diff options
| author | Luite Stegeman <stegeman@gmail.com> | 2021-05-03 19:15:28 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-05-05 05:45:03 -0400 |
| commit | 3280eb2216b44d46813fe8e026ebdfc9ac0547a9 (patch) | |
| tree | fe0ded5d68f510e78e6ec34b4af4f4c33155ce7e | |
| parent | f464e4777662a25c0b241d396146ba7a3182b9f3 (diff) | |
| download | haskell-3280eb2216b44d46813fe8e026ebdfc9ac0547a9.tar.gz | |
support LiftedRep and UnliftedRep in GHCi FFI
fixes #19733
| -rw-r--r-- | compiler/GHC/StgToByteCode.hs | 36 | ||||
| -rw-r--r-- | testsuite/tests/ghci/should_run/T19733.hs | 22 | ||||
| -rw-r--r-- | testsuite/tests/ghci/should_run/T19733.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/ghci/should_run/all.T | 1 |
4 files changed, 44 insertions, 17 deletions
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs index 04eb52d7c0..787c0ad155 100644 --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -1645,7 +1645,9 @@ primRepToFFIType platform r AddrRep -> FFIPointer FloatRep -> FFIFloat DoubleRep -> FFIDouble - _ -> panic "primRepToFFIType" + LiftedRep -> FFIPointer + UnliftedRep -> FFIPointer + _ -> pprPanic "primRepToFFIType" (ppr r) where (signed_word, unsigned_word) = case platformWordSize platform of PW4 -> (FFISInt32, FFIUInt32) @@ -1656,19 +1658,21 @@ primRepToFFIType platform r mkDummyLiteral :: Platform -> PrimRep -> Literal mkDummyLiteral platform pr = case pr of - IntRep -> mkLitInt platform 0 - WordRep -> mkLitWord platform 0 - Int8Rep -> mkLitInt8 0 - Word8Rep -> mkLitWord8 0 - Int16Rep -> mkLitInt16 0 - Word16Rep -> mkLitWord16 0 - Int32Rep -> mkLitInt32 0 - Word32Rep -> mkLitWord32 0 - Int64Rep -> mkLitInt64 0 - Word64Rep -> mkLitWord64 0 - AddrRep -> LitNullAddr - DoubleRep -> LitDouble 0 - FloatRep -> LitFloat 0 + IntRep -> mkLitInt platform 0 + WordRep -> mkLitWord platform 0 + Int8Rep -> mkLitInt8 0 + Word8Rep -> mkLitWord8 0 + Int16Rep -> mkLitInt16 0 + Word16Rep -> mkLitWord16 0 + Int32Rep -> mkLitInt32 0 + Word32Rep -> mkLitWord32 0 + Int64Rep -> mkLitInt64 0 + Word64Rep -> mkLitWord64 0 + AddrRep -> LitNullAddr + DoubleRep -> LitDouble 0 + FloatRep -> LitFloat 0 + LiftedRep -> LitNullAddr + UnliftedRep -> LitNullAddr _ -> pprPanic "mkDummyLiteral" (ppr pr) @@ -1699,9 +1703,7 @@ maybe_getCCallReturnRep fn_ty case r_reps of [] -> panic "empty typePrimRepArgs" [VoidRep] -> Nothing - [rep] - | isGcPtrRep rep -> blargh - | otherwise -> Just rep + [rep] -> Just rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack diff --git a/testsuite/tests/ghci/should_run/T19733.hs b/testsuite/tests/ghci/should_run/T19733.hs new file mode 100644 index 0000000000..7bb8102a2d --- /dev/null +++ b/testsuite/tests/ghci/should_run/T19733.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} + +{-# OPTIONS_GHC -fbyte-code #-} + +module Main where + +import GHC.Prim +import GHC.IO +import Foreign.C + +main :: IO () +main = testThreadId >> putStrLn "OK" + +testThreadId :: IO CInt +testThreadId = IO $ \s0 -> + case myThreadId# s0 of + (# s1, tid #) -> (# s1, c_getThreadId tid #) + +foreign import ccall unsafe "rts_getThreadId" c_getThreadId :: ThreadId# -> CInt + diff --git a/testsuite/tests/ghci/should_run/T19733.stdout b/testsuite/tests/ghci/should_run/T19733.stdout new file mode 100644 index 0000000000..885fd66bd8 --- /dev/null +++ b/testsuite/tests/ghci/should_run/T19733.stdout @@ -0,0 +1,2 @@ +OK + diff --git a/testsuite/tests/ghci/should_run/all.T b/testsuite/tests/ghci/should_run/all.T index dc125dd828..aa92930d90 100644 --- a/testsuite/tests/ghci/should_run/all.T +++ b/testsuite/tests/ghci/should_run/all.T @@ -77,3 +77,4 @@ test('T18064', ['T18064.script']) test('T18594', just_ghci, ghci_script, ['T18594.script']) test('T18562', just_ghci, ghci_script, ['T18562.script']) +test('T19733', just_ghci, compile_and_run, ['']) |