From 043459646ccc1bb4e9bfd414c0e01cae2b88fd82 Mon Sep 17 00:00:00 2001
From: Stefan Schulze Frielinghaus <stefansf@linux.ibm.com>
Date: Wed, 21 Jul 2021 13:31:47 +0200
Subject: [PATCH] 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.
This is basically a backport of 0ac5860ea4d45587771869970beecdd4da0cb105
but adjusted for the 8.10 branch.
Fixes #20120
---
compiler/llvmGen/Llvm/PpLlvm.hs | 13 ++++++++-----
compiler/llvmGen/Llvm/Types.hs | 16 ++++++++++++----
compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 17 ++++++++++++++++-
3 files changed, 36 insertions(+), 10 deletions(-)
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index b534276f08ea..eb9508c9721d 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -268,7 +268,7 @@ ppCall 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 (map snd params) args
ppArgTy = (ppCommaJoin $ map fst params) <>
(case argTy of
VarArgs -> text ", ..."
@@ -279,10 +279,13 @@ ppCall ct fptr args attrs = case fptr of
<> fnty <+> ppName fptr <> lparen <+> ppValues
<+> rparen <+> attrDoc
- -- Metadata needs to be marked as having the `metadata` type when used
- -- in a call argument
- ppCallMetaExpr (MetaVar v) = ppr v
- ppCallMetaExpr v = text "metadata" <+> ppr v
+ ppCallParams :: [[LlvmParamAttr]] -> [MetaExpr] -> SDoc
+ ppCallParams 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 v
+ ppCallMetaExpr _ v = text "metadata" <+> ppr v
ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp op left right =
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index f477aa64edda..059f412fe3e4 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -114,8 +114,12 @@ data LlvmVar
deriving (Eq)
instance Outputable LlvmVar where
- ppr (LMLitVar x) = ppr x
- ppr (x ) = ppr (getVarType x) <+> ppName x
+ ppr = ppVar' []
+
+ppVar' :: [LlvmParamAttr] -> LlvmVar -> SDoc
+ppVar' attrs v = case v of
+ LMLitVar x -> ppTypeLit' attrs x
+ x -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName x
-- | Llvm Literal Data.
@@ -135,8 +139,12 @@ data LlvmLit
deriving (Eq)
instance Outputable LlvmLit where
- ppr l@(LMVectorLit {}) = ppLit l
- ppr l = ppr (getLitType l) <+> ppLit l
+ ppr = ppTypeLit' []
+
+ppTypeLit' :: [LlvmParamAttr] -> LlvmLit -> SDoc
+ppTypeLit' attrs l = case l of
+ l@(LMVectorLit {}) -> ppLit l
+ _ -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit l
-- | Llvm Static Data.
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 7c1c5832ed27..15a4bc7199d9 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -460,6 +460,12 @@ genCall target res args = runStmtsDecls $ do
The native code generator only handles StdCall and CCallConv.
-}
+ let arg_type (hint, expr) =
+ case expr of
+ ty@(LMInt n) | n < 64 && lmconv == CC_Ccc && platformCConvNeedsExtension platform
+ -> (ty, if hint == Signed then [SignExt] else [ZeroExt])
+ ty -> (ty, [])
+
-- call attributes
let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
| otherwise = llvmStdFunAttrs
@@ -477,7 +483,7 @@ genCall target res args = runStmtsDecls $ do
let retTyCmm = ret_type_cmm ress_hints
- let argTy = tysToParams $ map (snd . primRepToLlvmTy) args_rep
+ let argTy = map arg_type $ map primRepToLlvmTy args_rep
let retTy = snd $ primRepToLlvmTy ret_rep
let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
@@ -524,6 +530,15 @@ genCall target res args = runStmtsDecls $ do
v2 <- doExprW ty $ Cast op v1 ty
statement $ Store v2 vreg
doReturn
+ where
+ -- | 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
-- | Generate a call to an LLVM intrinsic that performs arithmetic operation
-- with overflow bit (i.e., returns a struct containing the actual result of the
--
GitLab