CmmToLlvm: Sign/Zero extend parameters for foreign calls

For some architectures the C calling convention is that any integer
shorter than 64 bits is replaced by its 64 bits representation using
sign or zero extension.

Fixes #19023.

3 files changed, 47 insertions, 24 deletions

diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index 5c0f08f641..944da379f9 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -449,20 +449,7 @@ genCall target res args = do
   platform <- getPlatform
   runStmtsDecls $ do
 
-    -- parameter types
-    let arg_type (_, AddrHint) = i8Ptr
-        -- cast pointers to i8*. Llvm equivalent of void*
-        arg_type (expr, _) = cmmToLlvmType $ cmmExprType platform expr
-
-    -- ret type
-    let ret_type [] = LMVoid
-        ret_type [(_, AddrHint)] = i8Ptr
-        ret_type [(reg, _)]      = cmmToLlvmType $ localRegType reg
-        ret_type t = panic $ "genCall: Too many return values! Can only handle"
-                        ++ " 0 or 1, given " ++ show (length t) ++ "."
-
     -- extract Cmm call convention, and translate to LLVM call convention
-    platform <- lift $ getPlatform
     let lmconv = case target of
             ForeignTarget _ (ForeignConvention conv _ _ _) ->
               case conv of
@@ -485,6 +472,22 @@ genCall target res args = do
         The native code generator only handles StdCall and CCallConv.
     -}
 
+    -- parameter types
+    let arg_type (_, AddrHint) = (i8Ptr, [])
+        -- cast pointers to i8*. Llvm equivalent of void*
+        arg_type (expr, hint) =
+            case cmmToLlvmType $ cmmExprType platform expr of
+              ty@(LMInt n) | n < 64 && lmconv == CC_Ccc && platformCConvNeedsExtension platform
+                 -> (ty, if hint == SignedHint then [SignExt] else [ZeroExt])
+              ty -> (ty, [])
+
+    -- ret type
+    let ret_type [] = LMVoid
+        ret_type [(_, AddrHint)] = i8Ptr
+        ret_type [(reg, _)]      = cmmToLlvmType $ localRegType reg
+        ret_type t = panic $ "genCall: Too many return values! Can only handle"
+                        ++ " 0 or 1, given " ++ show (length t) ++ "."
+
     -- call attributes
     let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
                 | otherwise     = llvmStdFunAttrs
@@ -499,7 +502,7 @@ genCall target res args = do
     let ress_hints = zip res  res_hints
     let ccTy  = StdCall -- tail calls should be done through CmmJump
     let retTy = ret_type ress_hints
-    let argTy = tysToParams $ map arg_type args_hints
+    let argTy = map arg_type args_hints
     let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
                              lmconv retTy FixedArgs argTy (llvmFunAlign platform)
 
diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs
index 5d32473796..3cc4ab5394 100644
--- a/compiler/GHC/Llvm/Ppr.hs
+++ b/compiler/GHC/Llvm/Ppr.hs
@@ -284,7 +284,7 @@ ppCall opts ct fptr args attrs = case fptr of
     where
         ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
             let tc = if ct == TailCall then text "tail " else empty
-                ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args
+                ppValues = ppCallParams opts (map snd params) args
                 ppArgTy  = (ppCommaJoin $ map (ppr . fst) params) <>
                            (case argTy of
                                VarArgs   -> text ", ..."
@@ -295,10 +295,14 @@ ppCall opts ct fptr args attrs = case fptr of
                     <> fnty <+> ppName opts fptr <> lparen <+> ppValues
                     <+> rparen <+> attrDoc
 
-        -- Metadata needs to be marked as having the `metadata` type when used
-        -- in a call argument
-        ppCallMetaExpr (MetaVar v) = ppVar opts v
-        ppCallMetaExpr v           = text "metadata" <+> ppMetaExpr opts v
+        ppCallParams :: LlvmOpts -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc
+        ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args
+         where
+          -- Metadata needs to be marked as having the `metadata` type when used
+          -- in a call argument
+          ppCallMetaExpr attrs (MetaVar v) = ppVar' attrs opts v
+          ppCallMetaExpr _ v             = text "metadata" <+> ppMetaExpr opts v
+
 
 ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
 ppMachOp opts op left right =
@@ -546,14 +550,20 @@ ppLit opts l = case l of
       | otherwise                  -> text "undef"
 
 ppVar :: LlvmOpts -> LlvmVar -> SDoc
-ppVar opts v = case v of
-  LMLitVar x -> ppTypeLit opts x
-  x          -> ppr (getVarType x) <+> ppName opts x
+ppVar = ppVar' []
+
+ppVar' :: [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc
+ppVar' attrs opts v = case v of
+  LMLitVar x -> ppTypeLit' attrs opts x
+  x          -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x
 
 ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc
-ppTypeLit opts l = case l of
+ppTypeLit = ppTypeLit' []
+
+ppTypeLit' :: [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc
+ppTypeLit' attrs opts l = case l of
   LMVectorLit {} -> ppLit opts l
-  _              -> ppr (getLitType l) <+> ppLit opts l
+  _              -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l
 
 ppStatic :: LlvmOpts -> LlvmStatic -> SDoc
 ppStatic opts st = case st of
diff --git a/compiler/GHC/Platform.hs b/compiler/GHC/Platform.hs
index 1e6add2b46..5e54e2111e 100644
--- a/compiler/GHC/Platform.hs
+++ b/compiler/GHC/Platform.hs
@@ -28,6 +28,7 @@ module GHC.Platform
    , platformMaxWord
    , platformInIntRange
    , platformInWordRange
+   , platformCConvNeedsExtension
    , PlatformMisc(..)
    , SseVersion (..)
    , BmiVersion (..)
@@ -182,6 +183,15 @@ platformInIntRange platform x = x >= platformMinInt platform && x <= platformMax
 platformInWordRange :: Platform -> Integer -> Bool
 platformInWordRange platform x = x >= 0 && x <= platformMaxWord platform
 
+-- | For some architectures the C calling convention is that any
+-- integer shorter than 64 bits is replaced by its 64 bits
+-- representation using sign or zero extension.
+platformCConvNeedsExtension :: Platform -> Bool
+platformCConvNeedsExtension platform = case platformArch platform of
+  ArchPPC_64 _ -> True
+  ArchS390X    -> True
+  _            -> False
+
 
 --------------------------------------------------
 -- Instruction sets