Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
T
test-primops
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Iterations
Wiki
Requirements
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Locked files
Build
Pipelines
Jobs
Pipeline schedules
Test cases
Artifacts
Deploy
Releases
Package Registry
Container Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Code review analytics
Issue analytics
Insights
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Glasgow Haskell Compiler
test-primops
Merge requests
!6
CCall: Extend to test signed arguments and results
Code
Review changes
Check out branch
Download
Patches
Plain diff
Merged
CCall: Extend to test signed arguments and results
T3
into
master
Overview
0
Commits
4
Pipelines
8
Changes
2
Merged
Ben Gamari
requested to merge
T3
into
master
3 years ago
Overview
0
Commits
4
Pipelines
8
Changes
2
Expand
Closes
#3 (closed)
.
Edited
3 years ago
by
Ben Gamari
0
0
Merge request reports
Compare
master
version 7
fd887b7e
3 years ago
version 6
12ec248e
3 years ago
version 5
c71451f9
3 years ago
version 4
1ddf3821
3 years ago
version 3
e699643f
3 years ago
version 2
74fc7427
3 years ago
version 1
a4898570
3 years ago
master (base)
and
latest version
latest version
983ef6ea
4 commits,
3 years ago
version 7
fd887b7e
4 commits,
3 years ago
version 6
12ec248e
3 commits,
3 years ago
version 5
c71451f9
3 commits,
3 years ago
version 4
1ddf3821
3 commits,
3 years ago
version 3
e699643f
2 commits,
3 years ago
version 2
74fc7427
2 commits,
3 years ago
version 1
a4898570
1 commit,
3 years ago
2 files
+
69
−
36
Inline
Compare changes
Side-by-side
Inline
Show whitespace changes
Show one file at a time
Files
2
Search (e.g. *.vue) (Ctrl+P)
src/CCall.hs
+
61
−
36
Options
@@ -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
test
CCall
eval
CCall
::
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
arg
Width
s
argBndrs
++
[
cType
Unsigned
(
retWidth
c
)
<>
" test_c("
<>
argList
<>
") {"
]
++
zipWith
printArg
arg
Type
s
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
(
"PRI
x"
++
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