-- Another test for the evaluated-ness of data2tag

module Main where

    data S e = A | B | C | D | E | F | G | H | I deriving (Eq)
    newtype R = T (S R) deriving (Eq)

    main = do { print (T A == T B) ; print (T I == T I) }


-- For testing +RTS -xc
import Control.Exception
main = try (evaluate (f ())) :: IO (Either SomeException ())

f x = g x

g x = error (show x)


-- Not really a code-gen test, but this program gave
-- incorrect results in Hugs (Hugs Trac #37), so I
-- thought I'd add it to GHC's test suite.

module Main where

data MInt = Zero | Succ MInt | Pred MInt deriving Show

tn :: Int -> MInt
tn x | x<0 = Pred (tn (x+1))
tn 0     =  Zero
tn n     = Succ (tn (n - 1))

ti :: MInt -> Int
ti Zero = 0
ti (Succ x) = 1+(ti x)
ti (Pred x) = (ti x) -1

testi :: (MInt -> MInt -> MInt) -> (Int -> Int -> Int) -> Int -> Int -> Bool
testi f g x y = (ti (f (tn x) (tn y))) /= (g x y)

myMul x y = tn ((ti x) * (ti y))

-- test should be empty!
test = [ (x,y,ti (myMul (tn x) (tn y)),x * y)
       | x<-[-100, -99, -98, -97, -2, -1, 0, 1, 2, 97, 98, 99, 100],
         y<-([-100..(-1)]++[1..100]),
         testi myMul (*)  x y ]

main = print test


-- GHC 6.6 compiled YHC wrong; this is a cutdown testcase (from trac #1171).

module Main where

import System.Directory

data Error
    = ErrorFileNone
    | ErrorFileMany
        FilePath    -- file you were looking for

raiseError ErrorFileNone = error "Error: File not found"
raiseError (ErrorFileMany file) = error $ "Error: Found file multiple times: "++file

data PackageData = PackageData [FilePath] deriving Show

getModule :: PackageData -> String -> IO ()
getModule (PackageData rs@(root:rest)) file =
        do local <- testPackage root
           res <- testPackage root
           print (local, res)
           case (local,res) of
                ([x], _) -> return ()
                (_, [x]) -> return ()
                ([], []) -> raiseError $ ErrorFileNone
                (as, bs) -> if as++bs == [] then error "Empty as++bs" else raiseError $ ErrorFileMany file
    where
        testPackage pkg =
            do
                bHi <- doesFileExist "/does/not/exist"
                return [("","") | bHi]

main = getModule (PackageData ["7"]) "13"


-- tickled a bug in stack squeezing in 6.8.2.  unsafePerformIO calls
-- noDuplicate#, which marks the update frames on the stack, and was
-- preventing subsequent update frames from being collapsed with the
-- marked frame.

module Main where

import System.IO.Unsafe

main = print (sim (replicate 100000 ()))

sim []     = True
sim (_:xs) = badStack (sim xs)

goodStack x = fromJust (Just x)          --no stack overflow
badStack  x = unsafePerformIO (return x) --stack overflow

fromJust (Just x) = x


module Main where

newtype Test = Test { var :: String }

{-
hugs (Sept 2006) gives
Program error: pattern match failure: instShow_v16_v1443 (Test_Test "a")
Program error: pattern match failure: instShow_v16_v1443 (Test_Test "b")
hugs trac #46
-}

main = do print (var x)
          print (var (y{var="b"}))
    where x = Test { var = "a" }
          y = Test "a"


module Main where

newtype T = C { f :: String }

{-
hugs (Sept 2006) gives
"bc"
Program error: Prelude.undefined
hugs trac #48
-}

main = do print $ case C "abc" of
                  C { f = v } -> v
          print $ case undefined of
                  C {} -> True


{-
Check that we aren't making gcc misinterpret our strings as trigraphs.
Trac #2968.
http://gcc.gnu.org/onlinedocs/cpp/Initial-processing.html
-}

module Main where

main :: IO ()
main = do putStrLn "??("
          putStrLn "??)"
          putStrLn "??<"
          putStrLn "??>"
          putStrLn "??="
          putStrLn "??/"
          putStrLn "??'"
          putStrLn "??!"
          putStrLn "??-"


{-# LANGUAGE MagicHash, UnboxedTuples #-}

-- !!! simple tests of copying/cloning primitive arrays
--

module Main ( main ) where

import GHC.Exts hiding (IsList(..))
import GHC.Prim
import GHC.ST

main :: IO ()
main = putStr
       (test_copyArray
        ++ "\n" ++ test_copyMutableArray
        ++ "\n" ++ test_copyMutableArrayOverlap
        ++ "\n" ++ test_cloneArray
        ++ "\n" ++ test_cloneArrayStatic
        ++ "\n" ++ test_cloneMutableArray
        ++ "\n" ++ test_cloneMutableArrayEmpty
        ++ "\n" ++ test_cloneMutableArrayStatic
        ++ "\n" ++ test_freezeArray
        ++ "\n" ++ test_freezeArrayStatic
        ++ "\n" ++ test_thawArray
        ++ "\n" ++ test_thawArrayStatic
        ++ "\n"
       )

------------------------------------------------------------------------
-- Constants

-- All allocated arrays are of this size
len :: Int
len = 130

-- We copy these many elements
copied :: Int
copied = len - 2

copiedStatic :: Int
copiedStatic = 16
{-# INLINE copiedStatic #-}  -- to make sure optimization triggers

------------------------------------------------------------------------
-- copyArray#

-- Copy a slice of the source array into a destination array and check
-- that the copy succeeded.
test_copyArray :: String
test_copyArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            src <- unsafeFreezeArray src
            dst <- newArray len (-1)
            -- Leave the first and last element untouched
            copyArray src 1 dst 1 copied
            unsafeFreezeArray dst
    in shows (toList dst len) "\n"

------------------------------------------------------------------------
-- copyMutableArray#

-- Copy a slice of the source array into a destination array and check
-- that the copy succeeded.
test_copyMutableArray :: String
test_copyMutableArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            dst <- newArray len (-1)
            -- Leave the first and last element untouched
            copyMutableArray src 1 dst 1 copied
            unsafeFreezeArray dst
    in shows (toList dst len) "\n"

-- Perform a copy where the source and destination part overlap.
test_copyMutableArrayOverlap :: String
test_copyMutableArrayOverlap =
    let arr = runST $ do
            marr <- fromList inp
            -- Overlap of two elements
            copyMutableArray marr 5 marr 7 8
            unsafeFreezeArray marr
    in shows (toList arr (length inp)) "\n"
  where
     -- This case was known to fail at some point.
     inp = [0,169,196,9,16,25,36,16,25,81,100,121,144,169,196]

------------------------------------------------------------------------
-- cloneArray#

-- Clone a slice of the source array into a destination array and
-- check that the clone succeeded.
test_cloneArray :: String
test_cloneArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            src <- unsafeFreezeArray src
            -- Don't include the first and last element.
            return $! cloneArray src 1 copied
    in shows (toList dst copied) "\n"

--  Check that the static-size optimization works.
test_cloneArrayStatic :: String
test_cloneArrayStatic =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            src <- unsafeFreezeArray src
            -- Don't include the first and last element.
            return $! cloneArray src 1 copiedStatic
    in shows (toList dst copiedStatic) "\n"

------------------------------------------------------------------------
-- cloneMutableArray#

-- Clone a slice of the source array into a destination array and
-- check that the clone succeeded.
test_cloneMutableArray :: String
test_cloneMutableArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            -- Don't include the first and last element.
            dst <- cloneMutableArray src 1 copied
            unsafeFreezeArray dst
    in shows (toList dst copied) "\n"

-- Check that zero-length clones work.
test_cloneMutableArrayEmpty :: String
test_cloneMutableArrayEmpty =
    let dst = runST $ do
            src <- newArray len 0
            dst <- cloneMutableArray src 0 0
            unsafeFreezeArray dst
    in shows (toList dst 0) "\n"

--  Check that the static-size optimization works.
test_cloneMutableArrayStatic :: String
test_cloneMutableArrayStatic =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            -- Don't include the first and last element.
            dst <- cloneMutableArray src 1 copiedStatic
            unsafeFreezeArray dst
    in shows (toList dst copiedStatic) "\n"

------------------------------------------------------------------------
-- freezeArray#

-- Clone a slice of the source array into a destination array and
-- check that the clone succeeded.
test_freezeArray :: String
test_freezeArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            -- Don't include the first and last element.
            freezeArray src 1 copied
    in shows (toList dst copied) "\n"

--  Check that the static-size optimization works.
test_freezeArrayStatic :: String
test_freezeArrayStatic =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            -- Don't include the first and last element.
            freezeArray src 1 copiedStatic
    in shows (toList dst copiedStatic) "\n"

------------------------------------------------------------------------
-- thawArray#

-- Clone a slice of the source array into a destination array and
-- check that the clone succeeded.
test_thawArray :: String
test_thawArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            src <- unsafeFreezeArray src
            -- Don't include the first and last element.
            dst <- thawArray src 1 copied
            unsafeFreezeArray dst
    in shows (toList dst copied) "\n"

--  Check that the static-size optimization works.
test_thawArrayStatic :: String
test_thawArrayStatic =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            src <- unsafeFreezeArray src
            -- Don't include the first and last element.
            dst <- thawArray src 1 copiedStatic
            unsafeFreezeArray dst
    in shows (toList dst copiedStatic) "\n"

------------------------------------------------------------------------
-- Test helpers

-- Initialize the elements of this array, starting at the given
-- offset.  The last parameter specifies the number of elements to
-- initialize.  Element at index @i@ takes the value @i*i@ (i.e. the
-- first actually modified element will take value @off*off@).
fill :: MArray s Int -> Int -> Int -> ST s ()
fill marr off count = go 0
  where
    go i
        | i >= count = return ()
        | otherwise = writeArray marr (off + i) (i*i) >> go (i + 1)

fromList :: [Int] -> ST s (MArray s Int)
fromList xs0 = do
    marr <- newArray (length xs0) bottomElem
    let go [] i = i `seq` return marr
        go (x:xs) i = writeArray marr i x >> go xs (i + 1)
    go xs0 0
  where
    bottomElem = error "undefined element"

------------------------------------------------------------------------
-- Convenience wrappers for Array# and MutableArray#

data Array a = Array { unArray :: Array# a }
data MArray s a = MArray { unMArray :: MutableArray# s a }

newArray :: Int -> a -> ST s (MArray s a)
newArray (I# n#) a = ST $ \s# -> case newArray# n# a s# of
    (# s2#, marr# #) -> (# s2#, MArray marr# #)

indexArray :: Array a -> Int -> a
indexArray arr i@(I# i#)
  | i < 0 || i >= len =
      error $ "bounds error, offset " ++ show i ++ ", length " ++ show len
  | otherwise = case indexArray# (unArray arr) i# of
      (# a #) -> a
  where len = lengthArray arr

writeArray :: MArray s a -> Int -> a -> ST s ()
writeArray marr i@(I# i#) a
  | i < 0 || i >= len =
      error $ "bounds error, offset " ++ show i ++ ", length " ++ show len
  | otherwise = ST $ \ s# ->
    case writeArray# (unMArray marr) i# a s# of
        s2# -> (# s2#, () #)
  where len = lengthMArray marr

lengthArray :: Array a -> Int
lengthArray arr = I# (sizeofArray# (unArray arr))

lengthMArray :: MArray s a -> Int
lengthMArray marr = I# (sizeofMutableArray# (unMArray marr))

unsafeFreezeArray :: MArray s a -> ST s (Array a)
unsafeFreezeArray marr = ST $ \ s# ->
    case unsafeFreezeArray# (unMArray marr) s# of
        (# s2#, arr# #) -> (# s2#, Array arr# #)

copyArray :: Array a -> Int -> MArray s a -> Int -> Int -> ST s ()
copyArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# ->
    case copyArray# (unArray src) six# (unMArray dst) dix# n# s# of
        s2# -> (# s2#, () #)

copyMutableArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
copyMutableArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# ->
    case copyMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of
        s2# -> (# s2#, () #)

cloneArray :: Array a -> Int -> Int -> Array a
cloneArray src (I# six#) (I# n#) = Array (cloneArray# (unArray src) six# n#)
{-# INLINE cloneArray #-}  -- to make sure optimization triggers

cloneMutableArray :: MArray s a -> Int -> Int -> ST s (MArray s a)
cloneMutableArray src (I# six#) (I# n#) = ST $ \ s# ->
    case cloneMutableArray# (unMArray src) six# n# s# of
        (# s2#, marr# #) -> (# s2#, MArray marr# #)
{-# INLINE cloneMutableArray #-}  -- to make sure optimization triggers

freezeArray :: MArray s a -> Int -> Int -> ST s (Array a)
freezeArray src (I# six#) (I# n#) = ST $ \ s# ->
    case freezeArray# (unMArray src) six# n# s# of
        (# s2#, arr# #) -> (# s2#, Array arr# #)
{-# INLINE freezeArray #-}  -- to make sure optimization triggers

thawArray :: Array a -> Int -> Int -> ST s (MArray s a)
thawArray src (I# six#) (I# n#) = ST $ \ s# ->
    case thawArray# (unArray src) six# n# s# of
        (# s2#, marr# #) -> (# s2#, MArray marr# #)
{-# INLINE thawArray #-}  -- to make sure optimization triggers

toList :: Array a -> Int -> [a]
toList arr n = go 0
  where
    go i | i >= n = []
         | otherwise = indexArray arr i : go (i+1)


{-# LANGUAGE MagicHash, UnboxedTuples #-}

module Main ( main ) where

import GHC.Exts
import GHC.Prim
import GHC.ST

main = putStr
       (test_sizeofArray
        ++ "\n" ++ test_sizeofMutableArray
        ++ "\n"
       )

test_sizeofArray :: String
test_sizeofArray = flip shows "\n" $ runST $ ST $ \ s# -> go 0 [] s#
  where
    go i@(I# i#) acc s#
        | i < 1000 = case newArray# i# 0 s# of
            (# s2#, marr# #) -> case unsafeFreezeArray# marr# s2# of
                (# s3#, arr# #) -> case sizeofArray# arr# of
                    j# -> go (i+1) ((I# j#):acc) s3#
        | otherwise = (# s#, reverse acc #)

test_sizeofMutableArray :: String
test_sizeofMutableArray = flip shows "\n" $ runST $ ST $ \ s# -> go 0 [] s#
  where
    go i@(I# i#) acc s#
        | i < 1000 = case newArray# i# 0 s# of
            (# s2#, marr# #) -> case sizeofMutableArray# marr# of
                    j# -> go (i+1) ((I# j#):acc) s2#
        | otherwise = (# s#, reverse acc #)


{-# LANGUAGE MagicHash, BangPatterns #-}

import Foreign.C
import Data.Word
import Foreign.Ptr
import GHC.Exts

import Control.Exception

hashStr  :: Ptr Word8 -> Int -> Int
hashStr (Ptr a#) (I# len#) = loop 0# 0#
   where
    loop h n | isTrue# (n GHC.Exts.==# len#) = I# h
             | otherwise  = loop h2 (n GHC.Exts.+# 1#)
          where !c = ord# (indexCharOffAddr# a# n)
                !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` 4091#

-- Infinite loops with new code generator + C-- optimizations
main = do
    withCStringLen "ff" $ \(ptr, l) -> do
        print (hashStr (castPtr ptr) l)


-- This test-case tickled a bug where an optimization pass incorrectly
-- reloaded a stack slot before the slot was initialized.  It was a bit
-- tricky to reproduce, and I don't really know why this particular
-- harness was necessary.

-- Miscompiled code must be in another module, otherwise problem doesn't
-- show up.
import Cgrun067A (miscompiledFn)
import Foreign.C.String

main = withCString "foobar" $ \p -> print =<< miscompiledFn p


module Cgrun067A (miscompiledFn) where

import Foreign.C
import Foreign

miscompiledFn :: CString -> IO String
miscompiledFn cp = do
  l <- lengthArray0 0 cp
  if l <= 0 then return "" else loop "" (l-1)
  where
    loop s i = do
        xval <- peekElemOff cp i
        let val = castCCharToChar xval
        val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1)


{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, MagicHash,
             UnboxedTuples #-}

-- !!! stress tests of copying/cloning primitive arrays

-- Note: You can run this test manually with an argument
-- (i.e. ./cgrun068 10000) if you want to run the stress test for
-- longer.

{-
Test strategy
=============

We create an array of arrays of integers. Repeatedly we then either

* allocate a new array in place of an old, or

* copy a random segment of an array into another array (which might be
  the source array).

By running this process long enough we hope to trigger any bugs
related to garbage collection or edge cases.

We only test copyMutableArray# and cloneArray# as they are
representative of all the primops.
-}

module Main ( main ) where

import Debug.Trace (trace)

import Control.Exception (assert)
import Control.Monad
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Class
import GHC.Exts hiding (IsList(..))
import GHC.ST hiding (liftST)
import Prelude hiding (length, read)
import qualified Prelude as P
import qualified Prelude as P
import System.Environment
import System.Random

main :: IO ()
main = do
    args <- getArgs
    -- Number of copies to perform
    let numMods = case args of
            [] -> 100
            [n] -> P.read n :: Int
    putStr (test_copyMutableArray numMods ++ "\n" ++
            test_cloneMutableArray numMods ++ "\n"
           )

-- Number of arrays
numArrays :: Int
numArrays = 100

-- Maxmimum length of a sub-array
maxLen :: Int
maxLen = 1024

-- Create an array of arrays, with each sub-array having random length
-- and content.
setup :: Rng s (MArray s (MArray s Int))
setup = do
    len <- rnd (1, numArrays)
    marr <- liftST $ new_ len
    let go i
            | i >= len = return ()
            | otherwise = do
                n <- rnd (1, maxLen)
                subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
                liftST $ write marr i subarr
                go (i+1)
    go 0
    return marr

-- Replace one of the sub-arrays with a newly allocated array.
allocate :: MArray s (MArray s Int) -> Rng s ()
allocate marr = do
    ix <- rnd (0, length marr - 1)
    n <- rnd (1, maxLen)
    subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
    liftST $ write marr ix subarr

type CopyFunction s a =
    MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()

-- Copy a random segment of an array onto another array, using the
-- supplied copy function.
copy :: MArray s (MArray s a) -> CopyFunction s a
     -> Rng s (Int, Int, Int, Int, Int)
copy marr f = do
    six <- rnd (0, length marr - 1)
    dix <- rnd (0, length marr - 1)
    src <- liftST $ read marr six
    dst <- liftST $ read marr dix
    let srcLen = length src
    srcOff <- rnd (0, srcLen - 1)
    let dstLen = length dst
    dstOff <- rnd (0, dstLen - 1)
    n <- rnd (0, min (srcLen - srcOff) (dstLen - dstOff))
    liftST $ f src srcOff dst dstOff n
    return (six, dix, srcOff, dstOff, n)

type CloneFunction s a = MArray s a -> Int -> Int -> ST s (MArray s a)

-- Clone a random segment of an array, replacing another array, using
-- the supplied clone function.
clone :: MArray s (MArray s a) -> CloneFunction s a
      -> Rng s (Int, Int, Int, Int)
clone marr f = do
    six <- rnd (0, length marr - 1)
    dix <- rnd (0, length marr - 1)
    src <- liftST $ read marr six
    let srcLen = length src
    -- N.B. The array length might be zero if we previously cloned
    -- zero elements from some array.
    srcOff <- rnd (0, max 0 (srcLen - 1))
    n <- rnd (0, srcLen - srcOff)
    dst <- liftST $ f src srcOff n
    liftST $ write marr dix dst
    return (six, dix, srcOff, n)

------------------------------------------------------------------------
-- copyMutableArray#

-- Copy a slice of the source array into a destination array and check
-- that the copy succeeded.
test_copyMutableArray :: Int -> String
test_copyMutableArray numMods = runST $ run $ do
    marr <- local setup
    marrRef <- setup
    let go i
            | i >= numMods = return "test_copyMutableArray: OK"
            | otherwise = do
                -- Either allocate or copy
                alloc <- rnd (True, False)
                if alloc then doAlloc else doCopy
                go (i+1)

        doAlloc = do
            local $ allocate marr
            allocate marrRef

        doCopy = do
            inp <- liftST $ asList marr
            _ <- local $ copy marr copyMArray
            (six, dix, srcOff, dstOff, n) <- copy marrRef copyMArraySlow
            el <- liftST $ asList marr
            elRef <- liftST $ asList marrRef
            when (el /= elRef) $
                fail inp el elRef six dix srcOff dstOff n
    go 0
  where
    fail inp el elRef six dix srcOff dstOff n =
        error $ "test_copyMutableArray: FAIL\n"
        ++ "   Input: " ++ unlinesShow inp
        ++ "    Copy: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
        ++ show srcOff ++ " dstOff: " ++ show dstOff ++ " n: " ++ show n ++ "\n"
        ++ "Expected: " ++ unlinesShow elRef
        ++ "  Actual: " ++ unlinesShow el

asList :: MArray s (MArray s a) -> ST s [[a]]
asList marr = toListM =<< mapArrayM toListM marr

unlinesShow :: Show a => [a] -> String
unlinesShow =  concatMap (\ x -> show x ++ "\n")

------------------------------------------------------------------------
-- cloneMutableArray#

-- Copy a slice of the source array into a destination array and check
-- that the copy succeeded.
test_cloneMutableArray :: Int -> String
test_cloneMutableArray numMods = runST $ run $ do
    marr <- local setup
    marrRef <- setup
    let go i
            | i >= numMods = return "test_cloneMutableArray: OK"
            | otherwise = do
                -- Either allocate or clone
                alloc <- rnd (True, False)
                if alloc then doAlloc else doClone
                go (i+1)

        doAlloc = do
            local $ allocate marr
            allocate marrRef

        doClone = do
            inp <- liftST $ asList marr
            _ <- local $ clone marr cloneMArray
            (six, dix, srcOff, n) <- clone marrRef cloneMArraySlow
            el <- liftST $ asList marr
            elRef <- liftST $ asList marrRef
            when (el /= elRef) $
                fail inp el elRef six dix srcOff n
    go 0
  where
    fail inp el elRef six dix srcOff n =
        error $ "test_cloneMutableArray: FAIL\n"
        ++ "   Input: " ++ unlinesShow inp
        ++ "   Clone: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
        ++ show srcOff ++ " n: " ++ show n ++ "\n"
        ++ "Expected: " ++ unlinesShow elRef
        ++ "  Actual: " ++ unlinesShow el

------------------------------------------------------------------------
-- Convenience wrappers for Array# and MutableArray#

data Array a = Array
    { unArray :: Array# a
    , lengthA :: {-# UNPACK #-} !Int}

data MArray s a = MArray
    { unMArray :: MutableArray# s a
    , lengthM :: {-# UNPACK #-} !Int}

class IArray a where
    length :: a -> Int
instance IArray (Array a) where
    length = lengthA
instance IArray (MArray s a) where
    length = lengthM

instance Eq a => Eq (Array a) where
    arr1 == arr2 = toList arr1 == toList arr2

new :: Int -> a -> ST s (MArray s a)
new n@(I# n#) a =
    assert (n >= 0) $
    ST $ \s# -> case newArray# n# a s# of
        (# s2#, marr# #) -> (# s2#, MArray marr# n #)

new_ :: Int -> ST s (MArray s a)
new_ n = new n (error "Undefined element")

write :: MArray s a -> Int -> a -> ST s ()
write marr i@(I# i#) a =
    assert (i >= 0) $
    assert (i < length marr) $
    ST $ \ s# ->
    case writeArray# (unMArray marr) i# a s# of
        s2# -> (# s2#, () #)

read :: MArray s a -> Int -> ST s a
read marr i@(I# i#) =
    assert (i >= 0) $
    assert (i < length marr) $
    ST $ \ s# ->
    readArray# (unMArray marr) i# s#

index :: Array a -> Int -> a
index arr i@(I# i#) =
    assert (i >= 0) $
    assert (i < length arr) $
    case indexArray# (unArray arr) i# of
        (# a #) -> a

unsafeFreeze :: MArray s a -> ST s (Array a)
unsafeFreeze marr = ST $ \ s# ->
    case unsafeFreezeArray# (unMArray marr) s# of
        (# s2#, arr# #) -> (# s2#, Array arr# (length marr) #)

toList :: Array a -> [a]
toList arr = go 0
  where
    go i | i >= length arr = []
         | otherwise = index arr i : go (i+1)

fromList :: [e] -> ST s (MArray s e)
fromList es = do
    marr <- new_ n
    let go !_ [] = return ()
        go i (x:xs) = write marr i x >> go (i+1) xs
    go 0 es
    return marr
  where
    n = P.length es

mapArrayM :: (a -> ST s b) -> MArray s a -> ST s (MArray s b)
mapArrayM f src = do
    dst <- new_ n
    let go i
            | i >= n = return dst
            | otherwise = do
                el <- read src i
                el' <- f el
                write dst i el'
                go (i+1)
    go 0
  where
    n = length src

toListM :: MArray s e -> ST s [e]
toListM marr =
    sequence [read marr i | i <- [0..(length marr)-1]]

------------------------------------------------------------------------
-- Wrappers around copy/clone primops

copyMArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
copyMArray src six@(I# six#) dst dix@(I# dix#) n@(I# n#) =
    assert (six >= 0) $
    assert (six + n <= length src) $
    assert (dix >= 0) $
    assert (dix + n <= length dst) $
    ST $ \ s# ->
    case copyMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of
        s2# -> (# s2#, () #)

cloneMArray :: MArray s a -> Int -> Int -> ST s (MArray s a)
cloneMArray marr off@(I# off#) n@(I# n#) =
    assert (off >= 0) $
    assert (off + n <= length marr) $
    ST $ \ s# ->
    case cloneMutableArray# (unMArray marr) off# n# s# of
        (# s2#, marr2 #) -> (# s2#, MArray marr2 n #)

------------------------------------------------------------------------
-- Manual versions of copy/clone primops.  Used to validate the
-- primops

copyMArraySlow :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()
copyMArraySlow !src !six !dst !dix n =
    assert (six >= 0) $
    assert (six + n <= length src) $
    assert (dix >= 0) $
    assert (dix + n <= length dst) $
       if six < dix
       then goB (six+n-1) (dix+n-1) 0  -- Copy backwards
       else goF six dix 0  -- Copy forwards
  where
    goF !i !j c
        | c >= n = return ()
        | otherwise = do b <- read src i
                         write dst j b
                         goF (i+1) (j+1) (c+1)
    goB !i !j c
        | c >= n = return ()
        | otherwise = do b <- read src i
                         write dst j b
                         goB (i-1) (j-1) (c+1)

cloneMArraySlow :: MArray s a -> Int -> Int -> ST s (MArray s a)
cloneMArraySlow !marr !off n =
    assert (off >= 0) $
    assert (off + n <= length marr) $ do
        marr2 <- new_ n
        let go !i !j c
                | c >= n = return marr2
                | otherwise = do
                    b <- read marr i
                    write marr2 j b
                    go (i+1) (j+1) (c+1)
        go off 0 0

------------------------------------------------------------------------
-- Utilities for simplifying RNG passing

newtype Rng s a = Rng { unRng :: StateT StdGen (ST s) a }
                deriving (Functor, Applicative, Monad)

-- Same as 'randomR', but using the RNG state kept in the 'Rng' monad.
rnd :: Random a => (a, a) -> Rng s a
rnd r = Rng $ do
    g <- get
    let (x, g') = randomR r g
    put g'
    return x

-- Run a sub-computation without affecting the RNG state.
local :: Rng s a -> Rng s a
local m = Rng $ do
    g <- get
    x <- unRng m
    put g
    return x

liftST :: ST s a -> Rng s a
liftST m = Rng $ lift m

run :: Rng s a -> ST s a
run = flip evalStateT (mkStdGen 13) . unRng


{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-}
module Main where

import GHC.Exts
import Control.Exception
import System.IO

foreign import prim "memintrinTest" basicTest :: Int# -> Int#

foreign import prim "testMemset8_0" testMemset8_0 :: Int# -> Int#
foreign import prim "testMemset8_8" testMemset8_8 :: Int# -> Int#
foreign import prim "testMemset8_9" testMemset8_9 :: Int# -> Int#
foreign import prim "testMemset8_10" testMemset8_10 :: Int# -> Int#
foreign import prim "testMemset8_11" testMemset8_11 :: Int# -> Int#
foreign import prim "testMemset8_12" testMemset8_12 :: Int# -> Int#
foreign import prim "testMemset8_13" testMemset8_13 :: Int# -> Int#
foreign import prim "testMemset8_14" testMemset8_14 :: Int# -> Int#
foreign import prim "testMemset8_15" testMemset8_15 :: Int# -> Int#
foreign import prim "testMemset8_16" testMemset8_16 :: Int# -> Int#
foreign import prim "testMemset4_0" testMemset4_0 :: Int# -> Int#
foreign import prim "testMemset4_4" testMemset4_4 :: Int# -> Int#
foreign import prim "testMemset4_5" testMemset4_5 :: Int# -> Int#
foreign import prim "testMemset4_6" testMemset4_6 :: Int# -> Int#
foreign import prim "testMemset4_7" testMemset4_7 :: Int# -> Int#
foreign import prim "testMemset4_8" testMemset4_8 :: Int# -> Int#

foreign import prim "testMemcpy8_0" testMemcpy8_0 :: Int# -> Int#
foreign import prim "testMemcpy8_8" testMemcpy8_8 :: Int# -> Int#
foreign import prim "testMemcpy8_9" testMemcpy8_9 :: Int# -> Int#
foreign import prim "testMemcpy8_10" testMemcpy8_10 :: Int# -> Int#
foreign import prim "testMemcpy8_11" testMemcpy8_11 :: Int# -> Int#
foreign import prim "testMemcpy8_12" testMemcpy8_12 :: Int# -> Int#
foreign import prim "testMemcpy8_13" testMemcpy8_13 :: Int# -> Int#
foreign import prim "testMemcpy8_14" testMemcpy8_14 :: Int# -> Int#
foreign import prim "testMemcpy8_15" testMemcpy8_15 :: Int# -> Int#
foreign import prim "testMemcpy8_16" testMemcpy8_16 :: Int# -> Int#
foreign import prim "testMemcpy4_0" testMemcpy4_0 :: Int# -> Int#
foreign import prim "testMemcpy4_4" testMemcpy4_4 :: Int# -> Int#
foreign import prim "testMemcpy4_5" testMemcpy4_5 :: Int# -> Int#
foreign import prim "testMemcpy4_6" testMemcpy4_6 :: Int# -> Int#
foreign import prim "testMemcpy4_7" testMemcpy4_7 :: Int# -> Int#
foreign import prim "testMemcpy4_8" testMemcpy4_8 :: Int# -> Int#

main = do
    putStrLn "Mem{cpy,set,move} Intrinsics Test..."
    _ <- evaluate (I# (basicTest 1#))

    _ <- evaluate (I# (testMemset8_0 1#))
    _ <- evaluate (I# (testMemset8_8 1#))
    _ <- evaluate (I# (testMemset8_9 1#))
    _ <- evaluate (I# (testMemset8_10 1#))
    _ <- evaluate (I# (testMemset8_11 1#))
    _ <- evaluate (I# (testMemset8_12 1#))
    _ <- evaluate (I# (testMemset8_13 1#))
    _ <- evaluate (I# (testMemset8_14 1#))
    _ <- evaluate (I# (testMemset8_15 1#))
    _ <- evaluate (I# (testMemset8_16 1#))
    _ <- evaluate (I# (testMemset4_0 1#))
    _ <- evaluate (I# (testMemset4_4 1#))
    _ <- evaluate (I# (testMemset4_5 1#))
    _ <- evaluate (I# (testMemset4_6 1#))
    _ <- evaluate (I# (testMemset4_7 1#))
    _ <- evaluate (I# (testMemset4_8 1#))

    _ <- evaluate (I# (testMemcpy8_0 1#))
    _ <- evaluate (I# (testMemcpy8_8 1#))
    _ <- evaluate (I# (testMemcpy8_9 1#))
    _ <- evaluate (I# (testMemcpy8_10 1#))
    _ <- evaluate (I# (testMemcpy8_11 1#))
    _ <- evaluate (I# (testMemcpy8_12 1#))
    _ <- evaluate (I# (testMemcpy8_13 1#))
    _ <- evaluate (I# (testMemcpy8_14 1#))
    _ <- evaluate (I# (testMemcpy8_15 1#))
    _ <- evaluate (I# (testMemcpy8_16 1#))
    _ <- evaluate (I# (testMemcpy4_0 1#))
    _ <- evaluate (I# (testMemcpy4_4 1#))
    _ <- evaluate (I# (testMemcpy4_5 1#))
    _ <- evaluate (I# (testMemcpy4_6 1#))
    _ <- evaluate (I# (testMemcpy4_7 1#))
    _ <- evaluate (I# (testMemcpy4_8 1#))
    putStrLn "Test Passed!"
    return ()


{-# LANGUAGE MagicHash, UnboxedTuples #-}

-- !!! simple tests of copying/cloning byte arrays
--

module Main ( main ) where

import GHC.Word
import GHC.Exts hiding (IsList(..))
import GHC.Prim
import GHC.ST
import GHC.IO
import GHC.Ptr

main = putStr
       (test_copyByteArray
        ++ "\n" ++ test_copyMutableByteArray
        ++ "\n" ++ test_copyMutableByteArrayOverlap
        ++ "\n" ++ test_copyByteArrayToAddr
        ++ "\n" ++ test_copyMutableByteArrayToAddr
        ++ "\n" ++ test_copyAddrToByteArray
        ++ "\n"
       )

------------------------------------------------------------------------
-- Constants

-- All allocated arrays are of this size
len :: Int
len = 130

-- We copy these many elements
copied :: Int
copied = len - 2

------------------------------------------------------------------------
-- copyByteArray#

-- Copy a slice of the source array into a destination array and check
-- that the copy succeeded.
test_copyByteArray :: String
test_copyByteArray =
    let dst = runST $ do
            src <- newByteArray len
            fill src 0 len
            src <- unsafeFreezeByteArray src
            dst <- newByteArray len
            -- Markers to detect errors
            writeWord8Array dst 0 255
            writeWord8Array dst (len-1) 255
            -- Leave the first and last element untouched
            copyByteArray src 1 dst 1 copied
            unsafeFreezeByteArray dst
    in shows (toList dst len) "\n"

------------------------------------------------------------------------
-- copyMutableByteArray#

-- Copy a slice of the source array into a destination array and check
-- that the copy succeeded.
test_copyMutableByteArray :: String
test_copyMutableByteArray =
    let dst = runST $ do
            src <- newByteArray len
            fill src 0 len
            dst <- newByteArray len
            -- Markers to detect errors
            writeWord8Array dst 0 255
            writeWord8Array dst (len-1) 255
            -- Leave the first and last element untouched
            copyMutableByteArray src 1 dst 1 copied
            unsafeFreezeByteArray dst
    in shows (toList dst len) "\n"

-- Perform a copy where the source and destination part overlap.
test_copyMutableByteArrayOverlap :: String
test_copyMutableByteArrayOverlap =
    let arr = runST $ do
            marr <- fromList inp
            -- Overlap of two elements
            copyMutableByteArray marr 5 marr 7 8
            unsafeFreezeByteArray marr
    in shows (toList arr (length inp)) "\n"
  where
     -- This case was known to fail at some point.
     inp = [0,169,196,9,16,25,36,16,25,81,100,121,144,169,196]

------------------------------------------------------------------------
-- copyByteArrayToAddr#

-- Copy a slice of the source array into a destination memory area and check
-- that the copy succeeded.
test_copyByteArrayToAddr :: String
test_copyByteArrayToAddr =
    let dst = runST $ do
            src <- newByteArray len
            fill src 0 len
            src <- unsafeFreezeByteArray src
            withNewPinnedByteArray len $ \dst dst_marr -> do
              -- Markers to detect errors
              writeWord8Array dst_marr 0 255
              writeWord8Array dst_marr (len-1) 255
              -- Leave the first and last element untouched
              copyByteArrayToAddr src 1 (dst `plusPtr` 1) copied
              unsafeFreezeByteArray dst_marr
    in shows (toList dst len) "\n"

------------------------------------------------------------------------
-- copyMutableByteArrayToAddr#

-- Copy a slice of the source array into a destination memory area and check
-- that the copy succeeded.
test_copyMutableByteArrayToAddr :: String
test_copyMutableByteArrayToAddr =
    let dst = runST $ do
            src <- newByteArray len
            fill src 0 len
            withNewPinnedByteArray len $ \dst dst_marr -> do
              -- Markers to detect errors
              writeWord8Array dst_marr 0 255
              writeWord8Array dst_marr (len-1) 255
              -- Leave the first and last element untouched
              copyMutableByteArrayToAddr src 1 (dst `plusPtr` 1) copied
              unsafeFreezeByteArray dst_marr
    in shows (toList dst len) "\n"

------------------------------------------------------------------------
-- copyAddrToByteArray#

-- Copy a slice of the source memory area into a destination array and check
-- that the copy succeeded.
test_copyAddrToByteArray :: String
test_copyAddrToByteArray =
    let dst = runST $
            withNewPinnedByteArray len $ \src src_marr -> do
              fill src_marr 0 len
              dst <- newByteArray len
              -- Markers to detect errors
              writeWord8Array dst 0 255
              writeWord8Array dst (len-1) 255
              -- Leave the first and last element untouched
              copyAddrToByteArray (src `plusPtr` 1) dst 1 copied
              unsafeFreezeByteArray dst
    in shows (toList dst len) "\n"

------------------------------------------------------------------------
-- Test helpers

-- Initialize the elements of this array, starting at the given
-- offset.  The last parameter specifies the number of elements to
-- initialize.  Element at index @i@ takes the value @i@ (i.e. the
-- first actually modified element will take value @off@).
fill :: MByteArray s -> Int -> Int -> ST s ()
fill marr off count = go 0
  where
    go i
        | i >= fromIntegral count = return ()
        | otherwise = do writeWord8Array marr (off + i) (fromIntegral i)
                         go (i + 1)

fromList :: [Word8] -> ST s (MByteArray s)
fromList xs0 = do
    marr <- newByteArray (length xs0)
    let go [] i = i `seq` return marr
        go (x:xs) i = writeWord8Array marr i x >> go xs (i + 1)
    go xs0 0

------------------------------------------------------------------------
-- Convenience wrappers for ByteArray# and MutableByteArray#

data ByteArray = ByteArray { unBA :: ByteArray# }
data MByteArray s = MByteArray { unMBA :: MutableByteArray# s }

newByteArray :: Int -> ST s (MByteArray s)
newByteArray (I# n#) = ST $ \s# -> case newByteArray# n# s# of
    (# s2#, marr# #) -> (# s2#, MByteArray marr# #)

newPinnedByteArray :: Int -> ST s (Ptr (), MByteArray s)
newPinnedByteArray (I# n#) = ST $ \s# ->
    case newPinnedByteArray# n# s# of
        (# s2#, marr# #) ->
          (# s2#, (Ptr (byteArrayContents# (unsafeCoerce# marr#)),
                  MByteArray marr#) #)

withNewPinnedByteArray :: Int -> (Ptr () -> MByteArray s -> ST s a) -> ST s a
withNewPinnedByteArray n action = do
    (ptr, marr) <- newPinnedByteArray n
    x <- action ptr marr
    touch marr
    return x

touch :: a -> ST s ()
touch a = unsafeIOToST $ IO $ \s# ->
    case touch# a s# of
        s2# -> (# s2#, () #)

indexWord8Array :: ByteArray -> Int -> Word8
indexWord8Array arr (I# i#) = case indexWord8Array# (unBA arr) i# of
    a -> W8# a

writeWord8Array :: MByteArray s -> Int -> Word8 -> ST s ()
writeWord8Array marr (I# i#) (W8# a) = ST $ \ s# ->
    case writeWord8Array# (unMBA marr) i# a s# of
        s2# -> (# s2#, () #)

unsafeFreezeByteArray :: MByteArray s -> ST s (ByteArray)
unsafeFreezeByteArray marr = ST $ \ s# ->
    case unsafeFreezeByteArray# (unMBA marr) s# of
        (# s2#, arr# #) -> (# s2#, ByteArray arr# #)

copyByteArray :: ByteArray -> Int -> MByteArray s -> Int -> Int -> ST s ()
copyByteArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# ->
    case copyByteArray# (unBA src) six# (unMBA dst) dix# n# s# of
        s2# -> (# s2#, () #)

copyMutableByteArray :: MByteArray s -> Int -> MByteArray s -> Int -> Int
                     -> ST s ()
copyMutableByteArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# ->
    case copyMutableByteArray# (unMBA src) six# (unMBA dst) dix# n# s# of
        s2# -> (# s2#, () #)

copyAddrToByteArray :: Ptr () -> MByteArray s -> Int -> Int -> ST s ()
copyAddrToByteArray (Ptr src#) dst (I# dix#) (I# n#) = ST $ \ s# ->
    case copyAddrToByteArray# src# (unMBA dst) dix# n# s# of
        s2# -> (# s2#, () #)

copyByteArrayToAddr :: ByteArray -> Int -> Ptr () -> Int -> ST s ()
copyByteArrayToAddr src (I# six#) (Ptr dst#) (I# n#) = ST $ \ s# ->
    case copyByteArrayToAddr# (unBA src) six# dst# n# s# of
        s2# -> (# s2#, () #)

copyMutableByteArrayToAddr :: MByteArray s -> Int -> Ptr () -> Int -> ST s ()
copyMutableByteArrayToAddr src (I# six#) (Ptr dst#) (I# n#) = ST $ \ s# ->
    case copyMutableByteArrayToAddr# (unMBA src) six# dst# n# s# of
        s2# -> (# s2#, () #)

toList :: ByteArray -> Int -> [Word8]
toList arr n = go 0
  where
    go i | i >= n = []
         | otherwise = indexWord8Array arr i : go (i+1)


{-# LANGUAGE BangPatterns, CPP, MagicHash #-}

module Main ( main ) where

import Data.Bits
import GHC.Prim
import GHC.Word

#include "MachDeps.h"

main = putStr
       (test_popCnt ++ "\n"
        ++ test_popCnt8 ++ "\n"
        ++ test_popCnt16 ++ "\n"
        ++ test_popCnt32 ++ "\n"
        ++ test_popCnt64 ++ "\n"
        ++ "\n"
       )

popcnt :: Word -> Word
popcnt (W# w#) = W# (popCnt# w#)

popcnt8 :: Word -> Word
popcnt8 (W# w#) = W# (popCnt8# w#)

popcnt16 :: Word -> Word
popcnt16 (W# w#) = W# (popCnt16# w#)

popcnt32 :: Word -> Word
popcnt32 (W# w#) = W# (popCnt32# w#)

popcnt64 :: Word64 -> Word
popcnt64 (W64# w#) =
#if SIZEOF_HSWORD == 4
    W# (popCnt64# w#)
#else
    W# (popCnt# w#)
#endif

-- Cribbed from http://ghc.haskell.org/trac/ghc/ticket/3563
slowPopcnt :: Word -> Word
slowPopcnt x = count' (bitSize x) x 0
  where
    count' 0 _ !acc = acc
    count' n x acc  = count' (n-1) (x `shiftR` 1)
                      (acc + if x .&. 1 == 1 then 1 else 0)

test_popCnt = test popcnt slowPopcnt
test_popCnt8 = test popcnt8 (slowPopcnt . fromIntegral . (mask 8 .&.))
test_popCnt16 = test popcnt16 (slowPopcnt . fromIntegral . (mask 16 .&.))
test_popCnt32 = test popcnt32 (slowPopcnt . fromIntegral . (mask 32 .&.))
test_popCnt64 = test popcnt64 (slowPopcnt . fromIntegral . (mask 64 .&.))

mask n = (2 ^ n) - 1

test :: (Show a, Num a) => (a -> Word) -> (a -> Word) -> String
test fast slow = case failing of
    [] -> "OK"
    ((_, e, a, i):xs) ->
        "FAIL\n" ++ "   Input: " ++ show i ++ "\nExpected: " ++ show e ++
        "\n  Actual: " ++ show a
  where
    failing = dropWhile ( \(b,_,_,_) -> b)
              . map (\ x -> (slow x == fast x, slow x, fast x, x)) $ cases
    expected = map slow cases
    actual = map fast cases
    -- 10 random numbers
#if SIZEOF_HSWORD == 4
    cases = [1480294021,1626858410,2316287658,1246556957,3806579062,65945563,
             1521588071,791321966,1355466914,2284998160]
#elif SIZEOF_HSWORD == 8
    cases = [11004539497957619752,5625461252166958202,1799960778872209546,
             16979826074020750638,12789915432197771481,11680809699809094550,
             13208678822802632247,13794454868797172383,13364728999716654549,
             17516539991479925226]
#else
# error Unexpected word size
#endif


{-# LANGUAGE BangPatterns, CPP, MagicHash #-}

{- Note!
   If you see output like

        Expected: 48042
          Actual: 48042

   from this test, it means that the "actual" Word16 (or Word32)
   has higher bits that are nonzero, which is not allowed!
   See GHC.Word for an explanation.
-}

module Main ( main ) where

import Data.Bits
import GHC.Prim
import GHC.Word

#include "MachDeps.h"

main :: IO ()
main = do putStrLn test_primop_bSwap16
          putStrLn test_primop_bSwap32
          putStrLn test_primop_bSwap64
          putStrLn test_base_bSwap16
          putStrLn test_base_bSwap32
          putStrLn test_base_bSwap64
          putStrLn test'_base_bSwap16
          putStrLn test'_base_bSwap32
          putStrLn test'_base_bSwap64

bswap16 :: Word16 -> Word16
bswap16 (W16# w#) = W16# (narrow16Word# (byteSwap16# w#))

bswap32 :: Word32 -> Word32
bswap32 (W32# w#) = W32# (narrow32Word# (byteSwap32# w#))

bswap64 :: Word64 -> Word64
bswap64 (W64# w#) = W64# (byteSwap64# w#)

slowBswap64 :: Word64 -> Word64
slowBswap64 w =
        (w `shiftR` 56)                  .|. (w `shiftL` 56)
    .|. ((w `shiftR` 40) .&. 0xff00)     .|. ((w .&. 0xff00) `shiftL` 40)
    .|. ((w `shiftR` 24) .&. 0xff0000)   .|. ((w .&. 0xff0000) `shiftL` 24)
    .|. ((w `shiftR` 8)  .&. 0xff000000) .|. ((w .&. 0xff000000) `shiftL` 8)

-- | swap endianness on a Word32
slowBswap32 :: Word32 -> Word32
slowBswap32 w =
         (w `shiftR` 24)             .|. (w `shiftL` 24)
     .|. ((w `shiftR` 8) .&. 0xff00) .|. ((w .&. 0xff00) `shiftL` 8)

-- | swap endianness on a Word16
slowBswap16 :: Word16 -> Word16
slowBswap16 w = (w `shiftR` 8) .|. (w `shiftL` 8)

-- Test the primops directly.
test_primop_bSwap16 = test casesW16 bswap16 slowBswap16
test_primop_bSwap32 = test casesW32 bswap32 slowBswap32
test_primop_bSwap64 = test casesW64 bswap64 slowBswap64

-- Test the wrappers in GHC.Word, inlined.
-- Inlining matters because it means we are
-- testing the backend used to run the test,
-- rather than the backend used to build base.
test_base_bSwap16 = test casesW16 byteSwap16 slowBswap16
test_base_bSwap32 = test casesW32 byteSwap32 slowBswap32
test_base_bSwap64 = test casesW64 byteSwap64 slowBswap64

-- Test the wrappers in GHC.Word, not inlined.
test'_base_bSwap16 = test' casesW16 byteSwap16 slowBswap16
test'_base_bSwap32 = test' casesW32 byteSwap32 slowBswap32
test'_base_bSwap64 = test' casesW64 byteSwap64 slowBswap64

{-# INLINE test #-}
test :: (Eq a, Show a, Num a) => [a] -> (a -> a) -> (a -> a) -> String
test cases fast slow = case failing of
    [] -> "OK"
    ((_, e, a, i):xs) ->
        "FAIL\n" ++ "   Input: " ++ show i ++ "\nExpected: " ++ show e ++
        "\n  Actual: " ++ show a
  where
    failing = dropWhile ( \(b,_,_,_) -> b)
              . map (\ x -> (slow x == fast x, slow x, fast x, x)) $ cases
    expected = map slow cases
    actual = map fast cases

{-# NOINLINE test' #-}
test' :: (Eq a, Show a, Num a) => [a] -> (a -> a) -> (a -> a) -> String
test' = test

casesW16 = [0xff00,0xf021,0x1234,0x5620,0x5463,0x0000,0xa00f,0x0201,0x2901,
            0xaabb]
casesW32 = [1480294021,1626858410,2316287658,1246556957,3806579062,65945563,
            1521588071,791321966,1355466914,2284998160]
casesW64 = [11004539497957619752,5625461252166958202,1799960778872209546,
            16979826074020750638,12789915432197771481,11680809699809094550,
            13208678822802632247,13794454868797172383,13364728999716654549,
            17516539991479925226]


-- This test exercises the "large block" allocation code in the
-- scheduler, where the mutator requests more than a block's worth of
-- memory.

longlistof x = [
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,
  x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x
  ]

main = print (sum (concat (map longlistof [1..100])))


{-# LANGUAGE BangPatterns, CPP, MagicHash #-}

module Main ( main ) where

import Data.Bits
import GHC.Int
import GHC.Prim
import GHC.Word
import Data.Int
import Data.Word

#include "MachDeps.h"

main = putStr
        (   test_pdep   ++ "\n"
        ++  test_pdep8  ++ "\n"
        ++  test_pdep16 ++ "\n"
        ++  test_pdep32 ++ "\n"
        ++  test_pdep64 ++ "\n"
        ++  "\n"
        )

class Pdep a where
  pdep :: a -> a -> a

instance Pdep Word where
  pdep (W#   src#) (W#   mask#) = W#   (pdep#   src# mask#)

instance Pdep Word8 where
  pdep (W8#  src#) (W8#  mask#) = W8#  (pdep8#  src# mask#)

instance Pdep Word16 where
  pdep (W16# src#) (W16# mask#) = W16# (pdep16# src# mask#)

instance Pdep Word32 where
  pdep (W32# src#) (W32# mask#) = W32# (pdep32# src# mask#)

instance Pdep Word64 where
  pdep (W64# src#) (W64# mask#) = W64# (pdep64# src# mask#)

class SlowPdep a where
  slowPdep :: a -> a -> a

instance SlowPdep Word where
  slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))

instance SlowPdep Word8 where
  slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))

instance SlowPdep Word16 where
  slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))

instance SlowPdep Word32 where
  slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))

instance SlowPdep Word64 where
  slowPdep s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))

slowPdep64 :: Word64 -> Word64 -> Word64
slowPdep64 = slowPdep64' 0

slowPdep32 :: Word32 -> Word32 -> Word32
slowPdep32 s m = fromIntegral (slowPdep64 (fromIntegral s) (fromIntegral m))

lsb :: Word64 -> Word64
lsb src = fromIntegral ((fromIntegral (src `shiftL` 63) :: Int64) `shiftR` 63)

slowPdep64' :: Word64 -> Word64 -> Word64 -> Word64
slowPdep64' result src mask = if lowest /= 0
  then slowPdep64' newResult (src `shiftR` 1) (mask .&. complement lowest)
  else result
  where lowest    = (-mask) .&. mask
        newResult = (result .|. ((lsb src) .&. lowest))

test_pdep   = test (0 :: Word  ) pdep slowPdep
test_pdep8  = test (0 :: Word8 ) pdep slowPdep
test_pdep16 = test (0 :: Word16) pdep slowPdep
test_pdep32 = test (0 :: Word32) pdep slowPdep
test_pdep64 = test (0 :: Word64) pdep slowPdep

mask n = (2 ^ n) - 1

fst4 :: (a, b, c, d) -> a
fst4 (a, _, _, _) = a

runCase :: Eq a
        => (a -> a -> a)
        -> (a -> a -> a)
        -> (a, a)
        -> (Bool, a, a, (a, a))
runCase fast slow (x, y) = (slow x y == fast x y, slow x y, fast x y, (x, y))

test :: (Show a, Num a, Eq a) => a -> (a -> a -> a) -> (a -> a -> a) -> String
test _ fast slow = case failing of
    [] -> "OK"
    ((_, e, a, i):xs) ->
        "FAIL\n" ++ "   Input: " ++ show i ++ "\nExpected: " ++ show e ++
        "\n  Actual: " ++ show a
  where failing = dropWhile fst4 . map (runCase fast slow) $ cases
        cases   = (,) <$> numbers <*> numbers
        -- 10 random numbers
#if SIZEOF_HSWORD == 4
        numbers = [ 1480294021, 1626858410, 2316287658, 1246556957, 3806579062
                  , 65945563  , 1521588071, 791321966 , 1355466914, 2284998160
                  ]
#elif SIZEOF_HSWORD == 8
        numbers = [ 11004539497957619752, 5625461252166958202
                  , 1799960778872209546 , 16979826074020750638
                  , 12789915432197771481, 11680809699809094550
                  , 13208678822802632247, 13794454868797172383
                  , 13364728999716654549, 17516539991479925226
                  ]
#else
# error Unexpected word size
#endif


{-# LANGUAGE BangPatterns, CPP, MagicHash #-}

module Main ( main ) where

import Data.Bits
import GHC.Int
import GHC.Prim
import GHC.Word
import Data.Int
import Data.Word

#include "MachDeps.h"

main = putStr
        (   test_pext   ++ "\n"
        ++  test_pext8  ++ "\n"
        ++  test_pext16 ++ "\n"
        ++  test_pext32 ++ "\n"
        ++  test_pext64 ++ "\n"
        ++  "\n"
        )

class Pext a where
  pext :: a -> a -> a

instance Pext Word where
  pext (W#   src#) (W#   mask#) = W#   (pext#   src# mask#)

instance Pext Word8 where
  pext (W8#  src#) (W8#  mask#) = W8#  (pext8#  src# mask#)

instance Pext Word16 where
  pext (W16# src#) (W16# mask#) = W16# (pext16# src# mask#)

instance Pext Word32 where
  pext (W32# src#) (W32# mask#) = W32# (pext32# src# mask#)

instance Pext Word64 where
  pext (W64# src#) (W64# mask#) = W64# (pext64# src# mask#)

class SlowPext a where
  slowPext :: a -> a -> a

instance SlowPext Word where
  slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))

instance SlowPext Word8 where
  slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))

instance SlowPext Word16 where
  slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))

instance SlowPext Word32 where
  slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))

instance SlowPext Word64 where
  slowPext s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))

slowPext64 :: Word64 -> Word64 -> Word64
slowPext64 = slowPext64' 0 0 0

slowPext32 :: Word32 -> Word32 -> Word32
slowPext32 s m = fromIntegral (slowPext64 (fromIntegral s) (fromIntegral m))

slowPext64' :: Word64 -> Int -> Int -> Word64 -> Word64 -> Word64
slowPext64' result offset index src mask = if index /= 64
  then if maskBit /= 0
          then slowPext64' nextResult (offset + 1) (index + 1) src mask
          else slowPext64' result      offset      (index + 1) src mask
  else result
  where srcBit      = (src  `shiftR` index) .&. 1
        maskBit     = (mask `shiftR` index) .&. 1
        nextResult  = result .|. (srcBit `shiftL` offset)

test_pext   = test (0 :: Word  ) pext slowPext
test_pext8  = test (0 :: Word8 ) pext slowPext
test_pext16 = test (0 :: Word16) pext slowPext
test_pext32 = test (0 :: Word32) pext slowPext
test_pext64 = test (0 :: Word64) pext slowPext

mask n = (2 ^ n) - 1

fst4 :: (a, b, c, d) -> a
fst4 (a, _, _, _) = a

runCase :: Eq a
        => (a -> a -> a)
        -> (a -> a -> a)
        -> (a, a)
        -> (Bool, a, a, (a, a))
runCase fast slow (x, y) = (slow x y == fast x y, slow x y, fast x y, (x, y))

test :: (Show a, Num a, Eq a) => a -> (a -> a -> a) -> (a -> a -> a) -> String
test _ fast slow = case failing of
    [] -> "OK"
    ((_, e, a, i):xs) ->
        "FAIL\n" ++ "   Input: " ++ show i ++ "\nExpected: " ++ show e ++
        "\n  Actual: " ++ show a
  where failing = dropWhile fst4 . map (runCase fast slow) $ cases
        cases   = (,) <$> numbers <*> numbers
        -- 10 random numbers
#if SIZEOF_HSWORD == 4
        numbers = [ 1480294021, 1626858410, 2316287658, 1246556957, 3806579062
                  , 65945563  , 1521588071, 791321966 , 1355466914, 2284998160
                  ]
#elif SIZEOF_HSWORD == 8
        numbers = [ 11004539497957619752, 5625461252166958202
                  , 1799960778872209546 , 16979826074020750638
                  , 12789915432197771481, 11680809699809094550
                  , 13208678822802632247, 13794454868797172383
                  , 13364728999716654549, 17516539991479925226
                  ]
#else
# error Unexpected word size
#endif


{-# LANGUAGE BangPatterns, CPP, MagicHash #-}

module Main ( main ) where

import Data.Bits
import GHC.Prim
import GHC.Word

#include "MachDeps.h"

main = putStr
       (test_lzCnt ++ "\n"
        ++ test_lzCnt8 ++ "\n"
        ++ test_lzCnt16 ++ "\n"
        ++ test_lzCnt32 ++ "\n"
        ++ test_lzCnt64 ++ "\n"
        ++ "\n"
        ++ test_tzCnt ++ "\n"
        ++ test_tzCnt8 ++ "\n"
        ++ test_tzCnt16 ++ "\n"
        ++ test_tzCnt32 ++ "\n"
        ++ test_tzCnt64 ++ "\n"
        ++ "\n"
       )

lzcnt :: Word -> Word
lzcnt (W# w#) = W# (clz# w#)

lzcnt8 :: Word -> Word
lzcnt8 (W# w#) = W# (clz8# w#)

lzcnt16 :: Word -> Word
lzcnt16 (W# w#) = W# (clz16# w#)

lzcnt32 :: Word -> Word
lzcnt32 (W# w#) = W# (clz32# w#)

lzcnt64 :: Word64 -> Word
lzcnt64 (W64# w#) =
#if SIZEOF_HSWORD == 4
    W# (clz64# w#)
#else
    W# (clz# w#)
#endif

lzcnt_slow :: Int -> Word -> Word
lzcnt_slow size x = fromIntegral $ min size $ length $ takeWhile (== False) $ reverse $ map (testBit x) [0 .. size - 1]

tzcnt :: Word -> Word
tzcnt (W# w#) = W# (ctz# w#)

tzcnt8 :: Word -> Word
tzcnt8 (W# w#) = W# (ctz8# w#)

tzcnt16 :: Word -> Word
tzcnt16 (W# w#) = W# (ctz16# w#)

tzcnt32 :: Word -> Word
tzcnt32 (W# w#) = W# (ctz32# w#)

tzcnt64 :: Word64 -> Word
tzcnt64 (W64# w#) =
#if SIZEOF_HSWORD == 4
    W# (ctz64# w#)
#else
    W# (ctz# w#)
#endif

tzcnt_slow :: Int -> Word -> Word
tzcnt_slow size x = fromIntegral $ min size $ length $ takeWhile (== False) $ map (testBit x) [0 .. size - 1]

test_lzCnt = test "lzcnt" lzcnt (lzcnt_slow (8 * SIZEOF_HSWORD))
test_lzCnt8 = test "lzcnt8" lzcnt8 (lzcnt_slow 8 . fromIntegral . (mask 8 .&.))
test_lzCnt16 = test "lzcnt16" lzcnt16 (lzcnt_slow 16 . fromIntegral . (mask 16 .&.))
test_lzCnt32 = test "lzcnt32" lzcnt32 (lzcnt_slow 32 . fromIntegral . (mask 32 .&.))
test_lzCnt64 = test "lzcnt64" lzcnt64 (lzcnt_slow 64 . fromIntegral . (mask 64 .&.))

test_tzCnt = test "tzcnt" tzcnt (tzcnt_slow (8 * SIZEOF_HSWORD))
test_tzCnt8 = test "tzcnt8" tzcnt8 (tzcnt_slow 8 . fromIntegral . (mask 8 .&.))
test_tzCnt16 = test "tzcnt16" tzcnt16 (tzcnt_slow 16 . fromIntegral . (mask 16 .&.))
test_tzCnt32 = test "tzcnt32" tzcnt32 (tzcnt_slow 32 . fromIntegral . (mask 32 .&.))
test_tzCnt64 = test "tzcnt64" tzcnt64 (tzcnt_slow 64 . fromIntegral . (mask 64 .&.))

mask n = (2 ^ n) - 1

test :: (Show a, Num a) => String -> (a -> Word) -> (a -> Word) -> String
test name fast slow = case failing of
    [] -> "OK"
    ((_, e, a, i):xs) ->
        "FAIL " ++ name ++ "\n" ++ "   Input: " ++ show i ++ "\nExpected: " ++ show e ++
        "\n  Actual: " ++ show a
  where
    failing = dropWhile ( \(b,_,_,_) -> b)
              . map (\ x -> (slow x == fast x, slow x, fast x, x)) $ cases
    expected = map slow cases
    actual = map fast cases
#if SIZEOF_HSWORD == 4
    cases = [0, 1, 2, 1480294021,1626858410,2316287658,1246556957,3806579062,65945563,
             1521588071,791321966,1355466914,2284998160]
#elif SIZEOF_HSWORD == 8
    cases = [0, 1, 2, 11004539497957619752,5625461252166958202,1799960778872209546,
             16979826074020750638,12789915432197771481,11680809699809094550,
             13208678822802632247,13794454868797172383,13364728999716654549,
             17516539991479925226]
#else
# error Unexpected word size
#endif


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE StaticPointers     #-}

-- | A test to use symbols produced by the static form.
module Main(main) where

import Data.Typeable
import GHC.StaticPtr

main :: IO ()
main = do
  lookupKey (static (id . id)) >>= \f -> print $ f (1 :: Int)
  lookupKey (static method :: StaticPtr (Char -> Int)) >>= \f -> print $ f 'a'
  print $ deRefStaticPtr (static g)
  print $ deRefStaticPtr p0 'a'
  print $ deRefStaticPtr (static t_field) $ T 'b'
 where
  g :: String
  g = "found"

lookupKey :: StaticPtr a -> IO a
lookupKey p = unsafeLookupStaticPtr (staticKey p) >>= \case
  Just p -> return $ deRefStaticPtr p
  Nothing -> error $ "couldn't find " ++ show (staticPtrInfo p)

p0 :: Typeable a => StaticPtr (a -> a)
p0 = static (\x -> x)

data T a = T { t_field :: a }
  deriving Typeable

class C1 a where
  method :: a -> Int

instance C1 Char where
  method = const 0


{-# LANGUAGE TupleSections #-}

-- Generates CmmSwitchTest.hs

import qualified Data.Set as S
import Data.Int
import Data.Word
import Data.List
import System.Environment

output :: Integer -> Integer
output n = n`div`2 + 42

def :: Integer
def = 1337

data Bits = X32 | X64
    deriving Eq
type Spec = (String, Bool, [Integer], Bits)

primtyp True = "Int#"
primtyp False = "Word#"

con True = "I#"
con False = "W#"

hash True = "#"
hash False = "##"

primLit s v = show v ++ hash s

genSwitch :: Spec -> String
genSwitch (name, signed, values, _) = unlines $
  [ "{-# NOINLINE " ++ name ++ " #-}" ] ++
  [ name ++ " :: " ++ primtyp signed ++ " -> " ++ primtyp signed ] ++
  [ name ++ " " ++ primLit signed v ++ " = " ++ primLit signed (output v)
  | v <- values] ++
  [ name ++ " _ = " ++ primLit signed def ]

genCheck :: Spec -> String
genCheck (name, signed, values, bits) = unlines $
  [ checkName name ++ " :: IO ()"
  , checkName name ++ " = forM_\n    [ " ++ pairs ++ "] $ \\(" ++ con signed ++ " i,o) -> do"
  , "   let r = " ++ con signed ++ " (" ++ name ++ " i)"
  , "   unless (r == o) $ putStrLn $ \"ERR: " ++ name ++ " (\" ++ show (" ++ con signed ++ " i)++ \") is \" ++ show r ++ \" and not \" ++ show o ++\".\""
  ]
  where
    f x | x `S.member` range = output x
        | otherwise          = def
    range = S.fromList values
    minS = if bits == X32 then minS32 else minS64
    maxS = if bits == X32 then maxS32 else maxS64
    maxU = if bits == X32 then maxU32 else maxU64
    checkValues = S.toList $ S.fromList $
        [ v' | v <- values, v' <- [v-1,v,v+1],
               if signed then v' >= minS && v' <= maxS else v' >= minU && v' <= maxU ]
    pairs = intercalate "\n    , " ["(" ++ show v ++ "," ++ show (f v) ++ ")" | v <- checkValues ]

checkName :: String -> String
checkName f = f ++ "_check"

genMain :: [Spec] -> String
genMain specs = unlines $ "main = do" : [ "    " ++ checkName n | (n,_,_,_) <- specs ]

genMod :: [Spec] -> String
genMod specs = unlines $
    "-- This file is generated from CmmSwitchTestGen! @generated" :
    "{-# LANGUAGE MagicHash, NegativeLiterals #-}" :
    "import Control.Monad (unless, forM_)" :
    "import GHC.Exts" :
    map genSwitch specs ++
    map genCheck specs ++
    [ genMain specs ]

main = do
    args <- getArgs
    bits <- parse args
    putStrLn $
        genMod $ zipWith (\n (s,v) -> (n,s,v,bits)) names $ signedChecks bits ++ unsignedChecks bits

parse :: [String] -> IO Bits  -- Use IO to avoid lazy parsing
parse ["-32"] = return X32
parse ["-64"] = return X64
parse _ = error "Please, supply -32 or -64 option"

signedChecks :: Bits -> [(Bool, [Integer])]
signedChecks bits = map (True,)
    [ [1..10]
    , [0..10]
    , [1..3]
    , [1..4]
    , [1..5]
    , [-1..10]
    , [-10..10]
    , [-20.. -10]++[0..10]
    , [-20.. -10]++[1..10]
    , [minS,0,maxS]
    , [maxS-10 .. maxS]
    , [minS..minS+10]++[maxS-10 .. maxS]
    ]
    where
        minS = if bits == X32 then minS32 else minS64
        maxS = if bits == X32 then maxS32 else maxS64

minU, maxU32, maxU64, minS32, minS64, maxS32, maxS64 :: Integer
minU = 0
maxU32 = fromIntegral (maxBound :: Word32)
maxU64 = fromIntegral (maxBound :: Word64)

minS32 = fromIntegral (minBound :: Int32)
minS64 = fromIntegral (minBound :: Int64)
maxS32 = fromIntegral (maxBound :: Int32)
maxS64 = fromIntegral (maxBound :: Int64)

unsignedChecks :: Bits -> [(Bool, [Integer])]
unsignedChecks bits = map (False,)
    [ [0..10]
    , [1..10]
    , [0]
    , [0..1]
    , [0..2]
    , [0..3]
    , [0..4]
    , [1]
    , [1..2]
    , [1..3]
    , [1..4]
    , [1..5]
    , [minU,maxU]
    , [maxU-10 .. maxU]
    , [minU..minU+10]++[maxU-10 .. maxU]
    ]
    where
        maxU = if bits == X32 then maxU32 else maxU64

names :: [String]
names = [ c1:c2:[] | c1 <- ['a'..'z'], c2 <- ['a'..'z']]


{-# LANGUAGE MagicHash     #-}
{-# LANGUAGE RankNTypes    #-}
{-# LANGUAGE UnboxedTuples #-}

-- exercise the 'compareByteArray#' primitive

module Main (main) where

import           Control.Monad
import           Control.Monad.ST
import           Data.List
import           GHC.Exts         (Int (..))
import           GHC.Prim
import           GHC.ST           (ST (ST))
import           GHC.Word         (Word8 (..))
import           Text.Printf

data BA    = BA#   ByteArray#

instance Show BA where
  show xs = "[" ++ intercalate "," (map (printf "0x%02x") (unpack xs)) ++ "]"

instance Eq BA where
  x == y = eqByteArray x 0 (sizeofByteArray x) y 0 (sizeofByteArray y)

instance Ord BA where
  compare x y = ordByteArray x 0 (sizeofByteArray x) y 0 (sizeofByteArray y)

compareByteArrays :: BA -> Int -> BA -> Int -> Int -> Int
compareByteArrays (BA# ba1#) (I# ofs1#) (BA# ba2#) (I# ofs2#) (I# n#)
  = I# (compareByteArrays# ba1# ofs1# ba2# ofs2# n#)

{-
copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s ()
copyByteArray (BA# src#) (I# srcOfs#) (MBA# dest#) (I# destOfs#) (I# n#)
  = ST $ \s -> case copyByteArray# src# srcOfs# dest# destOfs# n# s of
                 s' -> (# s', () #)
-}

indexWord8Array :: BA -> Int -> Word8
indexWord8Array (BA# ba#) (I# i#)
  = W8# (indexWord8Array# ba# i#)

sizeofByteArray :: BA -> Int
sizeofByteArray (BA# ba#) = I# (sizeofByteArray# ba#)

data MBA s = MBA# (MutableByteArray# s)

newByteArray :: Int -> ST s (MBA s)
newByteArray (I# n#)
  = ST $ \s -> case newByteArray# n# s of
                 (# s', mba# #) -> (# s', MBA# mba# #)

writeWord8Array :: MBA s -> Int -> Word8 -> ST s ()
writeWord8Array (MBA# mba#) (I# i#) (W8# j#)
  = ST $ \s -> case writeWord8Array# mba# i# j# s of
                 s' -> (# s', () #)

unsafeFreezeByteArray :: MBA s -> ST s BA
unsafeFreezeByteArray (MBA# mba#)
  = ST $ \s -> case unsafeFreezeByteArray# mba# s of
                 (# s', ba# #) -> (# s', BA# ba# #)

----------------------------------------------------------------------------
-- high-level operations

createByteArray :: Int -> (forall s. MBA s -> ST s ()) -> BA
createByteArray n go = runST $ do
    mba <- newByteArray n
    go mba
    unsafeFreezeByteArray mba

pack :: [Word8] -> BA
pack xs = createByteArray (length xs) $ \mba -> do
    let  go _ [] = pure ()
         go i (y:ys) = do
           writeWord8Array mba i y
           go (i+1) ys
    go 0 xs

unpack :: BA -> [Word8]
unpack ba = go 0
  where
    go i | i < sz = indexWord8Array ba i : go (i+1)
         | otherwise = []
    sz = sizeofByteArray ba

eqByteArray :: BA -> Int -> Int -> BA -> Int -> Int -> Bool
eqByteArray ba1 ofs1 n1 ba2 ofs2 n2
  | n1 /= n2  = False
  | n1 == 0   = True
  | otherwise = compareByteArrays ba1 ofs1 ba2 ofs2 n1 == 0

ordByteArray :: BA -> Int -> Int -> BA -> Int -> Int -> Ordering
ordByteArray ba1 ofs1 n1 ba2 ofs2 n2
  | n == 0 = compare n1 n2
  | otherwise = case compareByteArrays ba1 ofs1 ba2 ofs2 n of
      r | r < 0     -> LT
        | r > 0     -> GT
        | n1 < n2   -> LT
        | n1 > n2   -> GT
        | otherwise -> EQ
  where
    n = n1 `min` n2

main :: IO ()
main = do
    putStrLn "BEGIN"
    -- a couple of low-level tests
    print (compareByteArrays s1 0 s2 0 4 `compare` 0)
    print (compareByteArrays s2 0 s1 0 4 `compare` 0)
    print (compareByteArrays s1 0 s2 0 3 `compare` 0)
    print (compareByteArrays s1 0 s2 1 3 `compare` 0)
    print (compareByteArrays s1 3 s2 2 1 `compare` 0)

    forM_ [(s1,s1),(s1,s2),(s2,s1),(s2,s2)] $ \(x,y) -> do
      print (x == y, compare x y)

    -- realistic test
    print (sort (map pack strs) == map pack (sort strs))

    -- brute-force test
    forM_ [1..15] $ \n -> do
      forM_ [0..rnglen-(n+1)] $ \j -> do
        forM_ [0..rnglen-(n+1)] $ \k -> do
          let iut = compareByteArrays srng j srng k n `compare` 0
              ref = (take n (drop j rng) `compare` take n (drop k rng))
          unless (iut == ref) $
            print ("FAIL",n,j,k,iut,ref)

    putStrLn "END"
  where
    s1, s2 :: BA
    s1 = pack [0xca,0xfe,0xba,0xbe]
    s2 = pack [0xde,0xad,0xbe,0xef]

    strs = let go i xs = case splitAt (i `mod` 5) xs of
                           ([],[]) -> []
                           (y,ys)  -> y : go (i+1) ys
           in go 1 rng

    srng = pack rng

    rnglen = length rng

    rng :: [Word8]
    rng = [ 0xc1, 0x60, 0x31, 0xb6, 0x46, 0x81, 0xa7, 0xc6, 0xa8, 0xf4, 0x1e, 0x5d, 0xb7, 0x7c, 0x0b, 0xcd
          , 0x10, 0xfa, 0xe3, 0xdd, 0xf4, 0x26, 0xf9, 0x50, 0x4b, 0x9c, 0xdf, 0xc4, 0xda, 0xca, 0xc1, 0x60
          , 0x91, 0xf8, 0x70, 0x1a, 0x53, 0x89, 0xf1, 0xd9, 0xee, 0xff, 0x52, 0xb8, 0x1c, 0x5e, 0x25, 0x69
          , 0xd1, 0xa1, 0x08, 0x47, 0x93, 0x89, 0x71, 0x7a, 0xe4, 0x56, 0x24, 0x1b, 0xa1, 0x43, 0x63, 0xc0
          , 0x4d, 0xec, 0x93, 0x30, 0xb7, 0x98, 0x19, 0x23, 0x4e, 0x00, 0x76, 0x7e, 0xf4, 0xcc, 0x8b, 0x92
          , 0x19, 0xc5, 0x3d, 0xf4, 0xa0, 0x4f, 0xe3, 0x64, 0x1b, 0x4e, 0x01, 0xc9, 0xfc, 0x47, 0x3e, 0x16
          , 0xa4, 0x78, 0xdd, 0x12, 0x20, 0xa6, 0x0b, 0xcd, 0x82, 0x06, 0xd0, 0x2a, 0x19, 0x2d, 0x2f, 0xf2
          , 0x8a, 0xf0, 0xc2, 0x2d, 0x0e, 0xfb, 0x39, 0x55, 0xb2, 0xfb, 0x6e, 0xd0, 0xfa, 0xf0, 0x87, 0x57
          , 0x93, 0xa3, 0xae, 0x36, 0x1f, 0xcf, 0x91, 0x45, 0x44, 0x11, 0x62, 0x7f, 0x18, 0x9a, 0xcb, 0x54
          , 0x78, 0x3c, 0x04, 0xbe, 0x3e, 0xd4, 0x2c, 0xbf, 0x73, 0x38, 0x9e, 0xf5, 0xc9, 0xbe, 0xd9, 0xf8
          , 0xe5, 0xf5, 0x41, 0xbb, 0x84, 0x03, 0x2c, 0xe2, 0x0d, 0xe5, 0x8b, 0x1c, 0x75, 0xf7, 0x4c, 0x49
          , 0xfe, 0xac, 0x9f, 0xf4, 0x36, 0xf2, 0xba, 0x5f, 0xc0, 0xda, 0x24, 0xfc, 0x10, 0x61, 0xf0, 0xb6
          , 0xa7, 0xc7, 0xba, 0xc6, 0xb0, 0x41, 0x04, 0x8c, 0xd0, 0xe8, 0x48, 0x41, 0x38, 0xa4, 0x84, 0x21
          , 0xb6, 0xb1, 0x21, 0x33, 0x58, 0xf2, 0xa5, 0xe5, 0x73, 0xf2, 0xd7, 0xbc, 0xc7, 0x7e, 0x86, 0xee
          , 0x81, 0xb1, 0xcd, 0x42, 0xc0, 0x2c, 0xd0, 0xa0, 0x8d, 0xb5, 0x4a, 0x5b, 0xc1, 0xfe, 0xcc, 0x92
          , 0x59, 0xf4, 0x71, 0x96, 0x58, 0x6a, 0xb6, 0xa2, 0xf7, 0x67, 0x76, 0x01, 0xc5, 0x8b, 0xc9, 0x6f
          , 0x38, 0x93, 0xf3, 0xaa, 0x89, 0xf7, 0xb2, 0x2a, 0x0f, 0x19, 0x7b, 0x48, 0xbe, 0x86, 0x37, 0xd1
          , 0x30, 0xfa, 0xce, 0x72, 0xf4, 0x25, 0x64, 0xee, 0xde, 0x3a, 0x5c, 0x02, 0x32, 0xe6, 0x31, 0x3a
          , 0x4b, 0x18, 0x47, 0x30, 0xa4, 0x2c, 0xf8, 0x4d, 0xc5, 0xee, 0x0b, 0x9c, 0x75, 0x43, 0x2a, 0xf9
          ]


{-# LANGUAGE MagicHash, UnboxedTuples #-}

-- !!! simple tests of copying/cloning primitive arrays
--

module Main ( main ) where

import GHC.Exts hiding (IsList(..))
import GHC.Prim
import GHC.ST

main :: IO ()
main = putStr
       (test_copyArray
        ++ "\n" ++ test_copyMutableArray
        ++ "\n" ++ test_copyMutableArrayOverlap
        ++ "\n" ++ test_cloneArray
        ++ "\n" ++ test_cloneArrayStatic
        ++ "\n" ++ test_cloneMutableArray
        ++ "\n" ++ test_cloneMutableArrayEmpty
        ++ "\n" ++ test_cloneMutableArrayStatic
        ++ "\n" ++ test_freezeArray
        ++ "\n" ++ test_freezeArrayStatic
        ++ "\n" ++ test_thawArray
        ++ "\n" ++ test_thawArrayStatic
        ++ "\n"
       )

------------------------------------------------------------------------
-- Constants

-- All allocated arrays are of this size
len :: Int
len = 130

-- We copy these many elements
copied :: Int
copied = len - 2

copiedStatic :: Int
copiedStatic = 16
{-# INLINE copiedStatic #-}  -- to make sure optimization triggers

------------------------------------------------------------------------
-- copySmallArray#

-- Copy a slice of the source array into a destination array and check
-- that the copy succeeded.
test_copyArray :: String
test_copyArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            src <- unsafeFreezeArray src
            dst <- newArray len (-1)
            -- Leave the first and last element untouched
            copyArray src 1 dst 1 copied
            unsafeFreezeArray dst
    in shows (toList dst len) "\n"

------------------------------------------------------------------------
-- copySmallMutableArray#

-- Copy a slice of the source array into a destination array and check
-- that the copy succeeded.
test_copyMutableArray :: String
test_copyMutableArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            dst <- newArray len (-1)
            -- Leave the first and last element untouched
            copyMutableArray src 1 dst 1 copied
            unsafeFreezeArray dst
    in shows (toList dst len) "\n"

-- Perform a copy where the source and destination part overlap.
test_copyMutableArrayOverlap :: String
test_copyMutableArrayOverlap =
    let arr = runST $ do
            marr <- fromList inp
            -- Overlap of two elements
            copyMutableArray marr 5 marr 7 8
            unsafeFreezeArray marr
    in shows (toList arr (length inp)) "\n"
  where
     -- This case was known to fail at some point.
     inp = [0,169,196,9,16,25,36,16,25,81,100,121,144,169,196]

------------------------------------------------------------------------
-- cloneSmallArray#

-- Clone a slice of the source array into a destination array and
-- check that the clone succeeded.
test_cloneArray :: String
test_cloneArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            src <- unsafeFreezeArray src
            -- Don't include the first and last element.
            return $! cloneArray src 1 copied
    in shows (toList dst copied) "\n"

--  Check that the static-size optimization works.
test_cloneArrayStatic :: String
test_cloneArrayStatic =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            src <- unsafeFreezeArray src
            -- Don't include the first and last element.
            return $! cloneArray src 1 copiedStatic
    in shows (toList dst copiedStatic) "\n"

------------------------------------------------------------------------
-- cloneMutableSmallArray#

-- Clone a slice of the source array into a destination array and
-- check that the clone succeeded.
test_cloneMutableArray :: String
test_cloneMutableArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            -- Don't include the first and last element.
            dst <- cloneMutableArray src 1 copied
            unsafeFreezeArray dst
    in shows (toList dst copied) "\n"

-- Check that zero-length clones work.
test_cloneMutableArrayEmpty :: String
test_cloneMutableArrayEmpty =
    let dst = runST $ do
            src <- newArray len 0
            dst <- cloneMutableArray src 0 0
            unsafeFreezeArray dst
    in shows (toList dst 0) "\n"

--  Check that the static-size optimization works.
test_cloneMutableArrayStatic :: String
test_cloneMutableArrayStatic =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            -- Don't include the first and last element.
            dst <- cloneMutableArray src 1 copiedStatic
            unsafeFreezeArray dst
    in shows (toList dst copiedStatic) "\n"

------------------------------------------------------------------------
-- freezeSmallArray#

-- Clone a slice of the source array into a destination array and
-- check that the clone succeeded.
test_freezeArray :: String
test_freezeArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            -- Don't include the first and last element.
            freezeArray src 1 copied
    in shows (toList dst copied) "\n"

--  Check that the static-size optimization works.
test_freezeArrayStatic :: String
test_freezeArrayStatic =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            -- Don't include the first and last element.
            freezeArray src 1 copiedStatic
    in shows (toList dst copiedStatic) "\n"

------------------------------------------------------------------------
-- thawSmallArray#

-- Clone a slice of the source array into a destination array and
-- check that the clone succeeded.
test_thawArray :: String
test_thawArray =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            src <- unsafeFreezeArray src
            -- Don't include the first and last element.
            dst <- thawArray src 1 copied
            unsafeFreezeArray dst
    in shows (toList dst copied) "\n"

--  Check that the static-size optimization works.
test_thawArrayStatic :: String
test_thawArrayStatic =
    let dst = runST $ do
            src <- newArray len 0
            fill src 0 len
            src <- unsafeFreezeArray src
            -- Don't include the first and last element.
            dst <- thawArray src 1 copiedStatic
            unsafeFreezeArray dst
    in shows (toList dst copiedStatic) "\n"

------------------------------------------------------------------------
-- Test helpers

-- Initialize the elements of this array, starting at the given
-- offset.  The last parameter specifies the number of elements to
-- initialize.  Element at index @i@ takes the value @i*i@ (i.e. the
-- first actually modified element will take value @off*off@).
fill :: MArray s Int -> Int -> Int -> ST s ()
fill marr off count = go 0
  where
    go i
        | i >= count = return ()
        | otherwise = writeArray marr (off + i) (i*i) >> go (i + 1)

fromList :: [Int] -> ST s (MArray s Int)
fromList xs0 = do
    marr <- newArray (length xs0) bottomElem
    let go [] i = i `seq` return marr
        go (x:xs) i = writeArray marr i x >> go xs (i + 1)
    go xs0 0
  where
    bottomElem = error "undefined element"

------------------------------------------------------------------------
-- Convenience wrappers for SmallArray# and MutableSmallArray#

data Array a = Array { unArray :: SmallArray# a }
data MArray s a = MArray { unMArray :: SmallMutableArray# s a }

newArray :: Int -> a -> ST s (MArray s a)
newArray (I# n#) a = ST $ \s# -> case newSmallArray# n# a s# of
    (# s2#, marr# #) -> (# s2#, MArray marr# #)

indexArray :: Array a -> Int -> a
indexArray arr i@(I# i#)
  | i < 0 || i >= len =
      error $ "bounds error, offset " ++ show i ++ ", length " ++ show len
  | otherwise = case indexSmallArray# (unArray arr) i# of
      (# a #) -> a
  where len = lengthArray arr

writeArray :: MArray s a -> Int -> a -> ST s ()
writeArray marr i@(I# i#) a
  | i < 0 || i >= len =
      error $ "bounds error, offset " ++ show i ++ ", length " ++ show len
  | otherwise = ST $ \ s# ->
    case writeSmallArray# (unMArray marr) i# a s# of
        s2# -> (# s2#, () #)
  where len = lengthMArray marr

lengthArray :: Array a -> Int
lengthArray arr = I# (sizeofSmallArray# (unArray arr))

lengthMArray :: MArray s a -> Int
lengthMArray marr = I# (sizeofSmallMutableArray# (unMArray marr))

unsafeFreezeArray :: MArray s a -> ST s (Array a)
unsafeFreezeArray marr = ST $ \ s# ->
    case unsafeFreezeSmallArray# (unMArray marr) s# of
        (# s2#, arr# #) -> (# s2#, Array arr# #)

copyArray :: Array a -> Int -> MArray s a -> Int -> Int -> ST s ()
copyArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# ->
    case copySmallArray# (unArray src) six# (unMArray dst) dix# n# s# of
        s2# -> (# s2#, () #)

copyMutableArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
copyMutableArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# ->
    case copySmallMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of
        s2# -> (# s2#, () #)

cloneArray :: Array a -> Int -> Int -> Array a
cloneArray src (I# six#) (I# n#) = Array (cloneSmallArray# (unArray src) six# n#)
{-# INLINE cloneArray #-}  -- to make sure optimization triggers

cloneMutableArray :: MArray s a -> Int -> Int -> ST s (MArray s a)
cloneMutableArray src (I# six#) (I# n#) = ST $ \ s# ->
    case cloneSmallMutableArray# (unMArray src) six# n# s# of
        (# s2#, marr# #) -> (# s2#, MArray marr# #)
{-# INLINE cloneMutableArray #-}  -- to make sure optimization triggers

freezeArray :: MArray s a -> Int -> Int -> ST s (Array a)
freezeArray src (I# six#) (I# n#) = ST $ \ s# ->
    case freezeSmallArray# (unMArray src) six# n# s# of
        (# s2#, arr# #) -> (# s2#, Array arr# #)
{-# INLINE freezeArray #-}  -- to make sure optimization triggers

thawArray :: Array a -> Int -> Int -> ST s (MArray s a)
thawArray src (I# six#) (I# n#) = ST $ \ s# ->
    case thawSmallArray# (unArray src) six# n# s# of
        (# s2#, marr# #) -> (# s2#, MArray marr# #)
{-# INLINE thawArray #-}  -- to make sure optimization triggers

toList :: Array a -> Int -> [a]
toList arr n = go 0
  where
    go i | i >= n = []
         | otherwise = indexArray arr i : go (i+1)


{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, MagicHash,
             UnboxedTuples #-}

-- !!! stress tests of copying/cloning primitive arrays

-- Note: You can run this test manually with an argument (i.e.
-- ./CopySmallArrayStressTest 10000) if you want to run the stress
-- test for longer.

{-
Test strategy
=============

We create an array of arrays of integers. Repeatedly we then either

* allocate a new array in place of an old, or

* copy a random segment of an array into another array (which might be
  the source array).

By running this process long enough we hope to trigger any bugs
related to garbage collection or edge cases.

We only test copySmallMutableArray# and cloneSmallArray# as they are
representative of all the primops.
-}

module Main ( main ) where

import Debug.Trace (trace)

import Control.Exception (assert)
import Control.Monad
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Class
import GHC.Exts hiding (IsList(..))
import GHC.ST hiding (liftST)
import Prelude hiding (length, read)
import qualified Prelude as P
import qualified Prelude as P
import System.Environment
import System.Random

main :: IO ()
main = do
    args <- getArgs
    -- Number of copies to perform
    let numMods = case args of
            [] -> 100
            [n] -> P.read n :: Int
    putStr (test_copyMutableArray numMods ++ "\n" ++
            test_cloneMutableArray numMods ++ "\n"
           )

-- Number of arrays
numArrays :: Int
numArrays = 100

-- Maxmimum length of a sub-array
maxLen :: Int
maxLen = 1024

-- Create an array of arrays, with each sub-array having random length
-- and content.
setup :: Rng s (MArray s (MArray s Int))
setup = do
    len <- rnd (1, numArrays)
    marr <- liftST $ new_ len
    let go i
            | i >= len = return ()
            | otherwise = do
                n <- rnd (1, maxLen)
                subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
                liftST $ write marr i subarr
                go (i+1)
    go 0
    return marr

-- Replace one of the sub-arrays with a newly allocated array.
allocate :: MArray s (MArray s Int) -> Rng s ()
allocate marr = do
    ix <- rnd (0, length marr - 1)
    n <- rnd (1, maxLen)
    subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
    liftST $ write marr ix subarr

type CopyFunction s a =
    MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()

-- Copy a random segment of an array onto another array, using the
-- supplied copy function.
copy :: MArray s (MArray s a) -> CopyFunction s a
     -> Rng s (Int, Int, Int, Int, Int)
copy marr f = do
    six <- rnd (0, length marr - 1)
    dix <- rnd (0, length marr - 1)
    src <- liftST $ read marr six
    dst <- liftST $ read marr dix
    let srcLen = length src
    srcOff <- rnd (0, srcLen - 1)
    let dstLen = length dst
    dstOff <- rnd (0, dstLen - 1)
    n <- rnd (0, min (srcLen - srcOff) (dstLen - dstOff))
    liftST $ f src srcOff dst dstOff n
    return (six, dix, srcOff, dstOff, n)

type CloneFunction s a = MArray s a -> Int -> Int -> ST s (MArray s a)

-- Clone a random segment of an array, replacing another array, using
-- the supplied clone function.
clone :: MArray s (MArray s a) -> CloneFunction s a
      -> Rng s (Int, Int, Int, Int)
clone marr f = do
    six <- rnd (0, length marr - 1)
    dix <- rnd (0, length marr - 1)
    src <- liftST $ read marr six
    let srcLen = length src
    -- N.B. The array length might be zero if we previously cloned
    -- zero elements from some array.
    srcOff <- rnd (0, max 0 (srcLen - 1))
    n <- rnd (0, srcLen - srcOff)
    dst <- liftST $ f src srcOff n
    liftST $ write marr dix dst
    return (six, dix, srcOff, n)

------------------------------------------------------------------------
-- copySmallMutableArray#

-- Copy a slice of the source array into a destination array and check
-- that the copy succeeded.
test_copyMutableArray :: Int -> String
test_copyMutableArray numMods = runST $ run $ do
    marr <- local setup
    marrRef <- setup
    let go i
            | i >= numMods = return "test_copyMutableArray: OK"
            | otherwise = do
                -- Either allocate or copy
                alloc <- rnd (True, False)
                if alloc then doAlloc else doCopy
                go (i+1)

        doAlloc = do
            local $ allocate marr
            allocate marrRef

        doCopy = do
            inp <- liftST $ asList marr
            _ <- local $ copy marr copyMArray
            (six, dix, srcOff, dstOff, n) <- copy marrRef copyMArraySlow
            el <- liftST $ asList marr
            elRef <- liftST $ asList marrRef
            when (el /= elRef) $
                fail inp el elRef six dix srcOff dstOff n
    go 0
  where
    fail inp el elRef six dix srcOff dstOff n =
        error $ "test_copyMutableArray: FAIL\n"
        ++ "   Input: " ++ unlinesShow inp
        ++ "    Copy: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
        ++ show srcOff ++ " dstOff: " ++ show dstOff ++ " n: " ++ show n ++ "\n"
        ++ "Expected: " ++ unlinesShow elRef
        ++ "  Actual: " ++ unlinesShow el

asList :: MArray s (MArray s a) -> ST s [[a]]
asList marr = toListM =<< mapArrayM toListM marr

unlinesShow :: Show a => [a] -> String
unlinesShow =  concatMap (\ x -> show x ++ "\n")

------------------------------------------------------------------------
-- cloneSmallMutableArray#

-- Copy a slice of the source array into a destination array and check
-- that the copy succeeded.
test_cloneMutableArray :: Int -> String
test_cloneMutableArray numMods = runST $ run $ do
    marr <- local setup
    marrRef <- setup
    let go i
            | i >= numMods = return "test_cloneMutableArray: OK"
            | otherwise = do
                -- Either allocate or clone
                alloc <- rnd (True, False)
                if alloc then doAlloc else doClone
                go (i+1)

        doAlloc = do
            local $ allocate marr
            allocate marrRef

        doClone = do
            inp <- liftST $ asList marr
            _ <- local $ clone marr cloneMArray
            (six, dix, srcOff, n) <- clone marrRef cloneMArraySlow
            el <- liftST $ asList marr
            elRef <- liftST $ asList marrRef
            when (el /= elRef) $
                fail inp el elRef six dix srcOff n
    go 0
  where
    fail inp el elRef six dix srcOff n =
        error $ "test_cloneMutableArray: FAIL\n"
        ++ "   Input: " ++ unlinesShow inp
        ++ "   Clone: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
        ++ show srcOff ++ " n: " ++ show n ++ "\n"
        ++ "Expected: " ++ unlinesShow elRef
        ++ "  Actual: " ++ unlinesShow el

------------------------------------------------------------------------
-- Convenience wrappers for SmallArray# and SmallMutableArray#

data Array a = Array
    { unArray :: SmallArray# a
    , lengthA :: {-# UNPACK #-} !Int}

data MArray s a = MArray
    { unMArray :: SmallMutableArray# s a
    , lengthM :: {-# UNPACK #-} !Int}

class IArray a where
    length :: a -> Int
instance IArray (Array a) where
    length = lengthA
instance IArray (MArray s a) where
    length = lengthM

instance Eq a => Eq (Array a) where
    arr1 == arr2 = toList arr1 == toList arr2

new :: Int -> a -> ST s (MArray s a)
new n@(I# n#) a =
    assert (n >= 0) $
    ST $ \s# -> case newSmallArray# n# a s# of
        (# s2#, marr# #) -> (# s2#, MArray marr# n #)

new_ :: Int -> ST s (MArray s a)
new_ n = new n (error "Undefined element")

write :: MArray s a -> Int -> a -> ST s ()
write marr i@(I# i#) a =
    assert (i >= 0) $
    assert (i < length marr) $
    ST $ \ s# ->
    case writeSmallArray# (unMArray marr) i# a s# of
        s2# -> (# s2#, () #)

read :: MArray s a -> Int -> ST s a
read marr i@(I# i#) =
    assert (i >= 0) $
    assert (i < length marr) $
    ST $ \ s# ->
    readSmallArray# (unMArray marr) i# s#

index :: Array a -> Int -> a
index arr i@(I# i#) =
    assert (i >= 0) $
    assert (i < length arr) $
    case indexSmallArray# (unArray arr) i# of
        (# a #) -> a

unsafeFreeze :: MArray s a -> ST s (Array a)
unsafeFreeze marr = ST $ \ s# ->
    case unsafeFreezeSmallArray# (unMArray marr) s# of
        (# s2#, arr# #) -> (# s2#, Array arr# (length marr) #)

toList :: Array a -> [a]
toList arr = go 0
  where
    go i | i >= length arr = []
         | otherwise = index arr i : go (i+1)

fromList :: [e] -> ST s (MArray s e)
fromList es = do
    marr <- new_ n
    let go !_ [] = return ()
        go i (x:xs) = write marr i x >> go (i+1) xs
    go 0 es
    return marr
  where
    n = P.length es

mapArrayM :: (a -> ST s b) -> MArray s a -> ST s (MArray s b)
mapArrayM f src = do
    dst <- new_ n
    let go i
            | i >= n = return dst
            | otherwise = do
                el <- read src i
                el' <- f el
                write dst i el'
                go (i+1)
    go 0
  where
    n = length src

toListM :: MArray s e -> ST s [e]
toListM marr =
    sequence [read marr i | i <- [0..(length marr)-1]]

------------------------------------------------------------------------
-- Wrappers around copy/clone primops

copyMArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
copyMArray src six@(I# six#) dst dix@(I# dix#) n@(I# n#) =
    assert (six >= 0) $
    assert (six + n <= length src) $
    assert (dix >= 0) $
    assert (dix + n <= length dst) $
    ST $ \ s# ->
    case copySmallMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of
        s2# -> (# s2#, () #)

cloneMArray :: MArray s a -> Int -> Int -> ST s (MArray s a)
cloneMArray marr off@(I# off#) n@(I# n#) =
    assert (off >= 0) $
    assert (off + n <= length marr) $
    ST $ \ s# ->
    case cloneSmallMutableArray# (unMArray marr) off# n# s# of
        (# s2#, marr2 #) -> (# s2#, MArray marr2 n #)

------------------------------------------------------------------------
-- Manual versions of copy/clone primops.  Used to validate the
-- primops

copyMArraySlow :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()
copyMArraySlow !src !six !dst !dix n =
    assert (six >= 0) $
    assert (six + n <= length src) $
    assert (dix >= 0) $
    assert (dix + n <= length dst) $
       if six < dix
       then goB (six+n-1) (dix+n-1) 0  -- Copy backwards
       else goF six dix 0  -- Copy forwards
  where
    goF !i !j c
        | c >= n = return ()
        | otherwise = do b <- read src i
                         write dst j b
                         goF (i+1) (j+1) (c+1)
    goB !i !j c
        | c >= n = return ()
        | otherwise = do b <- read src i
                         write dst j b
                         goB (i-1) (j-1) (c+1)

cloneMArraySlow :: MArray s a -> Int -> Int -> ST s (MArray s a)
cloneMArraySlow !marr !off n =
    assert (off >= 0) $
    assert (off + n <= length marr) $ do
        marr2 <- new_ n
        let go !i !j c
                | c >= n = return marr2
                | otherwise = do
                    b <- read marr i
                    write marr2 j b
                    go (i+1) (j+1) (c+1)
        go off 0 0

------------------------------------------------------------------------
-- Utilities for simplifying RNG passing

newtype Rng s a = Rng { unRng :: StateT StdGen (ST s) a }
                deriving (Functor, Applicative, Monad)

-- Same as 'randomR', but using the RNG state kept in the 'Rng' monad.
rnd :: Random a => (a, a) -> Rng s a
rnd r = Rng $ do
    g <- get
    let (x, g') = randomR r g
    put g'
    return x

-- Run a sub-computation without affecting the RNG state.
local :: Rng s a -> Rng s a
local m = Rng $ do
    g <- get
    x <- unRng m
    put g
    return x

liftST :: ST s a -> Rng s a
liftST m = Rng $ lift m

run :: Rng s a -> ST s a
run = flip evalStateT (mkStdGen 13) . unRng


{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-}
module Main where

import GHC.Exts

foreign import prim "do_popcnt32" popcnt32 :: Int# -> Int#

main = print (I# (popcnt32 0xffff#))


{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
{-# OPTIONS_GHC -Wall #-}

module Main ( main ) where

import GHC.Base

data BA = BA ByteArray#

-- Checks that setByteArray# works
main :: IO ()
main = do BA ba <- IO $ \s0 ->
                        case newByteArray# 8# s0 of
                        (# !s1, !mba #) ->
                            case setByteArray# mba 0# 8# 65# s1 of
                            !s2 ->
                                case setByteArray# mba 1# 6# 67# s2 of
                                !s3 ->
                                    case unsafeFreezeByteArray# mba s3 of
                                    (# s4, ba #) -> (# s4, BA ba #)
          let f (I# i) = putStrLn [C# (indexCharArray# ba i)]
          mapM_ f [0..7]


{-# LANGUAGE MagicHash, UnboxedTuples #-}

module Main ( main ) where

import GHC.Exts
import GHC.Prim
import GHC.ST

main = putStr
       (test_sizeofArray
        ++ "\n" ++ test_sizeofMutableArray
        ++ "\n"
       )

test_sizeofArray :: String
test_sizeofArray = flip shows "\n" $ runST $ ST $ \ s# -> go 0 [] s#
  where
    go i@(I# i#) acc s#
        | i < 1000 = case newSmallArray# i# 0 s# of
            (# s2#, marr# #) -> case unsafeFreezeSmallArray# marr# s2# of
                (# s3#, arr# #) -> case sizeofSmallArray# arr# of
                    j# -> go (i+1) ((I# j#):acc) s3#
        | otherwise = (# s#, reverse acc #)

test_sizeofMutableArray :: String
test_sizeofMutableArray = flip shows "\n" $ runST $ ST $ \ s# -> go 0 [] s#
  where
    go i@(I# i#) acc s#
        | i < 1000 = case newSmallArray# i# 0 s# of
            (# s2#, marr# #) -> case sizeofSmallMutableArray# marr# of
                    j# -> go (i+1) ((I# j#):acc) s2#
        | otherwise = (# s#, reverse acc #)


{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}

-- Test allocation of statically sized arrays. There's an optimization
-- that targets these and we want to make sure that the code generated
-- in the optimized case is correct.
--
-- The tests proceeds by allocating a bunch of arrays of different
-- sizes and reading elements from them, to try to provoke GC crashes,
-- which would be a symptom of the optimization not generating correct
-- code.
module Main where

import Control.Monad
import GHC.Exts
import GHC.IO
import Prelude hiding (read)

main :: IO ()
main = do
    loop 1000
    putStrLn "success"
  where
    loop :: Int -> IO ()
    loop 0 = return ()
    loop i = do
        -- Sizes have been picked to match the triggering of the
        -- optimization and to match boundary conditions. Sizes are
        -- given explicitly as to not rely on other optimizations to
        -- make the static size known to the compiler.
        marr0 <- newArray 0
        marr1 <- newArray 1
        marr2 <- newArray 2
        marr3 <- newArray 3
        marr4 <- newArray 4
        marr5 <- newArray 5
        marr6 <- newArray 6
        marr7 <- newArray 7
        marr8 <- newArray 8
        marr9 <- newArray 9
        marr10 <- newArray 10
        marr11 <- newArray 11
        marr12 <- newArray 12
        marr13 <- newArray 13
        marr14 <- newArray 14
        marr15 <- newArray 15
        marr16 <- newArray 16
        marr17 <- newArray 17
        let marrs = [marr0, marr1, marr2, marr3, marr4, marr5, marr6, marr7,
                     marr8, marr9, marr10, marr11, marr12, marr13, marr14,
                     marr15, marr16, marr17]
        total <- sumManyArrays marrs
        unless (total == 153) $
            putStrLn "incorrect sum"
        loop (i-1)

sumManyArrays :: [MArray] -> IO Int
sumManyArrays = go 0
  where
    go !acc [] = return acc
    go acc (marr:marrs) = do
        n <- sumArray marr
        go (acc+n) marrs

sumArray :: MArray -> IO Int
sumArray marr = go 0 0
  where
    go :: Int -> Int -> IO Int
    go !acc i
      | i < len = do
          k <- read marr i
          go (acc + k) (i+1)
      | otherwise = return acc
    len = lengthM marr

data MArray = MArray { unMArray :: !(MutableArray# RealWorld Int) }

newArray :: Int -> IO MArray
newArray (I# sz#) = IO $ \s -> case newArray# sz# 1 s of
    (# s', marr #) -> (# s', MArray marr #)
{-# INLINE newArray #-}  -- to make sure optimization triggers

lengthM :: MArray -> Int
lengthM marr = I# (sizeofMutableArray# (unMArray marr))

read :: MArray -> Int -> IO Int
read marr i@(I# i#)
  | i < 0 || i >= len =
      error $ "bounds error, offset " ++ show i ++ ", length " ++ show len
  | otherwise = IO $ \ s -> readArray# (unMArray marr) i# s
  where len = lengthM marr


{-# LANGUAGE MagicHash, UnboxedTuples #-}

-- Test allocation of statically sized byte arrays. There's an
-- optimization that targets these and we want to make sure that the
-- code generated in the optimized case is correct.
--
-- The tests proceeds by allocating a bunch of byte arrays of
-- different sizes, to try to provoke GC crashes, which would be a
-- symptom of the optimization not generating correct code.
module Main where

import GHC.Exts
import GHC.IO

main :: IO ()
main = do
    loop 1000
    putStrLn "success"
  where
    loop :: Int -> IO ()
    loop 0 = return ()
    loop i = do
        -- Sizes have been picked to match the triggering of the
        -- optimization and to match boundary conditions. Sizes are
        -- given explicitly as to not rely on other optimizations to
        -- make the static size known to the compiler.
        newByteArray 0
        newByteArray 1
        newByteArray 2
        newByteArray 3
        newByteArray 4
        newByteArray 5
        newByteArray 6
        newByteArray 7
        newByteArray 8
        newByteArray 9
        newByteArray 10
        newByteArray 11
        newByteArray 12
        newByteArray 13
        newByteArray 14
        newByteArray 15
        newByteArray 16
        newByteArray 64
        newByteArray 128
        newByteArray 129
        loop (i-1)

newByteArray :: Int -> IO ()
newByteArray (I# sz#) = IO $ \s -> case newByteArray# sz# s of
    (# s', _ #) -> (# s', () #)
{-# INLINE newByteArray #-}  -- to make sure optimization triggers


{-# LANGUAGE CPP #-}

#include "MachDeps.h"

f :: Int -> String
f n = case n of
#if WORD_SIZE_IN_BITS == 64
  0x8000000000000000 -> "yes"
#else
  0x80000000 -> "yes"
#endif
  _ -> "no"
{-# NOINLINE f #-}

main = do
#if WORD_SIZE_IN_BITS == 64
    let string = "0x8000000000000000"
#else
    let string = "0x80000000"
#endif
    let i = read string :: Integer
    let i' = fromIntegral i :: Int
    print i
    print i'
    print (f i')


f1 :: Int -> String
f1 n = case n of
  0 -> "bar"
  0x10000000000000000 -> "foo"
  _ -> "c"
{-# NOINLINE f1 #-}

g1 :: Int -> String
g1 n = if n == 0 then "bar" else
       if n == 0x10000000000000000 then  "foo" else
       "c"
{-# NOINLINE g1 #-}

f2 :: Int -> String
f2 n = case n of
  0x10000000000000000 -> "foo"
  0 -> "bar"
  _ -> "c"
{-# NOINLINE f2 #-}

g2 :: Int -> String
g2 n = if n == 0x10000000000000000 then  "foo" else
       if n == 0 then "bar" else
       "c"
{-# NOINLINE g2 #-}

main = do
    let i = read "0" :: Int
    print (f1 i)
    print (g1 i)
    print (f2 i)
    print (g2 i)