From: David Terei Date: Thu, 24 Jun 2010 11:17:44 +0000 (+0000) Subject: Add support for parameter attributes to the llvm BE binding X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6bae9f3ff5422c8ebe8a53d0981f51b3ced26777 Add support for parameter attributes to the llvm BE binding These allow annotations of the code produced by the backend which should bring some perforamnce gains. At the moment the attributes aren't being used though. --- diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index 907ab39..dcb8706 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -18,6 +18,7 @@ module Llvm ( LlvmFunctions, LlvmFunctionDecls, LlvmStatement(..), LlvmExpression(..), LlvmBlocks, LlvmBlock(..), LlvmBlockId, + LlvmParamAttr(..), LlvmParameter, -- * Call Handling LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..), diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index 05a0f08..1fed3a8 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -43,6 +43,9 @@ data LlvmFunction = LlvmFunction { -- | The signature of this declared function. funcDecl :: LlvmFunctionDecl, + -- | The functions arguments + funcArgs :: [LMString], + -- | The function attributes. funcAttrs :: [LlvmFuncAttr], diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index fffb72d..9afb76e 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -104,17 +104,30 @@ ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs -- | Print out a function definition. ppLlvmFunction :: LlvmFunction -> Doc -ppLlvmFunction (LlvmFunction dec attrs sec body) = +ppLlvmFunction (LlvmFunction dec args attrs sec body) = let attrDoc = ppSpaceJoin attrs secDoc = case sec of - Just s' -> text "section " <+> (doubleQuotes $ ftext s') + Just s' -> text "section" <+> (doubleQuotes $ ftext s') Nothing -> empty - in text "define" <+> texts dec + in text "define" <+> ppLlvmFunctionHeader dec args <+> attrDoc <+> secDoc $+$ lbrace $+$ ppLlvmBlocks body $+$ rbrace +-- | Print out a function defenition header. +ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc +ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args + = let varg' = if varg == VarArgs then text ", ..." else empty + align = case a of + Just a' -> space <> text "align" <+> texts a' + Nothing -> empty + args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%" + <> ftext n) + (zip p args) + in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <> + (hcat $ intersperse comma args') <> varg' <> rparen <> align + -- | Print out a list of function declaration. ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc @@ -194,7 +207,8 @@ ppCall ct fptr vals attrs = case fptr of ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = let tc = if ct == TailCall then text "tail " else empty ppValues = ppCommaJoin vals - ppArgTy = either ppCommaJoin (\x -> ppCommaJoin $ map getVarType x) params <> + ppParams = map (\(ty,p) -> texts ty <+> ppSpaceJoin p) params + ppArgTy = (hcat $ intersperse comma ppParams) <> (case argTy of VarArgs -> text ", ..." FixedArgs -> empty) diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 19a441f..50b3656 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -57,10 +57,11 @@ instance Show LlvmType where show (LMVoid ) = "void" show (LMStruct tys ) = "{" ++ (commaCat tys) ++ "}" - show (LMFunction (LlvmFunctionDecl _ _ _ r VarArgs p _)) - = show r ++ " (" ++ (either commaCat commaCat p) ++ ", ...)" - show (LMFunction (LlvmFunctionDecl _ _ _ r FixedArgs p _)) - = show r ++ " (" ++ (either commaCat commaCat p) ++ ")" + show (LMFunction (LlvmFunctionDecl _ _ _ r varg p _)) + = let varg' = if varg == VarArgs then ", ..." else "" + args = (tail.concat) $ + map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p + in show r ++ " (" ++ args ++ varg' ++ ")" show (LMAlias s _ ) = "%" ++ unpackFS s @@ -168,6 +169,11 @@ commaCat :: Show a => [a] -> String commaCat [] = "" commaCat x = show (head x) ++ (concat $ map (\y -> "," ++ show y) (tail x)) +-- | Concatenate an array together, separated by commas +spaceCat :: Show a => [a] -> String +spaceCat [] = "" +spaceCat x = show (head x) ++ (concat $ map (\y -> " " ++ show y) (tail x)) + -- ----------------------------------------------------------------------------- -- ** Operations on LLVM Basic Types and Variables -- @@ -326,19 +332,18 @@ llvmWordPtr = pLift llvmWord -- | An LLVM Function data LlvmFunctionDecl = LlvmFunctionDecl { - -- | Unique identifier of the function. + -- | Unique identifier of the function decName :: LMString, - -- | LinkageType of the function. + -- | LinkageType of the function funcLinkage :: LlvmLinkageType, - -- | The calling convention of the function. + -- | The calling convention of the function funcCc :: LlvmCallConvention, -- | Type of the returned value decReturnType :: LlvmType, -- | Indicates if this function uses varargs decVarargs :: LlvmParameterListType, - -- | Signature of the parameters, can be just types or full vars - -- if parameter names are required. - decParams :: Either [LlvmType] [LlvmVar], + -- | Parameter types and attributes + decParams :: [LlvmParameter], -- | Function align value, must be power of 2 funcAlign :: LMAlign } @@ -350,11 +355,59 @@ instance Show LlvmFunctionDecl where align = case a of Just a' -> " align " ++ show a' Nothing -> "" + args = (tail.concat) $ + map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p in show l ++ " " ++ show c ++ " " ++ show r ++ " @" ++ unpackFS n ++ - "(" ++ (either commaCat commaCat p) ++ varg' ++ ")" ++ align + "(" ++ args ++ varg' ++ ")" ++ align type LlvmFunctionDecls = [LlvmFunctionDecl] +type LlvmParameter = (LlvmType, [LlvmParamAttr]) + +-- | LLVM Parameter Attributes. +-- +-- Parameter attributes are used to communicate additional information about +-- the result or parameters of a function +data LlvmParamAttr + -- | This indicates to the code generator that the parameter or return value + -- should be zero-extended to a 32-bit value by the caller (for a parameter) + -- or the callee (for a return value). + = ZeroExt + -- | This indicates to the code generator that the parameter or return value + -- should be sign-extended to a 32-bit value by the caller (for a parameter) + -- or the callee (for a return value). + | SignExt + -- | This indicates that this parameter or return value should be treated in + -- a special target-dependent fashion during while emitting code for a + -- function call or return (usually, by putting it in a register as opposed + -- to memory). + | InReg + -- | This indicates that the pointer parameter should really be passed by + -- value to the function. + | ByVal + -- | This indicates that the pointer parameter specifies the address of a + -- structure that is the return value of the function in the source program. + | SRet + -- | This indicates that the pointer does not alias any global or any other + -- parameter. + | NoAlias + -- | This indicates that the callee does not make any copies of the pointer + -- that outlive the callee itself + | NoCapture + -- | This indicates that the pointer parameter can be excised using the + -- trampoline intrinsics. + | Nest + deriving (Eq) + +instance Show LlvmParamAttr where + show ZeroExt = "zeroext" + show SignExt = "signext" + show InReg = "inreg" + show ByVal = "byval" + show SRet = "sret" + show NoAlias = "noalias" + show NoCapture = "nocapture" + show Nest = "nest" -- | Llvm Function Attributes. -- diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 5e0df3e..83469c8 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -14,7 +14,7 @@ module LlvmCodeGen.Base ( cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, - llvmPtrBits, llvmGhcCC, + llvmPtrBits, mkLlvmFunc, tysToParams, strCLabel_llvm, genCmmLabelRef, genStringLabelRef @@ -82,17 +82,22 @@ llvmGhcCC = CC_Ncc 10 -- | Llvm Function type for Cmm function llvmFunTy :: LlvmType -llvmFunTy - = LMFunction $ - LlvmFunctionDecl (fsLit "a") ExternallyVisible llvmGhcCC LMVoid FixedArgs - (Left $ map getVarType llvmFunArgs) llvmFunAlign +llvmFunTy = LMFunction $ llvmFunSig' (fsLit "a") ExternallyVisible -- | Llvm Function signature llvmFunSig :: CLabel -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig lbl link - = let n = strCLabel_llvm lbl - in LlvmFunctionDecl n link llvmGhcCC LMVoid FixedArgs - (Right llvmFunArgs) llvmFunAlign +llvmFunSig lbl link = llvmFunSig' (strCLabel_llvm lbl) link + +llvmFunSig' :: LMString -> LlvmLinkageType -> LlvmFunctionDecl +llvmFunSig' lbl link = LlvmFunctionDecl lbl link llvmGhcCC LMVoid FixedArgs + (tysToParams $ map getVarType llvmFunArgs) llvmFunAlign + +-- | Create a Haskell function in LLVM. +mkLlvmFunc :: CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks -> LlvmFunction +mkLlvmFunc lbl link sec blks + = let funDec = llvmFunSig lbl link + funArgs = map (fsLit . getPlainName) llvmFunArgs + in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks -- | Alignment to use for functions llvmFunAlign :: LMAlign @@ -110,6 +115,11 @@ llvmFunArgs = map lmGlobalRegArg activeStgRegs llvmStdFunAttrs :: [LlvmFuncAttr] llvmStdFunAttrs = [NoUnwind] +-- | Convert a list of types to a list of function parameters +-- (each with no parameter attributes) +tysToParams :: [LlvmType] -> [LlvmParameter] +tysToParams = map (\ty -> (ty, [])) + -- | Pointer width llvmPtrBits :: Int llvmPtrBits = widthInBits $ typeWidth gcWord diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 85094f7..c945f97 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -153,7 +153,7 @@ genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do let fname = fsLit "llvm.memory.barrier" let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid - FixedArgs (Left [i1, i1, i1, i1, i1]) llvmFunAlign + FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign let fty = LMFunction funSig let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False @@ -217,7 +217,7 @@ genCall env target res args ret = do -- fun type let ccTy = StdCall -- tail calls should be done through CmmJump let retTy = ret_type res - let argTy = Left $ map arg_type args + let argTy = tysToParams $ map arg_type args let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible lmconv retTy FixedArgs argTy llvmFunAlign diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 8137713..2a96efb 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -90,10 +90,9 @@ pprLlvmCmmTop env count (CmmProc info lbl _ (ListGraph blks)) link = if externallyVisibleCLabel lbl' then ExternallyVisible else Internal - funDec = llvmFunSig lbl' link lmblocks = map (\(BasicBlock id stmts) -> LlvmBlock (getUnique id) stmts) blks - fun = LlvmFunction funDec [NoUnwind] sec' lmblocks + fun = mkLlvmFunc lbl' link sec' lmblocks in ppLlvmFunction fun ), ivar)