-- | 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
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
+ = 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
-- | Refers to an integer constant (i64 42).
= LMIntLit Integer LlvmType
-- | Floating point literal
- | LMFloatLit Rational LlvmType
+ | LMFloatLit Double LlvmType
deriving (Eq)
instance Show LlvmLit where
-- static expressions, could split out but leave
-- for moment for ease of use. Not many of them.
+ | LMBitc LlvmStatic LlvmType -- ^ Pointer to Pointer conversion
| LMPtoI LlvmStatic LlvmType -- ^ Pointer to Integer conversion
| LMAdd LlvmStatic LlvmStatic -- ^ Constant addition operation
| LMSub LlvmStatic LlvmStatic -- ^ Constant subtraction operation
- deriving (Eq)
instance Show LlvmStatic where
show (LMComment s) = "; " ++ unpackFS s
show (LMStaticArray 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 (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
+ show (LMBitc v t)
+ = show t ++ " bitcast (" ++ show v ++ " to " ++ show t ++ ")"
+
show (LMPtoI v t)
= show t ++ " ptrtoint (" ++ show v ++ " to " ++ show t ++ ")"
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
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
--
-- | 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)
--- 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
-- | 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
getStatType (LMStaticArray _ t) = t
getStatType (LMStaticStruc _ t) = t
getStatType (LMStaticPointer v) = getVarType v
+getStatType (LMBitc _ t) = t
getStatType (LMPtoI _ t) = t
getStatType (LMAdd t _) = getStatType t
getStatType (LMSub t _) = getStatType t
-- | Return the 'LlvmLinkageType' for a 'LlvmVar'
getLink :: LlvmVar -> LlvmLinkageType
-getLink (LMGlobalVar _ _ l) = l
-getLink _ = ExternallyVisible
+getLink (LMGlobalVar _ _ l _ _ _) = l
+getLink _ = Internal
-- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid'
-- cannot be lifted.
pLift (LMVoid) = error "Voids are unliftable"
pLift x = LMPointer x
+-- | Lower a variable of 'LMPointer' type.
+pVarLift :: LlvmVar -> LlvmVar
+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.
pLower :: LlvmType -> LlvmType
-- | Lower a variable of 'LMPointer' type.
pVarLower :: LlvmVar -> LlvmVar
-pVarLower (LMGlobalVar s t l) = LMGlobalVar s (pLower t) l
-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
-- | 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
-llvmWidthInBits (LMInt n) = n
-llvmWidthInBits (LMFloat) = 32
-llvmWidthInBits (LMDouble) = 64
-llvmWidthInBits (LMFloat80) = 80
-llvmWidthInBits (LMFloat128) = 128
+llvmWidthInBits (LMInt n) = n
+llvmWidthInBits (LMFloat) = 32
+llvmWidthInBits (LMDouble) = 64
+llvmWidthInBits (LMFloat80) = 80
+llvmWidthInBits (LMFloat128) = 128
-- Could return either a pointer width here or the width of what
-- it points to. We will go with the former for now.
-llvmWidthInBits (LMPointer _) = llvmWidthInBits llvmWord
-llvmWidthInBits (LMArray _ _) = llvmWidthInBits llvmWord
-llvmWidthInBits LMLabel = 0
-llvmWidthInBits LMVoid = 0
-llvmWidthInBits (LMStruct tys) = sum $ map llvmWidthInBits tys
-llvmWidthInBits (LMFunction _) = 0
-llvmWidthInBits (LMAlias _ t) = llvmWidthInBits t
+llvmWidthInBits (LMPointer _) = llvmWidthInBits llvmWord
+llvmWidthInBits (LMArray _ _) = llvmWidthInBits llvmWord
+llvmWidthInBits LMLabel = 0
+llvmWidthInBits LMVoid = 0
+llvmWidthInBits (LMStruct tys) = sum $ map llvmWidthInBits tys
+llvmWidthInBits (LMFunction _) = 0
+llvmWidthInBits (LMAlias _ t) = llvmWidthInBits t
-- -----------------------------------------------------------------------------
-- ** Shortcut for Common Types
--
-i128, i64, i32, i16, i8, i1 :: LlvmType
-i128 = LMInt 128
-i64 = LMInt 64
-i32 = LMInt 32
-i16 = LMInt 16
-i8 = LMInt 8
-i1 = LMInt 1
+i128, i64, i32, i16, i8, i1, i8Ptr :: LlvmType
+i128 = LMInt 128
+i64 = LMInt 64
+i32 = LMInt 32
+i16 = LMInt 16
+i8 = LMInt 8
+i1 = LMInt 1
+i8Ptr = pLift i8
-- | The target architectures word size
-llvmWord :: LlvmType
-llvmWord = LMInt (wORD_SIZE * 8)
-
--- | The target architectures pointer size
-llvmWordPtr :: LlvmType
+llvmWord, llvmWordPtr :: LlvmType
+llvmWord = LMInt (wORD_SIZE * 8)
llvmWordPtr = pLift llvmWord
-
-- -----------------------------------------------------------------------------
-- * LLVM Function Types
--
-- | 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
}
+ deriving (Eq)
instance Show LlvmFunctionDecl where
- show (LlvmFunctionDecl n l c r VarArgs p)
- = (show l) ++ " " ++ (show c) ++ " " ++ (show r)
- ++ " @" ++ unpackFS n ++ "(" ++ (either commaCat commaCat p) ++ ", ...)"
- show (LlvmFunctionDecl n l c r FixedArgs p)
- = (show l) ++ " " ++ (show c) ++ " " ++ (show r)
- ++ " @" ++ unpackFS n ++ "(" ++ (either commaCat commaCat p) ++ ")"
-
-instance Eq LlvmFunctionDecl where
- (LlvmFunctionDecl n1 l1 c1 r1 v1 p1) == (LlvmFunctionDecl n2 l2 c2 r2 v2 p2)
- = (n1 == n2) && (l1 == l2) && (c1 == c2) && (r1 == r2)
- && (v1 == v2) && (p1 == p2)
+ show (LlvmFunctionDecl n l c r varg p a)
+ = 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 ++
+ "(" ++ 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.
--
deriving (Eq)
instance Show LlvmFuncAttr where
- show AlwaysInline = "alwaysinline"
- show InlineHint = "inlinehint"
- show NoInline = "noinline"
- show OptSize = "optsize"
- show NoReturn = "noreturn"
- show NoUnwind = "nounwind"
- show ReadNone = "readnon"
- show ReadOnly = "readonly"
- show Ssp = "ssp"
- show SspReq = "ssqreq"
- show NoRedZone = "noredzone"
- show NoImplicitFloat = "noimplicitfloat"
- show Naked = "naked"
+ show AlwaysInline = "alwaysinline"
+ show InlineHint = "inlinehint"
+ show NoInline = "noinline"
+ show OptSize = "optsize"
+ show NoReturn = "noreturn"
+ show NoUnwind = "nounwind"
+ show ReadNone = "readnon"
+ show ReadOnly = "readonly"
+ show Ssp = "ssp"
+ show SspReq = "ssqreq"
+ show NoRedZone = "noredzone"
+ show NoImplicitFloat = "noimplicitfloat"
+ show Naked = "naked"
-- | Different types to call a function.
show CC_Ccc = "ccc"
show CC_Fastcc = "fastcc"
show CC_Coldcc = "coldcc"
- show (CC_Ncc i) = "cc " ++ (show i)
+ show (CC_Ncc i) = "cc " ++ show i
show CC_X86_Stdcc = "x86_stdcallcc"
| 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
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"
-- * 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
+dToStr d
+ = let bs = doubleToBytes d
hex d' = case showHex d' "" of
[] -> error "dToStr: too few hex digits for float"
[x] -> ['0',x]
[x,y] -> [x,y]
_ -> error "dToStr: too many hex digits for float"
- str' = concat . fixEndian . (map hex) $ bs
- str = map toUpper str'
+ 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
projects / ghc-hetmet.git / blobdiff