LlvmFunctions, LlvmFunctionDecls,
LlvmStatement(..), LlvmExpression(..),
LlvmBlocks, LlvmBlock(..), LlvmBlockId,
+ LlvmParamAttr(..), LlvmParameter,
-- * Call Handling
LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),
-- | The signature of this declared function.
funcDecl :: LlvmFunctionDecl,
+ -- | The functions arguments
+ funcArgs :: [LMString],
+
-- | The function attributes.
funcAttrs :: [LlvmFuncAttr],
-- | 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
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)
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
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
--
-- | 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
}
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.
--
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
- llvmPtrBits, llvmGhcCC,
+ llvmPtrBits, mkLlvmFunc, tysToParams,
strCLabel_llvm, genCmmLabelRef, genStringLabelRef
-- | 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
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
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
-- 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
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)
projects / ghc-hetmet.git / commitdiff