diff options
author | Stefan Schulze Frielinghaus <stefansf@linux.ibm.com> | 2020-12-11 16:23:43 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-01-17 05:47:24 -0500 |
commit | 0ac5860ea4d45587771869970beecdd4da0cb105 (patch) | |
tree | a4dfb3d9063f9c705e14838d5acfb4184e712b76 | |
parent | 9ab0f830e362d330ae91678152990b4babeacd51 (diff) | |
download | haskell-0ac5860ea4d45587771869970beecdd4da0cb105.tar.gz |
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.
-rw-r--r-- | compiler/GHC/CmmToLlvm/CodeGen.hs | 31 | ||||
-rw-r--r-- | compiler/GHC/Llvm/Ppr.hs | 30 | ||||
-rw-r--r-- | compiler/GHC/Platform.hs | 10 |
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 |