path: root/testsuite/tests/primops/should_run/T4442.hs

{-# LANGUAGE MagicHash, UnboxedTuples, CPP #-}
module Main where

#include "MachDeps.h"

import GHC.Ptr(Ptr(..), nullPtr, plusPtr, minusPtr)
import GHC.Stable(
  StablePtr(..), castStablePtrToPtr, castPtrToStablePtr, newStablePtr)
import GHC.Exts
import Data.Char(ord)
#if WORD_SIZE_IN_BITS < 64
import GHC.Int (Int64(..))
import GHC.Word (Word64(..))
#endif

assertEqual :: (Show a, Eq a) => a -> a -> IO ()
assertEqual a b
  | a /= b = putStrLn (show a ++ " /= " ++ show b)
  | otherwise = return ()

readBytes :: MutableByteArray# s -> State# s -> Int# -> (# State# s, [Int] #)
readBytes marr s0 len = go s0 len []
 where
  go s 0# bs = (# s, bs #)
  go s i  bs = case readWord8Array# marr (i -# 1#) s of
    (# s', b #) -> go s' (i -# 1#) (I# (word2Int# b):bs)

indexBytes :: ByteArray# -> Int# -> [Int]
indexBytes arr len  =
  [I# (word2Int# (indexWord8Array# arr i)) | I# i <- [0..I# len - 1]]

fillByteArray :: MutableByteArray# s -> Int# -> Int -> State# s -> State# s
fillByteArray arr len (I# a) = go len
 where
  go 0# s = s
  go i s = go (i -# 1#) (writeInt8Array# arr (i -# 1#) a s)

test :: (Eq a, Show a)
  => String
  -> (ByteArray# -> Int# -> a)
  -> (MutableByteArray# RealWorld -> Int# -> State# RealWorld
      -> (# State# RealWorld, a #))
  -> (MutableByteArray# RealWorld -> Int# -> a -> State# RealWorld
      -> State# RealWorld)
  -> a
  -> [Int]
  -> Int
  -> IO ()
test name index read write val valBytes len = do
  putStrLn name
  mapM_ testAtOffset [0..16]
 where
  arrLen :: Int#
  arrLen = 24#

  fillerByte :: Int
  fillerByte = 0x34

  expectedArrayBytes :: Int -> [Int]
  expectedArrayBytes offset =
       replicate offset fillerByte
    ++ valBytes
    ++ replicate (I# arrLen - len - offset) fillerByte

  testAtOffset :: Int -> IO ()
  testAtOffset offset@(I# offset#) = runRW# (\s0 -> let
    (# s1, marr #) = newByteArray# arrLen s0
    s2 = fillByteArray marr arrLen fillerByte s1
    s3 = write marr offset# val s2
    (# s4, actual0 #) = read marr offset# s3
    (# s5, actualBytes0 #) = readBytes marr s4 arrLen
    (# _, arr #) = unsafeFreezeByteArray# marr s5
    actual1 = index arr offset#
    actualBytes1 = indexBytes arr arrLen
   in do
       assertEqual actual0 val
       assertEqual actual1 val
       assertEqual actualBytes0 (expectedArrayBytes offset)
       assertEqual actualBytes1 (expectedArrayBytes offset)
   )

intToBytes :: Int -> Int -> [Int]
intToBytes (I# val0) (I# len0) = let
    result = go val0 len0
    go v 0# = []
    go v len =
      I# (v `andI#` 0xff#) : go (v `uncheckedIShiftRL#` 8#) (len -# 1#)
  in
#if defined(WORDS_BIGENDIAN)
    reverse result
#else
    result
#endif

testIntArray ::
     String
  -> (ByteArray# -> Int# -> Int#)
  -> (MutableByteArray# RealWorld -> Int# -> State# RealWorld
        -> (# State# RealWorld, Int# #))
  -> (MutableByteArray# RealWorld -> Int# -> Int# -> State# RealWorld
        -> State# RealWorld)
  -> Int
  -> Int
  -> IO ()
testIntArray name0 index read write val0 len = do
  doOne (name0 ++ " positive") val0
  doOne (name0 ++ " negative") (negate val0)
 where
  doOne name val = test
    name
    (\arr i -> I# (index arr i))
    (\arr i s -> case read arr i s of (# s', a #) -> (# s', I# a #))
    (\arr i (I# a) s -> write arr i a s)
    val
    (intToBytes val len)
    len

#if WORD_SIZE_IN_BITS == 64
testInt64Array = testIntArray
#else
testInt64Array ::
     String
  -> (ByteArray# -> Int# -> Int64#)
  -> (MutableByteArray# RealWorld -> Int# -> State# RealWorld
        -> (# State# RealWorld, Int64# #))
  -> (MutableByteArray# RealWorld -> Int# -> Int64# -> State# RealWorld
        -> State# RealWorld)
  -> Int64
  -> Int
  -> IO ()
testInt64Array name0 index read write val0 len = do
  doOne (name0 ++ " positive") val0
  doOne (name0 ++ " negative") (negate val0)
 where
  doOne :: String -> Int64 -> IO ()
  doOne name val = test
    name
    (\arr i -> I64# (index arr i))
    (\arr i s -> case read arr i s of (# s', a #) -> (# s', I64# a #))
    (\arr i (I64# a) s -> write arr i a s)
    val
    (intToBytes (fromIntegral val) len)
    len
#endif

testWordArray ::
     String
  -> (ByteArray# -> Int# -> Word#)
  -> (MutableByteArray# RealWorld -> Int# -> State# RealWorld
        -> (# State# RealWorld, Word# #))
  -> (MutableByteArray# RealWorld -> Int# -> Word# -> State# RealWorld
        -> State# RealWorld)
  -> Word
  -> Int
  -> IO ()
testWordArray name index read write val len = test
  name
  (\arr i -> W# (index arr i))
  (\arr i s -> case read arr i s of (# s', a #) -> (# s', W# a #))
  (\arr i (W# a) s -> write arr i a s)
  val
  (intToBytes (fromIntegral val) len)
  len

#if WORD_SIZE_IN_BITS == 64
testWord64Array = testWordArray
#else
testWord64Array ::
     String
  -> (ByteArray# -> Int# -> Word64#)
  -> (MutableByteArray# RealWorld -> Int# -> State# RealWorld
        -> (# State# RealWorld, Word64# #))
  -> (MutableByteArray# RealWorld -> Int# -> Word64# -> State# RealWorld
        -> State# RealWorld)
  -> Word64
  -> Int
  -> IO ()
testWord64Array name index read write val len = test
  name
  (\arr i -> W64# (index arr i))
  (\arr i s -> case read arr i s of (# s', a #) -> (# s', W64# a #))
  (\arr i (W64# a) s -> write arr i a s)
  val
  (intToBytes (fromIntegral val) len)
  len
#endif

wordSizeInBytes :: Int
wordSizeInBytes = WORD_SIZE_IN_BITS `div` 8

int :: Int
int
  | WORD_SIZE_IN_BITS == 32 = 12345678
  | otherwise = 1234567890123

word :: Word
word = fromIntegral int

float :: Float
float = 123.456789

-- Test pattern generated by this python code:
-- >>> import struct
-- >>> import binascii
-- >>> binascii.hexlify(struct.pack('>f', 123.456789))
floatBytes :: Int
floatBytes = 0x42f6e9e0

double :: Double
double = 123.45678901234

-- Test pattern generated by this python code:
-- >>> import struct
-- >>> import binascii
-- >>> binascii.hexlify(struct.pack('>d', 123.45678901234))
doubleBytes :: Int
doubleBytes = 0x405edd3c07fb4b09

main :: IO ()
main = do
  testIntArray "Int8#"
    indexInt8Array# readInt8Array# writeInt8Array#
    123 1
  testIntArray "Int16#"
    indexWord8ArrayAsInt16# readWord8ArrayAsInt16# writeWord8ArrayAsInt16#
    12345 2
  testIntArray "Int32#"
    indexWord8ArrayAsInt32# readWord8ArrayAsInt32# writeWord8ArrayAsInt32#
    12345678 4
  testInt64Array "Int64#"
    indexWord8ArrayAsInt64# readWord8ArrayAsInt64# writeWord8ArrayAsInt64#
    1234567890123 8
  testIntArray "Int#"
    indexWord8ArrayAsInt# readWord8ArrayAsInt# writeWord8ArrayAsInt#
    int wordSizeInBytes

  testWordArray "Word8#"
    indexWord8Array# readWord8Array# writeWord8Array#
    123 1
  testWordArray "Word16#"
    indexWord8ArrayAsWord16# readWord8ArrayAsWord16# writeWord8ArrayAsWord16#
    12345 2
  testWordArray "Word32#"
    indexWord8ArrayAsWord32# readWord8ArrayAsWord32# writeWord8ArrayAsWord32#
    12345678 4
  testWord64Array "Word64#"
    indexWord8ArrayAsWord64# readWord8ArrayAsWord64# writeWord8ArrayAsWord64#
    1234567890123 8
  testWordArray "Word#"
    indexWord8ArrayAsWord# readWord8ArrayAsWord# writeWord8ArrayAsWord#
    word wordSizeInBytes

  test
    "Char#"
    (\arr i -> C# (indexWord8ArrayAsChar# arr i))
    (\arr i s ->
        case readWord8ArrayAsChar# arr i s of (# s', a #) -> (# s', C# a #))
    (\arr i (C# a) s -> writeWord8ArrayAsChar# arr i a s)
    'z'
    [ord 'z']
    1
  test
    "WideChar#"
    (\arr i -> C# (indexWord8ArrayAsWideChar# arr i))
    (\arr i s ->
        case readWord8ArrayAsWideChar# arr i s of (# s', a #) -> (# s', C# a #))
    (\arr i (C# a) s -> writeWord8ArrayAsWideChar# arr i a s)
    '𠜎'  -- See http://www.i18nguy.com/unicode/supplementary-test.html
    (intToBytes (ord '𠜎') 4)
    4
  test
    "Addr#"
    (\arr i -> Ptr (indexWord8ArrayAsAddr# arr i))
    (\arr i s ->
        case readWord8ArrayAsAddr# arr i s of (# s', a #) -> (# s', Ptr a #))
    (\arr i (Ptr a) s -> writeWord8ArrayAsAddr# arr i a s)
    (nullPtr `plusPtr` int)
    (intToBytes int wordSizeInBytes)
    wordSizeInBytes

  stablePtr <- newStablePtr ()
  test
    "StablePtr#"
    (\arr i ->
        castStablePtrToPtr (StablePtr (indexWord8ArrayAsStablePtr# arr i)))
    (\arr i s -> case readWord8ArrayAsStablePtr# arr i s of
                   (# s', a #) -> (# s', castStablePtrToPtr (StablePtr a) #))
    (\arr i p s -> case castPtrToStablePtr p of
                     (StablePtr a) -> writeWord8ArrayAsStablePtr# arr i a s)
    (castStablePtrToPtr stablePtr)
    (intToBytes (castStablePtrToPtr stablePtr `minusPtr` nullPtr)
                wordSizeInBytes)
    wordSizeInBytes

  test
    "Float#"
    (\arr i -> F# (indexWord8ArrayAsFloat# arr i))
    (\arr i s ->
        case readWord8ArrayAsFloat# arr i s of (# s', a #) -> (# s', F# a #))
    (\arr i (F# a) s -> writeWord8ArrayAsFloat# arr i a s)
    float
    (intToBytes floatBytes 4)
    4
  test
    "Double#"
    (\arr i -> D# (indexWord8ArrayAsDouble# arr i))
    (\arr i s ->
        case readWord8ArrayAsDouble# arr i s of (# s', a #) -> (# s', D# a #))
    (\arr i (D# a) s -> writeWord8ArrayAsDouble# arr i a s)
    double
    (intToBytes doubleBytes 8)
    8