X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FllvmGen%2FLlvm%2FTypes.hs;h=3637c864673ebd74f51c01f2ee3960ed3bc7cc1e;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hp=9275c07556de53c9df89bda72d9b83803a191bc3;hpb=24a3fee9f3ff6cef6fe471ab6f0a7ba9ac001faf;p=ghc-hetmet.git diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 9275c07..3637c86 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -5,7 +5,6 @@ module Llvm.Types where #include "HsVersions.h" -#include "ghcconfig.h" import Data.Char import Numeric @@ -22,26 +21,26 @@ import PprBase -- -- | A global mutable variable. Maybe defined or external -type LMGlobal = (LlvmVar, Maybe LlvmStatic) --- | A global constant variable -type LMConstant = (LlvmVar, LlvmStatic) +type LMGlobal = (LlvmVar, Maybe LlvmStatic) -- | A String in LLVM -type LMString = FastString +type LMString = FastString +-- | A type alias +type LlvmAlias = (LMString, LlvmType) --- | Llvm Types. +-- | Llvm Types data LlvmType - = LMInt Int -- ^ An integer with a given width in bits. - | LMFloat -- ^ 32 bit floating point - | LMDouble -- ^ 64 bit floating point - | LMFloat80 -- ^ 80 bit (x86 only) floating point - | LMFloat128 -- ^ 128 bit floating point - | LMPointer LlvmType -- ^ A pointer to a 'LlvmType' - | LMArray Int LlvmType -- ^ An array of 'LlvmType' - | LMLabel -- ^ A 'LlvmVar' can represent a label (address) - | LMVoid -- ^ Void type - | LMStruct [LlvmType] -- ^ Structure type - | LMAlias LMString LlvmType -- ^ A type alias + = LMInt Int -- ^ An integer with a given width in bits. + | LMFloat -- ^ 32 bit floating point + | LMDouble -- ^ 64 bit floating point + | LMFloat80 -- ^ 80 bit (x86 only) floating point + | LMFloat128 -- ^ 128 bit floating point + | LMPointer LlvmType -- ^ A pointer to a 'LlvmType' + | LMArray Int LlvmType -- ^ An array of 'LlvmType' + | LMLabel -- ^ A 'LlvmVar' can represent a label (address) + | LMVoid -- ^ Void type + | LMStruct [LlvmType] -- ^ Structure type + | LMAlias LlvmAlias -- ^ A type alias -- | Function type, used to create pointers to functions | LMFunction LlvmFunctionDecl @@ -57,23 +56,28 @@ instance Show LlvmType where show (LMArray nr tp ) = "[" ++ show nr ++ " x " ++ show tp ++ "]" show (LMLabel ) = "label" show (LMVoid ) = "void" - show (LMStruct tys ) = "{" ++ (commaCat tys) ++ "}" + 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 + show (LMAlias (s,_)) = "%" ++ unpackFS s --- | An LLVM section defenition. If Nothing then let LLVM decide the section +-- | An LLVM section definition. 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 @@ -95,7 +99,11 @@ data LlvmLit -- | Refers to an integer constant (i64 42). = LMIntLit Integer LlvmType -- | Floating point literal - | LMFloatLit Rational LlvmType + | LMFloatLit Double LlvmType + -- | Literal NULL, only applicable to pointer types + | LMNullLit LlvmType + -- | Undefined value, random bit pattern. Useful for optimisations. + | LMUndefLit LlvmType deriving (Eq) instance Show LlvmLit where @@ -137,9 +145,9 @@ instance Show LlvmStatic where show (LMStaticStruc d t) = let struc = case d of - [] -> "{}" - ts -> "{" ++ show (head ts) ++ - concat (map (\x -> "," ++ show x) (tail ts)) ++ "}" + [] -> "<{}>" + ts -> "<{" ++ show (head ts) ++ + concat (map (\x -> "," ++ show x) (tail ts)) ++ "}>" in show t ++ " " ++ struc show (LMStaticPointer v) = show v @@ -152,14 +160,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 +179,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,39 +191,42 @@ 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 LMLabel ) = show x +getPlainName (LMLocalVar x _ ) = "l" ++ 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) --- In Llvm float literals can be printed in a big-endian hexadecimal format, --- regardless of underlying architecture. -getLit (LMFloatLit r LMFloat) = fToStr $ fromRational r -getLit (LMFloatLit r LMDouble) = dToStr $ fromRational r -getLit l = error $ "getLit: Usupported LlvmLit type! " ++ show (getLitType l) +getLit (LMIntLit i _) = show ((fromInteger i)::Int) +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 +getLit (LMNullLit _) = "null" +getLit (LMUndefLit _) = "undef" -- | 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 getLitType (LMIntLit _ t) = t getLitType (LMFloatLit _ t) = t +getLitType (LMNullLit t) = t +getLitType (LMUndefLit t) = t -- | Return the 'LlvmType' of the 'LlvmStatic' getStatType :: LlvmStatic -> LlvmType @@ -234,8 +252,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. @@ -246,10 +264,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. @@ -259,10 +277,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 @@ -284,8 +302,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 @@ -302,7 +320,7 @@ llvmWidthInBits LMLabel = 0 llvmWidthInBits LMVoid = 0 llvmWidthInBits (LMStruct tys) = sum $ map llvmWidthInBits tys llvmWidthInBits (LMFunction _) = 0 -llvmWidthInBits (LMAlias _ t) = llvmWidthInBits t +llvmWidthInBits (LMAlias (_,t)) = llvmWidthInBits t -- ----------------------------------------------------------------------------- @@ -329,19 +347,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 } @@ -349,15 +366,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. -- @@ -580,10 +648,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 @@ -606,9 +678,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" @@ -695,11 +770,9 @@ instance Show LlvmCastOp where -- * Floating point conversion -- --- | Convert a Haskell Float to an LLVM hex encoded floating point form -fToStr :: Float -> String -fToStr f = dToStr $ realToFrac f - --- | Convert a Haskell Double to an LLVM hex encoded floating point form +-- | Convert a Haskell Double to an LLVM hex encoded floating point form. In +-- Llvm float literals can be printed in a big-endian hexadecimal format, +-- regardless of underlying architecture. dToStr :: Double -> String dToStr d = let bs = doubleToBytes d @@ -712,9 +785,15 @@ dToStr d str = map toUpper $ concat . fixEndian . (map hex) $ bs in "0x" ++ str --- | Reverse or leave byte data alone to fix endianness on this --- target. LLVM generally wants things in Big-Endian form --- regardless of target architecture. +-- | 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 fixEndian = id