[Git][ghc/ghc][wip/supersven/riscv64-ncg] 2 commits: WIP: Check C calling convention
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Fri Aug 18 07:55:28 UTC 2023
Sven Tennie pushed to branch wip/supersven/riscv64-ncg at Glasgow Haskell Compiler / GHC
Commits:
bd908619 by Sven Tennie at 2023-08-09T09:09:06+00:00
WIP: Check C calling convention
- - - - -
150bff5d by Sven Tennie at 2023-08-18T07:53:21+00:00
Fix & test C calling convention (parameters)
I think the gist is: Sub-word ints are sign-extended, sub-word words are
give as is, because they were truncated before.
- - - - -
5 changed files:
- compiler/GHC/CmmToAsm/RV64/CodeGen.hs
- + testsuite/tests/codeGen/should_run/CCallConv.hs
- + testsuite/tests/codeGen/should_run/CCallConv.stdout
- + testsuite/tests/codeGen/should_run/CCallConv_c.c
- testsuite/tests/codeGen/should_run/all.T
Changes:
=====================================
compiler/GHC/CmmToAsm/RV64/CodeGen.hs
=====================================
@@ -1734,24 +1734,20 @@ genCCall target dest_regs arg_regs bid = do
--
-- Still have GP regs, and we want to pass an GP argument.
- passArguments pack (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format , hint == NoHint = do
- -- Do not sign-extend unsigned register values. Otherwise, unsigned
- -- parameters (e.g. uint8_t) are messed up with sign bits.
+ passArguments pack (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
+ -- RISCV64 Integer Calling Convention: "When passed in registers or on the
+ -- stack, integer scalars narrower than XLEN bits are widened according to
+ -- the sign of their type up to 32 bits, then sign-extended to XLEN bits."
let w = formatToWidth format
- mov = MOV (OpReg w gpReg) (OpReg w r)
- accumCode' = accumCode `appOL`
- code_r `snocOL`
- ann (text "Pass gp argument (NoHint): " <> ppr r) mov
- passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode'
+ assignArg = if hint == SignedHint then
+ COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r) `consOL`
+ signExtend w W64 r gpReg
- passArguments pack (gpReg:gpRegs) fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
- -- RISCV64 Integer Calling Convention: "When passed in registers or on the
- -- stack, integer scalars narrower than XLEN bits are widened according to
- -- the sign of their type up to 32 bits, then sign-extended to XLEN bits."
- let w = formatToWidth format
+ else toOL[COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r)
+ , MOV (OpReg w gpReg) (OpReg w r)]
accumCode' = accumCode `appOL`
code_r `appOL`
- signExtend w W64 r gpReg
+ assignArg
passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode'
-- Still have FP regs, and we want to pass an FP argument.
@@ -1764,18 +1760,27 @@ genCCall target dest_regs arg_regs bid = do
passArguments pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) accumCode'
-- No mor regs left to pass. Must pass on stack.
- passArguments pack [] [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode = do
+ -- TODO: Pack can probably be deleted
+ passArguments pack [] [] ((r, format, hint, code_r) : args) stackSpace accumRegs accumCode = do
let w = formatToWidth format
bytes = widthInBits w `div` 8
space = if pack then bytes else 8
- stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)
- | otherwise = stackSpace
+ stackSpace'
+ | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)
+ | otherwise = stackSpace
str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 2) (ImmInt stackSpace')))
- stackCode = code_r `snocOL`
- ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str
- passArguments pack [] [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)
-
- -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.
+ stackCode =
+ if hint == SignedHint
+ then
+ code_r
+ `appOL` signExtend w W64 r ip_reg
+ `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr ip_reg) str
+ else
+ code_r
+ `snocOL` ann (text "Pass unsigned argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str
+ passArguments pack [] [] args (stackSpace' + space) accumRegs (stackCode `appOL` accumCode)
+
+-- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.
passArguments pack [] fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
let w = formatToWidth format
bytes = widthInBits w `div` 8
=====================================
testsuite/tests/codeGen/should_run/CCallConv.hs
=====================================
@@ -0,0 +1,89 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+-- | This test ensures that sub-word signed and unsigned parameters are correctly
+-- handed over to C functions. I.e. it asserts the calling-convention.
+--
+-- The number of parameters is currently shaped for the RISCV64 calling-convention.
+-- You may need to add more parameters to the C functions in case there are more
+-- registers reserved for parameters in your architecture.
+module Main where
+
+import Data.Word
+import GHC.Exts
+import GHC.Int
+
+foreign import ccall "fun8"
+ fun8 ::
+ Int8# -> -- a0
+ Word8# -> -- a1
+ Int8# -> -- a2
+ Int8# -> -- a3
+ Int8# -> -- a4
+ Int8# -> -- a5
+ Int8# -> -- a6
+ Int8# -> -- a7
+ Word8# -> -- s0
+ Int8# -> -- s1
+ Int64# -- result
+
+foreign import ccall "fun16"
+ fun16 ::
+ Int16# -> -- a0
+ Word16# -> -- a1
+ Int16# -> -- a2
+ Int16# -> -- a3
+ Int16# -> -- a4
+ Int16# -> -- a5
+ Int16# -> -- a6
+ Int16# -> -- a7
+ Word16# -> -- s0
+ Int16# -> -- s1
+ Int64# -- result
+
+foreign import ccall "fun32"
+ fun32 ::
+ Int32# -> -- a0
+ Word32# -> -- a1
+ Int32# -> -- a2
+ Int32# -> -- a3
+ Int32# -> -- a4
+ Int32# -> -- a5
+ Int32# -> -- a6
+ Int32# -> -- a7
+ Word32# -> -- s0
+ Int32# -> -- s1
+ Int64# -- result
+
+main :: IO ()
+main =
+ -- N.B. the values here aren't choosen by accident: -1 means all bits one in
+ -- twos-complement, which is the same as the max word value.
+ let i8 :: Int8# = intToInt8# (-1#)
+ w8 :: Word8# = wordToWord8# (255##)
+ res8 :: Int64# = fun8 i8 w8 i8 i8 i8 i8 i8 i8 w8 i8
+ expected_res8 :: Int64 = 2 * (fromInteger . fromIntegral) (maxBound :: Word8) + 8 * (-1)
+ i16 :: Int16# = intToInt16# (-1#)
+ w16 :: Word16# = wordToWord16# (65535##)
+ res16 :: Int64# = fun16 i16 w16 i16 i16 i16 i16 i16 i16 w16 i16
+ expected_res16 :: Int64 = 2 * (fromInteger . fromIntegral) (maxBound :: Word16) + 8 * (-1)
+ i32 :: Int32# = intToInt32# (-1#)
+ w32 :: Word32# = wordToWord32# (4294967295##)
+ res32 :: Int64# = fun32 i32 w32 i32 i32 i32 i32 i32 i32 w32 i32
+ expected_res32 :: Int64 = 2 * (fromInteger . fromIntegral) (maxBound :: Word32) + 8 * (-1)
+ in do
+ print $ "fun8 result:" ++ show (I64# res8)
+ assertEqual expected_res8 (I64# res8)
+ print $ "fun16 result:" ++ show (I64# res16)
+ assertEqual expected_res16 (I64# res16)
+ print $ "fun32 result:" ++ show (I64# res32)
+ assertEqual expected_res32 (I64# res32)
+
+assertEqual :: (Integral a, Integral b, Show a, Show b) => a -> b -> IO ()
+assertEqual a b =
+ if (fromIntegral a) == (fromIntegral b)
+ then pure ()
+ else error $ show a ++ " =/= " ++ show b
=====================================
testsuite/tests/codeGen/should_run/CCallConv.stdout
=====================================
@@ -0,0 +1,36 @@
+"fun8 result:502"
+"fun16 result:131062"
+"fun32 result:8589934582"
+fun32:
+a0: 0xffffffff -1
+a1: 0xffffffff 4294967295
+a2: 0xffffffff -1
+a3: 0xffffffff -1
+a4: 0xffffffff -1
+a5: 0xffffffff -1
+a6: 0xffffffff -1
+a7: 0xffffffff -1
+s0: 0xffffffff -1
+s1: 0xffffffff 4294967295
+fun16:
+a0: 0xffffffff -1
+a1: 0xffff 65535
+a2: 0xffffffff -1
+a3: 0xffffffff -1
+a4: 0xffffffff -1
+a5: 0xffffffff -1
+a6: 0xffffffff -1
+a7: 0xffffffff -1
+s0: 0xffffffff -1
+s1: 0xffff 65535
+fun8:
+a0: 0xffffffff -1
+a1: 0xff 255
+a2: 0xffffffff -1
+a3: 0xffffffff -1
+a4: 0xffffffff -1
+a5: 0xffffffff -1
+a6: 0xffffffff -1
+a7: 0xffffffff -1
+s0: 0xffffffff -1
+s1: 0xff 255
=====================================
testsuite/tests/codeGen/should_run/CCallConv_c.c
=====================================
@@ -0,0 +1,57 @@
+#include "stdint.h"
+#include "stdio.h"
+
+int64_t fun8(int8_t a0, uint8_t a1, int8_t a2, int8_t a3, int8_t a4, int8_t a5,
+ int8_t a6, int8_t a7, int8_t s0, uint8_t s1) {
+ printf("fun8:\n");
+ printf("a0: %#x %hhd\n", a0, a0);
+ printf("a1: %#x %hhu\n", a1, a1);
+ printf("a2: %#x %hhd\n", a2, a2);
+ printf("a3: %#x %hhd\n", a3, a3);
+ printf("a4: %#x %hhd\n", a4, a4);
+ printf("a5: %#x %hhd\n", a5, a5);
+ printf("a6: %#x %hhd\n", a6, a6);
+ printf("a7: %#x %hhd\n", a7, a7);
+ printf("s0: %#x %hhd\n", s0, s0);
+ printf("s1: %#x %hhu\n", s1, s1);
+
+ return a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + s0 + s1;
+}
+
+int64_t fun16(int16_t a0, uint16_t a1, int16_t a2, int16_t a3, int16_t a4,
+ int16_t a5, int16_t a6, int16_t a7, int16_t s0, uint16_t s1) {
+ printf("fun16:\n");
+ printf("a0: %#x %hd\n", a0, a0);
+ printf("a1: %#x %hu\n", a1, a1);
+ printf("a2: %#x %hd\n", a2, a2);
+ printf("a3: %#x %hd\n", a3, a3);
+ printf("a4: %#x %hd\n", a4, a4);
+ printf("a5: %#x %hd\n", a5, a5);
+ printf("a6: %#x %hd\n", a6, a6);
+ printf("a7: %#x %hd\n", a7, a7);
+ printf("s0: %#x %hd\n", s0, s0);
+ printf("s1: %#x %hu\n", s1, s1);
+
+ return a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + s0 + s1;
+}
+
+int64_t fun32(int32_t a0, uint32_t a1, int32_t a2, int32_t a3, int32_t a4,
+ int32_t a5, int32_t a6, int32_t a7, int32_t s0, uint32_t s1) {
+ printf("fun32:\n");
+ printf("a0: %#x %d\n", a0, a0);
+ printf("a1: %#x %u\n", a1, a1);
+ printf("a2: %#x %d\n", a2, a2);
+ printf("a3: %#x %d\n", a3, a3);
+ printf("a4: %#x %d\n", a4, a4);
+ printf("a5: %#x %d\n", a5, a5);
+ printf("a6: %#x %d\n", a6, a6);
+ printf("a7: %#x %d\n", a7, a7);
+ printf("s0: %#x %d\n", s0, s0);
+ printf("s1: %#x %u\n", s1, s1);
+
+ // Ensure the addition happens in long int (not just int) precission.
+ // Otherwise, the result is truncated during the operation.
+ int64_t force_int64_precission = 0;
+ return force_int64_precission + a0 + a1 + a2 + a3 + a4 + a5 + a6 + a7 + s0 +
+ s1;
+}
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -234,3 +234,8 @@ test('MulMayOflo',
[ omit_ways(['ghci']), js_skip, ignore_stdout],
multi_compile_and_run,
['MulMayOflo', [('MulMayOflo_cmm.cmm', '')], ''])
+
+test('CCallConv',
+ [],
+ multi_compile_and_run,
+ ['CCallConv', [('CCallConv_c.c', '')], ''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/265bb433fd78d8ff21026ee0894e1468a5974071...150bff5df2010f4d6115592c5977d8ecdf1c041b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/265bb433fd78d8ff21026ee0894e1468a5974071...150bff5df2010f4d6115592c5977d8ecdf1c041b
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230818/24347c34/attachment-0001.html>
More information about the ghc-commits
mailing list