Skip to content
Snippets Groups Projects
Commit e699643f authored by Ben Gamari's avatar Ben Gamari :turtle:
Browse files

CCall: Extend to test signed arguments and results

Closes #3.
parent 00a693b8
No related branches found
No related tags found
No related merge requests found
Pipeline #53680 failed
......@@ -4,7 +4,6 @@ module CCall
, testCCall
) where
import Numeric.Natural
import System.FilePath
import System.IO.Temp
import Test.QuickCheck
......@@ -17,7 +16,8 @@ import Number
data CCallDesc
= CCallDesc { callRet :: SomeNumber
, callArgs :: [SomeNumber]
, callRetSignedness :: Signedness
, callArgs :: [(Signedness, SomeNumber)]
}
deriving (Show)
......@@ -30,9 +30,10 @@ 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
testCCall
:: Compiler
......@@ -44,11 +45,11 @@ testCCall comp 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]
let saw :: [Integer]
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
expected :: [Integer]
expected = map (\(s, SomeNumber e) -> asInteger s e) (callArgs c) ++ [ret]
ret = case callRet c of SomeNumber n -> asInteger (callRetSignedness c) n
return $ saw === expected
where
......@@ -65,11 +66,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 +81,47 @@ 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 =
formatStr :: (Signedness, Width) -> String
formatStr (_signedness, w) =
"0x%" ++ quoted ("PRIx"++show n)
where
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 -> ""
]
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment