Skip to content
Snippets Groups Projects

CCall: Extend to test signed arguments and results

Merged Ben Gamari requested to merge T3 into master
Files
2
+ 61
36
@@ -2,9 +2,9 @@
module CCall
( CCallDesc(..)
, testCCall
, evalCCall
) where
import Numeric.Natural
import System.FilePath
import System.IO.Temp
import Test.QuickCheck
@@ -17,7 +17,8 @@ import Number
data CCallDesc
= CCallDesc { callRet :: SomeNumber
, callArgs :: [SomeNumber]
, callRetSignedness :: Signedness
, callArgs :: [(Signedness, SomeNumber)]
}
deriving (Show)
@@ -30,30 +31,40 @@ mAX_ARGS = 32
instance Arbitrary CCallDesc where
arbitrary = do
ret <- arbitrary
ret_signedness <- arbitrary
n <- chooseInt (0, mAX_ARGS)
args <- vectorOf n arbitrary
return $ CCallDesc ret args
return $ CCallDesc ret ret_signedness args
shrink (CCallDesc ret ret_s args) =
CCallDesc <$> shrink ret <*> pure ret_s <*> shrinkList shrink args
testCCall
evalCCall
:: Compiler
-> CCallDesc
-> Property
testCCall comp c =
ioProperty $ withTempDirectory "." "tmp" $ \tmpDir -> do
writeFile (tmpDir </> "test_c.c") (cStub c)
writeFile (tmpDir </> "test.cmm") (cCallCmm c)
compile comp tmpDir ["test_c.c", "test.cmm"] soName ["-shared", "-dynamic"]
out <- runIt comp (tmpDir </> soName)
let saw :: [Natural]
saw = map read (lines out)
expected :: [Natural]
expected = map (\(SomeNumber e) -> toUnsigned e) (callArgs c) ++ [ret]
ret = case callRet c of SomeNumber n -> toUnsigned n
return $ saw === expected
-> IO [Integer]
evalCCall comp c = withTempDirectory "." "tmp" $ \tmpDir -> do
writeFile (tmpDir </> "test_c.c") (cStub c)
writeFile (tmpDir </> "test.cmm") (cCallCmm c)
compile comp tmpDir ["test_c.c", "test.cmm"] soName ["-shared", "-dynamic"]
out <- runIt comp (tmpDir </> soName)
let saw :: [Integer]
saw = map read (lines out)
return saw
where
soName = "test.so"
testCCall
:: Compiler
-> CCallDesc
-> Property
testCCall comp c = ioProperty $ do
saw <- evalCCall comp c
let expected :: [Integer]
expected = map (\(s, SomeNumber e) -> asInteger s e) (callArgs c) ++ [ret]
-- The wrapper zero extends the result so interpret it as unsigned.
ret = case callRet c of SomeNumber n -> asInteger Unsigned n
return $ saw === expected
cStub :: CCallDesc -> String
cStub c
= unlines
@@ -65,11 +76,14 @@ cStub c
]
where
argBndrs = [ "arg"++show i | (i,_) <- zip [0::Int ..] (callArgs c) ]
argWidths = [ knownWidth @w | SomeNumber (_ :: Number w) <- callArgs c ]
argTypes =
[ (signedness, knownWidth @w)
| (signedness, SomeNumber (_ :: Number w)) <- callArgs c
]
funcDef = unlines $
[ cType (retWidth c) <> " test_c(" <> argList <> ") {" ] ++
zipWith printArg argWidths argBndrs ++
[ cType Unsigned (retWidth c) <> " test_c(" <> argList <> ") {" ] ++
zipWith printArg argTypes argBndrs ++
[ " fflush(stdout);"
, " return " ++ show (someNumberToUnsigned $ callRet c) ++ "ULL;"
, "}"
@@ -77,39 +91,50 @@ cStub c
argList =
commaList
[ unwords [cType w, bndr]
| (w, bndr) <- zip argWidths argBndrs
[ unwords [ty, bndr]
| (ty, bndr) <- zip (map (uncurry cType) argTypes) argBndrs
]
printArg w bndr =
" printf(" ++ quoted (formatStr w ++ "\\n") ++ ", " ++ bndr ++ ");"
printArg ty bndr =
" printf(" ++ quoted (formatStr ty ++ "\\n") ++ ", " ++ bndr ++ ");"
quoted :: String -> String
quoted s = "\"" ++ s ++ "\""
formatStr :: Width -> String
formatStr w =
"0x%" ++ quoted ("PRIx"++show n)
formatStr :: (Signedness, Width) -> String
formatStr (signedness, w) =
"%" ++ quoted ("PRI" ++ fmt ++ show n)
where
fmt = case signedness of
Signed -> "d"
Unsigned -> "u"
n = widthBits w
cType :: Width -> String
cType W8 = "uint8_t"
cType W16 = "uint16_t"
cType W32 = "uint32_t"
cType W64 = "uint64_t"
cType :: Signedness -> Width -> String
cType signedness width = prefix ++ "int" ++ show n ++ "_t"
where
n = widthBits width
prefix = case signedness of
Signed -> ""
Unsigned -> "u"
cCallCmm :: CCallDesc -> String
cCallCmm c = unlines
[ "test("++cmmWordType ++" buffer) {"
, " "++cmmType (retWidth c)++" ret;"
, " (ret) = foreign \"C\" test_c(" ++ argList ++ ");"
, " (" ++ retHint ++ "ret) = foreign \"C\" test_c(" ++ argList ++ ");"
, " return ("++widenOp++"(ret));"
, "}"
]
where
retHint = case callRetSignedness c of
Signed -> "\"signed\" "
Unsigned -> ""
widenOp = "%zx" ++ show (widthBits wordSize)
argList =
commaList
[ exprToCmm $ ELit e
| SomeNumber e <- callArgs c
[ exprToCmm (ELit e) ++ hint
| (signedness, SomeNumber e) <- callArgs c
, let hint = case signedness of
Signed -> " \"signed\""
Unsigned -> ""
]
Loading