Commit 6bae9f3f authored by dterei's avatar dterei
Browse files

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.
parent 7dc0cd52
......@@ -18,6 +18,7 @@ module Llvm (
LlvmFunctions, LlvmFunctionDecls,
LlvmStatement(..), LlvmExpression(..),
LlvmBlocks, LlvmBlock(..), LlvmBlockId,
LlvmParamAttr(..), LlvmParameter,
-- * Call Handling
LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),
......
......@@ -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],
......
......@@ -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)
......
......@@ -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.
--
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment