X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FllvmGen%2FLlvm%2FTypes.hs;h=af2ae9e22d1ca9ccd48f14b680d828f31c5ced2b;hb=20ea4cf4993aa7b0b19c882fd98503a4b7f307d3;hp=a0b003298c8b696a76af631b7354a5550a3da23f;hpb=4bb4a1cfa8b88fefae3405d101dc6ff0f7adbae3;p=ghc-hetmet.git diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index a0b0032..af2ae9e 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -23,8 +23,6 @@ import PprBase -- | A global mutable variable. Maybe defined or external type LMGlobal = (LlvmVar, Maybe LlvmStatic) --- | A global constant variable -type LMConstant = (LlvmVar, LlvmStatic) -- | A String in LLVM type LMString = FastString @@ -59,21 +57,26 @@ 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 args = ((drop 1).concat) $ -- use drop since it can handle empty lists + map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p + varg' = case varg of + VarArgs | not (null args) -> ", ..." + | otherwise -> "..." + _otherwise -> "" + in show r ++ " (" ++ args ++ varg' ++ ")" show (LMAlias s _ ) = "%" ++ unpackFS s -- | An LLVM section defenition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString type LMAlign = Maybe Int +type LMConst = Bool -- ^ is a variable constant or not -- | Llvm Variables data LlvmVar -- | Variables with a global scope. - = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign + = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst -- | Variables local to a function or parameters. | LMLocalVar Unique LlvmType -- | Named local variables. Sometimes we need to be able to explicitly name @@ -152,14 +155,16 @@ instance Show LlvmStatic where show (LMAdd s1 s2) = let ty1 = getStatType s1 + op = if isFloat ty1 then " fadd (" else " add (" in if ty1 == getStatType s2 - then show ty1 ++ " add (" ++ show s1 ++ "," ++ show s2 ++ ")" + then show ty1 ++ op ++ show s1 ++ "," ++ show s2 ++ ")" else error $ "LMAdd with different types! s1: " ++ show s1 ++ ", s2: " ++ show s2 show (LMSub s1 s2) = let ty1 = getStatType s1 + op = if isFloat ty1 then " fsub (" else " sub (" in if ty1 == getStatType s2 - then show ty1 ++ " sub (" ++ show s1 ++ "," ++ show s2 ++ ")" + then show ty1 ++ op ++ show s1 ++ "," ++ show s2 ++ ")" else error $ "LMSub with different types! s1: " ++ show s1 ++ ", s2: " ++ show s2 @@ -169,6 +174,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 -- @@ -176,30 +186,32 @@ commaCat x = show (head x) ++ (concat $ map (\y -> "," ++ show y) (tail x)) -- | Return the variable name or value of the 'LlvmVar' -- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@). getName :: LlvmVar -> String -getName v@(LMGlobalVar _ _ _ _ _) = "@" ++ getPlainName v -getName v@(LMLocalVar _ _ ) = "%" ++ getPlainName v -getName v@(LMNLocalVar _ _ ) = "%" ++ getPlainName v -getName v@(LMLitVar _ ) = getPlainName v +getName v@(LMGlobalVar _ _ _ _ _ _) = "@" ++ getPlainName v +getName v@(LMLocalVar _ _ ) = "%" ++ getPlainName v +getName v@(LMNLocalVar _ _ ) = "%" ++ getPlainName v +getName v@(LMLitVar _ ) = getPlainName v -- | Return the variable name or value of the 'LlvmVar' -- in a plain textual representation (e.g. @x@, @y@ or @42@). getPlainName :: LlvmVar -> String -getPlainName (LMGlobalVar x _ _ _ _) = unpackFS x -getPlainName (LMLocalVar x _ ) = show x -getPlainName (LMNLocalVar x _ ) = unpackFS x -getPlainName (LMLitVar x ) = getLit x +getPlainName (LMGlobalVar x _ _ _ _ _) = unpackFS x +getPlainName (LMLocalVar x _ ) = show x +getPlainName (LMNLocalVar x _ ) = unpackFS x +getPlainName (LMLitVar x ) = getLit x -- | Print a literal value. No type. getLit :: LlvmLit -> String getLit (LMIntLit i _) = show ((fromInteger i)::Int) -getLit (LMFloatLit r _) = dToStr r +getLit (LMFloatLit r LMFloat ) = fToStr $ realToFrac r +getLit (LMFloatLit r LMDouble) = dToStr r +getLit f@(LMFloatLit _ _) = error $ "Can't print this float literal!" ++ show f -- | Return the 'LlvmType' of the 'LlvmVar' getVarType :: LlvmVar -> LlvmType -getVarType (LMGlobalVar _ y _ _ _) = y -getVarType (LMLocalVar _ y ) = y -getVarType (LMNLocalVar _ y ) = y -getVarType (LMLitVar l ) = getLitType l +getVarType (LMGlobalVar _ y _ _ _ _) = y +getVarType (LMLocalVar _ y ) = y +getVarType (LMNLocalVar _ y ) = y +getVarType (LMLitVar l ) = getLitType l -- | Return the 'LlvmType' of a 'LlvmLit' getLitType :: LlvmLit -> LlvmType @@ -230,8 +242,8 @@ getGlobalVar (v, _) = v -- | Return the 'LlvmLinkageType' for a 'LlvmVar' getLink :: LlvmVar -> LlvmLinkageType -getLink (LMGlobalVar _ _ l _ _) = l -getLink _ = Internal +getLink (LMGlobalVar _ _ l _ _ _) = l +getLink _ = Internal -- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid' -- cannot be lifted. @@ -242,10 +254,10 @@ pLift x = LMPointer x -- | Lower a variable of 'LMPointer' type. pVarLift :: LlvmVar -> LlvmVar -pVarLift (LMGlobalVar s t l x a) = LMGlobalVar s (pLift t) l x a -pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t) -pVarLift (LMNLocalVar s t ) = LMNLocalVar s (pLift t) -pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!" +pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c +pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t) +pVarLift (LMNLocalVar s t ) = LMNLocalVar s (pLift t) +pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!" -- | Remove the pointer indirection of the supplied type. Only 'LMPointer' -- constructors can be lowered. @@ -255,10 +267,10 @@ pLower x = error $ show x ++ " is a unlowerable type, need a pointer" -- | Lower a variable of 'LMPointer' type. pVarLower :: LlvmVar -> LlvmVar -pVarLower (LMGlobalVar s t l x a) = LMGlobalVar s (pLower t) l x a -pVarLower (LMLocalVar s t ) = LMLocalVar s (pLower t) -pVarLower (LMNLocalVar s t ) = LMNLocalVar s (pLower t) -pVarLower (LMLitVar _ ) = error $ "Can't lower a literal type!" +pVarLower (LMGlobalVar s t l x a c) = LMGlobalVar s (pLower t) l x a c +pVarLower (LMLocalVar s t ) = LMLocalVar s (pLower t) +pVarLower (LMNLocalVar s t ) = LMNLocalVar s (pLower t) +pVarLower (LMLitVar _ ) = error $ "Can't lower a literal type!" -- | Test if the given 'LlvmType' is an integer isInt :: LlvmType -> Bool @@ -280,8 +292,8 @@ isPointer _ = False -- | Test if a 'LlvmVar' is global. isGlobal :: LlvmVar -> Bool -isGlobal (LMGlobalVar _ _ _ _ _) = True -isGlobal _ = False +isGlobal (LMGlobalVar _ _ _ _ _ _) = True +isGlobal _ = False -- | Width in bits of an 'LlvmType', returns 0 if not applicable llvmWidthInBits :: LlvmType -> Int @@ -325,19 +337,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 } @@ -345,15 +356,66 @@ data LlvmFunctionDecl = LlvmFunctionDecl { instance Show LlvmFunctionDecl where show (LlvmFunctionDecl n l c r varg p a) - = let varg' = if varg == VarArgs then ", ..." else "" + = let args = ((drop 1).concat) $ -- use drop since it can handle empty lists + map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p + varg' = case varg of + VarArgs | not (null args) -> ", ..." + | otherwise -> "..." + _otherwise -> "" align = case a of Just a' -> " align " ++ show a' Nothing -> "" - in show l ++ " " ++ show c ++ " " ++ show r ++ " @" ++ unpackFS n ++ - "(" ++ (either commaCat commaCat p) ++ varg' ++ ")" ++ align + in show l ++ " " ++ show c ++ " " ++ show r ++ " @" ++ unpackFS n ++ + "(" ++ 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. -- @@ -576,10 +638,14 @@ data LlvmMachOp | LM_MO_Mul -- ^ multiply .. | LM_MO_UDiv -- ^ unsigned integer or vector division. | LM_MO_SDiv -- ^ signed integer .. - | LM_MO_FDiv -- ^ floating point .. | LM_MO_URem -- ^ unsigned integer or vector remainder (mod) | LM_MO_SRem -- ^ signed ... - | LM_MO_FRem -- ^ floating point ... + + | LM_MO_FAdd -- ^ add two floating point or vector values. + | LM_MO_FSub -- ^ subtract two ... + | LM_MO_FMul -- ^ multiply ... + | LM_MO_FDiv -- ^ divide ... + | LM_MO_FRem -- ^ remainder ... -- | Left shift | LM_MO_Shl @@ -602,9 +668,12 @@ instance Show LlvmMachOp where show LM_MO_Mul = "mul" show LM_MO_UDiv = "udiv" show LM_MO_SDiv = "sdiv" - show LM_MO_FDiv = "fdiv" show LM_MO_URem = "urem" show LM_MO_SRem = "srem" + show LM_MO_FAdd = "fadd" + show LM_MO_FSub = "fsub" + show LM_MO_FMul = "fmul" + show LM_MO_FDiv = "fdiv" show LM_MO_FRem = "frem" show LM_MO_Shl = "shl" show LM_MO_LShr = "lshr" @@ -706,6 +775,14 @@ dToStr d str = map toUpper $ concat . fixEndian . (map hex) $ bs in "0x" ++ str +-- | Convert a Haskell Float to an LLVM hex encoded floating point form. +-- LLVM uses the same encoding for both floats and doubles (16 digit hex +-- string) but floats must have the last half all zeroes so it can fit into +-- a float size type. +{-# NOINLINE fToStr #-} +fToStr :: Float -> String +fToStr = (dToStr . realToFrac) + -- | Reverse or leave byte data alone to fix endianness on this target. fixEndian :: [a] -> [a] #ifdef WORDS_BIGENDIAN