Commit 24a3fee9 authored by dterei's avatar dterei
Browse files

Add support of TNTC to llvm backend

We do this through a gnu as feature called subsections,
where you can put data/code into a numbered subsection
and those subsections will be joined together in descending
order by gas at compile time.
parent 1d8585bc
......@@ -43,12 +43,6 @@ compiler/stage2/package-data.mk : $(compiler_CONFIG_HS)
compiler/stage3/package-data.mk : $(compiler_CONFIG_HS)
endif
ifeq "$(GhcEnableTablesNextToCode)" "NO"
GhcWithLlvmCodeGen = YES
else
GhcWithLlvmCodeGen = NO
endif
$(compiler_CONFIG_HS) : mk/config.mk mk/project.mk
"$(RM)" $(RM_OPTS) $@
@echo "Creating $@ ... "
......@@ -74,7 +68,7 @@ $(compiler_CONFIG_HS) : mk/config.mk mk/project.mk
@echo "cGhcWithNativeCodeGen :: String" >> $@
@echo "cGhcWithNativeCodeGen = \"$(GhcWithNativeCodeGen)\"" >> $@
@echo "cGhcWithLlvmCodeGen :: String" >> $@
@echo "cGhcWithLlvmCodeGen = \"$(GhcWithLlvmCodeGen)\"" >> $@
@echo "cGhcWithLlvmCodeGen = \"YES\"" >> $@
@echo "cGhcWithSMP :: String" >> $@
@echo "cGhcWithSMP = \"$(GhcWithSMP)\"" >> $@
@echo "cGhcRTSWays :: String" >> $@
......@@ -321,7 +315,7 @@ ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO"
# or not?
# XXX This should logically be a CPP option, but there doesn't seem to
# be a flag for that
compiler_CONFIGURE_OPTS += --ghc-option=-DGHCI_TABLES_NEXT_TO_CODE
compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DGHCI_TABLES_NEXT_TO_CODE
endif
# Should the debugger commands be enabled?
......
......@@ -28,15 +28,15 @@ module Llvm (
-- * Variables and Type System
LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..),
LMGlobal, LMString, LMConstant,
LMGlobal, LMString, LMConstant, LMSection, LMAlign,
-- ** Some basic types
i64, i32, i16, i8, i1, llvmWord, llvmWordPtr,
i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
-- ** Operations on the type system.
isGlobal, getLitType, getLit, getName, getPlainName, getVarType,
getStatType, getGlobalVar, getGlobalType, pVarLower, pLift, pLower,
isInt, isFloat, isPointer, llvmWidthInBits,
getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower,
pLift, pLower, isInt, isFloat, isPointer, llvmWidthInBits,
-- * Pretty Printing
ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmConstants,
......
......@@ -44,13 +44,16 @@ data LlvmModule = LlvmModule {
-- | An LLVM Function
data LlvmFunction = LlvmFunction {
-- | The signature of this declared function.
funcDecl :: LlvmFunctionDecl,
funcDecl :: LlvmFunctionDecl,
-- | The function attributes.
funcAttrs :: [LlvmFuncAttr],
funcAttrs :: [LlvmFuncAttr],
-- | The section to put the function into,
funcSect :: LMSection,
-- | The body of the functions.
funcBody :: LlvmBlocks
funcBody :: LlvmBlocks
}
type LlvmFunctions = [LlvmFunction]
......
......@@ -18,6 +18,8 @@ module Llvm.PpLlvm (
ppLlvmFunctionDecl,
ppLlvmFunctions,
ppLlvmFunction,
-- * Utility functions
llvmSDoc
) where
......@@ -29,7 +31,7 @@ import Llvm.Types
import Data.List ( intersperse )
import Pretty
import qualified Outputable as Outp
import qualified Outputable as Out
import Unique
--------------------------------------------------------------------------------
......@@ -54,7 +56,7 @@ ppLlvmComments comments = vcat $ map ppLlvmComment comments
-- | Print out a comment, can be inside a function or on its own
ppLlvmComment :: LMString -> Doc
ppLlvmComment com = semi <+> (ftext com)
ppLlvmComment com = semi <+> ftext com
-- | Print out a list of global mutable variable definitions
......@@ -63,14 +65,25 @@ ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
-- | Print out a global mutable variable definition
ppLlvmGlobal :: LMGlobal -> Doc
ppLlvmGlobal (var@(LMGlobalVar _ _ link), Nothing) =
ppAssignment var $ text (show link) <+> text "global" <+>
(text $ show (pLower $ getVarType var))
ppLlvmGlobal = ppLlvmGlobal' (text "global")
ppLlvmGlobal' :: Doc -> LMGlobal -> Doc
ppLlvmGlobal' vty (var@(LMGlobalVar _ _ link x a), cont) =
let sect = case x of
Just x' -> text ", section" <+> doubleQuotes (ftext x')
Nothing -> empty
align = case a of
Just a' -> text ", align" <+> int a'
Nothing -> empty
rhs = case cont of
Just stat -> texts stat
Nothing -> texts (pLower $ getVarType var)
ppLlvmGlobal (var@(LMGlobalVar _ _ link), (Just stat)) =
ppAssignment var $ text (show link) <+> text "global" <+> text (show stat)
in ppAssignment var $ texts link <+> vty <+> rhs <> sect <> align
ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
ppLlvmGlobal' _ oth = error $ "Non Global var ppr as global! " ++ show oth
-- | Print out a list global constant variable
......@@ -79,10 +92,7 @@ ppLlvmConstants cons = vcat $ map ppLlvmConstant cons
-- | Print out a global constant variable
ppLlvmConstant :: LMConstant -> Doc
ppLlvmConstant (dst@(LMGlobalVar _ _ link), src) =
ppAssignment dst $ text (show link) <+> text "constant" <+> text (show src)
ppLlvmConstant c = error $ "Non global var as constant! " ++ show c
ppLlvmConstant (v,s) = ppLlvmGlobal' (text "constant") (v, Just s)
-- | Print out a list of LLVM type aliases.
......@@ -93,7 +103,7 @@ ppLlvmTypes tys = vcat $ map ppLlvmType tys
ppLlvmType :: LlvmType -> Doc
ppLlvmType al@(LMAlias _ t)
= (text $ show al) <+> equals <+> (text "type") <+> (text $ show t)
= texts al <+> equals <+> text "type" <+> texts t
ppLlvmType (LMFunction t)
= ppLlvmFunctionDecl t
......@@ -107,10 +117,13 @@ ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
-- | Print out a function definition.
ppLlvmFunction :: LlvmFunction -> Doc
ppLlvmFunction (LlvmFunction dec attrs body) =
ppLlvmFunction (LlvmFunction dec attrs sec body) =
let attrDoc = ppSpaceJoin attrs
in (text "define") <+> (ppLlvmFuncDecSig dec)
<+> attrDoc
secDoc = case sec of
Just s' -> text "section " <+> (doubleQuotes $ ftext s')
Nothing -> empty
in text "define" <+> texts dec
<+> attrDoc <+> secDoc
$+$ lbrace
$+$ ppLlvmBlocks body
$+$ rbrace
......@@ -124,22 +137,7 @@ ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
-- Declarations define the function type but don't define the actual body of
-- the function.
ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc
ppLlvmFunctionDecl dec = (text "declare") <+> ppLlvmFuncDecSig dec
-- | Print out a functions type signature.
-- This differs from [ppLlvmFunctionDecl] in that it is used for both function
-- declarations and defined functions to print out the type.
ppLlvmFuncDecSig :: LlvmFunctionDecl -> Doc
ppLlvmFuncDecSig (LlvmFunctionDecl name link cc retTy argTy params)
= let linkTxt = show link
linkDoc | linkTxt == "" = empty
| otherwise = (text linkTxt) <> space
ppParams = either ppCommaJoin ppCommaJoin params <>
(case argTy of
VarArgs -> (text ", ...")
FixedArgs -> empty)
in linkDoc <> (text $ show cc) <+> (text $ show retTy)
<+> atsym <> (ftext name) <> lparen <+> ppParams <+> rparen
ppLlvmFunctionDecl dec = text "declare" <+> texts dec
-- | Print out a list of LLVM blocks.
......@@ -151,7 +149,7 @@ ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
ppLlvmBlock :: LlvmBlock -> Doc
ppLlvmBlock (LlvmBlock blockId stmts)
= ppLlvmStatement (MkLabel blockId)
$+$ nest 4 (vcat $ map ppLlvmStatement stmts)
$+$ nest 4 (vcat $ map ppLlvmStatement stmts)
-- | Print out an LLVM statement.
......@@ -198,7 +196,7 @@ ppCall ct fptr vals attrs = case fptr of
LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
-- should be function type otherwise
LMGlobalVar _ (LMFunction d) _ -> ppCall' d
LMGlobalVar _ (LMFunction d) _ _ _ -> ppCall' d
-- not pointer or function, so error
_other -> error $ "ppCall called with non LMFunction type!\nMust be "
......@@ -206,23 +204,23 @@ ppCall ct fptr vals attrs = case fptr of
++ "local var of pointer function type."
where
ppCall' (LlvmFunctionDecl _ _ cc ret argTy params) =
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 <>
(case argTy of
VarArgs -> (text ", ...")
VarArgs -> text ", ..."
FixedArgs -> empty)
fnty = space <> lparen <> ppArgTy <> rparen <> (text "*")
fnty = space <> lparen <> ppArgTy <> rparen <> text "*"
attrDoc = ppSpaceJoin attrs
in tc <> (text "call") <+> (text $ show cc) <+> (text $ show ret)
in tc <> text "call" <+> texts cc <+> texts ret
<> fnty <+> (text $ getName fptr) <> lparen <+> ppValues
<+> rparen <+> attrDoc
ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> Doc
ppMachOp op left right =
(text $ show op) <+> (text $ show (getVarType left)) <+> (text $ getName left)
(texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
<> comma <+> (text $ getName right)
......@@ -234,7 +232,7 @@ ppCmpOp op left right =
| otherwise = error ("can't compare different types, left = "
++ (show $ getVarType left) ++ ", right = "
++ (show $ getVarType right))
in cmpOp <+> (text $ show op) <+> (text $ show (getVarType left))
in cmpOp <+> texts op <+> texts (getVarType left)
<+> (text $ getName left) <> comma <+> (text $ getName right)
......@@ -243,83 +241,79 @@ ppAssignment var expr = (text $ getName var) <+> equals <+> expr
ppLoad :: LlvmVar -> Doc
ppLoad var = (text "load") <+> (text $ show var)
ppLoad var = text "load" <+> texts var
ppStore :: LlvmVar -> LlvmVar -> Doc
ppStore val dst =
(text "store") <+> (text $ show val) <> comma <+> (text $ show dst)
ppStore val dst = text "store" <+> texts val <> comma <+> texts dst
ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc
ppCast op from to =
let castOp = text $ show op
in castOp <+> (text $ show from) <+> (text "to") <+> (text $ show to)
ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
ppMalloc :: LlvmType -> Int -> Doc
ppMalloc tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in (text "malloc") <+> (text $ show tp) <> comma <+> (text $ show amount')
in text "malloc" <+> texts tp <> comma <+> texts amount'
ppAlloca :: LlvmType -> Int -> Doc
ppAlloca tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in (text "alloca") <+> (text $ show tp) <> comma <+> (text $ show amount')
in text "alloca" <+> texts tp <> comma <+> texts amount'
ppGetElementPtr :: LlvmVar -> [Int] -> Doc
ppGetElementPtr ptr idx =
let indexes = hcat $ map ((comma <+> (text $ show i32) <+>) . text . show) idx
in (text "getelementptr") <+> (text $ show ptr) <> indexes
let indexes = hcat $ map ((comma <+> texts i32 <+>) . texts) idx
in text "getelementptr" <+> texts ptr <> indexes
ppReturn :: Maybe LlvmVar -> Doc
ppReturn (Just var) = (text "ret") <+> (text $ show var)
ppReturn Nothing = (text "ret") <+> (text $ show LMVoid)
ppReturn (Just var) = text "ret" <+> texts var
ppReturn Nothing = text "ret" <+> texts LMVoid
ppBranch :: LlvmVar -> Doc
ppBranch var = (text "br") <+> (text $ show var)
ppBranch var = text "br" <+> texts var
ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> Doc
ppBranchIf cond trueT falseT
= (text "br") <+> (text $ show cond) <> comma <+> (text $ show trueT) <> comma
<+> (text $ show falseT)
= text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT
ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> Doc
ppPhi tp preds =
let ppPreds (val, label) = brackets $ (text $ getName val) <> comma
<+> (text $ getName label)
in (text "phi") <+> (text $ show tp)
<+> (hcat $ intersperse comma (map ppPreds preds))
in text "phi" <+> texts tp <+> hcat (intersperse comma $ map ppPreds preds)
ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> Doc
ppSwitch scrut dflt targets =
let ppTarget (val, lab) = (text $ show val) <> comma <+> (text $ show lab)
let ppTarget (val, lab) = texts val <> comma <+> texts lab
ppTargets xs = brackets $ vcat (map ppTarget xs)
in (text "switch") <+> (text $ show scrut) <> comma <+> (text $ show dflt)
<+> (ppTargets targets)
in text "switch" <+> texts scrut <> comma <+> texts dflt
<+> ppTargets targets
--------------------------------------------------------------------------------
-- * Misc functions
--------------------------------------------------------------------------------
atsym :: Doc
atsym = text "@"
ppCommaJoin :: (Show a) => [a] -> Doc
ppCommaJoin strs = hcat $ intersperse comma (map (text . show) strs)
ppCommaJoin strs = hcat $ intersperse comma (map texts strs)
ppSpaceJoin :: (Show a) => [a] -> Doc
ppSpaceJoin strs = hcat $ intersperse space (map (text . show) strs)
ppSpaceJoin strs = hcat $ intersperse space (map texts strs)
-- | Convert SDoc to Doc
llvmSDoc :: Outp.SDoc -> Doc
llvmSDoc :: Out.SDoc -> Doc
llvmSDoc d
= Outp.withPprStyleDoc (Outp.mkCodeStyle Outp.CStyle) d
= Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d
-- | Showable to Doc
texts :: (Show a) => a -> Doc
texts = (text . show)
......@@ -59,18 +59,21 @@ 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 VarArgs p _))
= show r ++ " (" ++ (either commaCat commaCat p) ++ ", ...)"
show (LMFunction (LlvmFunctionDecl _ _ _ r FixedArgs p _))
= show r ++ " (" ++ (either commaCat commaCat p) ++ ")"
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
-- | Llvm Variables
data LlvmVar
-- | Variables with a global scope.
= LMGlobalVar LMString LlvmType LlvmLinkageType
= LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign
-- | Variables local to a function or parameters.
| LMLocalVar Unique LlvmType
-- | Named local variables. Sometimes we need to be able to explicitly name
......@@ -114,10 +117,10 @@ data LlvmStatic
-- 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
......@@ -128,23 +131,22 @@ instance Show LlvmStatic where
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 ++ ")"
......@@ -174,18 +176,18 @@ 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
......@@ -198,10 +200,10 @@ getLit l = error $ "getLit: Usupported LlvmLit type! " ++ show (getLitType l)
-- | 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
......@@ -216,6 +218,7 @@ getStatType (LMStaticStr _ t) = t
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
......@@ -231,8 +234,8 @@ getGlobalVar (v, _) = v
-- | 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.
......@@ -241,6 +244,13 @@ pLift (LMLabel) = error "Labels are unliftable"
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) = 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!"
-- | Remove the pointer indirection of the supplied type. Only 'LMPointer'
-- constructors can be lowered.
pLower :: LlvmType -> LlvmType
......@@ -249,10 +259,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) = 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) = 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!"
-- | Test if the given 'LlvmType' is an integer
isInt :: LlvmType -> Bool
......@@ -274,48 +284,45 @@ 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
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
--
......@@ -334,21 +341,20 @@ data LlvmFunctionDecl = LlvmFunctionDecl {
decVarargs :: LlvmParameterListType,
-- | Signature of the parameters, can be just types or full vars
-- if parameter names are required.
decParams :: Either [LlvmType] [LlvmVar]
decParams :: Either [LlvmType] [LlvmVar],
-- | 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)