summaryrefslogtreecommitdiff
path: root/testsuite/tests/ffi/should_run/T16650b.hs
blob: e1537c757dfd3c83056469762fe25627cd07192c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
{-# language GADTSyntax #-}
{-# language KindSignatures #-}
{-# language UnliftedFFITypes #-}
{-# language ForeignFunctionInterface #-}
{-# language MagicHash #-}
{-# language UnboxedTuples #-}

-- Test for shims when passing an array of unlifted values
-- to a foreign function.
-- See test T16650a for more commentary.

import GHC.Exts
import GHC.Word
import GHC.IO
import Data.Kind (Type)

main :: IO ()
main = do
  mb0 <- luckySingleton
  mb1 <- luckySingleton
  mbs <- newByteArrays 2
  writeByteArrays mbs 0 mb0
  writeByteArrays mbs 1 mb0
  case box mbs of
    Box x -> print =<< c_is_doubleton_homogeneous (unsafeCoerce# x)
  writeByteArrays mbs 1 mb1
  case box mbs of
    Box x -> print =<< c_is_doubleton_homogeneous (unsafeCoerce# x)

foreign import ccall unsafe "is_doubleton_homogenous"
  c_is_doubleton_homogeneous :: MutableArrayArray# RealWorld -> IO Word8

data Box :: Type where
  Box :: (Any :: TYPE ('BoxedRep 'Unlifted)) -> Box

-- An array of bytes
data MutableByteArray :: Type where
  MutableByteArray :: MutableByteArray# RealWorld -> MutableByteArray

-- A mutable array of mutable byte arrays
data MutableByteArrays :: Type where
  MutableByteArrays :: MutableArrayArray# RealWorld -> MutableByteArrays

box :: MutableByteArrays -> Box
{-# noinline box #-}
box (MutableByteArrays x) = Box (unsafeCoerce# x)

luckySingleton :: IO MutableByteArray
luckySingleton = IO $ \s0 -> case newByteArray# 1# s0 of
  (# s1, marr# #) -> case writeWord8Array# marr# 0# fortyTwo s1 of
    s2 -> (# s2, MutableByteArray marr# #)
  where W8# fortyTwo = 42

readByteArray :: MutableByteArray -> Int -> IO Word8
readByteArray (MutableByteArray b#) (I# i#) = IO $ \s0 ->
  case readWord8Array# b# i# s0 of
    (# s1, w #) -> (# s1, W8# w #)

-- Write a mutable byte array to the array of mutable byte arrays
-- at the given index.
writeByteArrays :: MutableByteArrays -> Int -> MutableByteArray -> IO ()
writeByteArrays (MutableByteArrays maa#) (I# i#) (MutableByteArray a) = IO $ \s0 ->
  case writeMutableByteArrayArray# maa# i# a s0 of
    s1 -> (# s1, () #)

-- Allocate a new array of mutable byte arrays. All elements are
-- uninitialized. Attempting to read them will cause a crash.
newByteArrays :: Int -> IO MutableByteArrays
newByteArrays (I# len#) = IO $ \s0 -> case newArrayArray# len# s0 of
  (# s1, a# #) -> (# s1, MutableByteArrays a# #)