From e699643f3b036dc39643a0ee322b2ee256fa23f5 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 22 Jun 2022 14:19:37 -0400
Subject: [PATCH] CCall: Extend to test signed arguments and results
Closes #3.
---
src/CCall.hs | 60 +++++++++++++++++++++++++++++++---------------------
1 file changed, 36 insertions(+), 24 deletions(-)
diff --git a/src/CCall.hs b/src/CCall.hs
index 8632bde..53880e6 100644
--- a/src/CCall.hs
+++ b/src/CCall.hs
@@ -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 -> ""
]
--
GitLab