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 $@ ... "
@echo "cGhcWithNativeCodeGen :: String" >> $@
@echo "cGhcWithNativeCodeGen = \"$(GhcWithNativeCodeGen)\"" >> $@
@echo "cGhcWithLlvmCodeGen :: String" >> $@
- @echo "cGhcWithLlvmCodeGen = \"$(GhcWithLlvmCodeGen)\"" >> $@
+ @echo "cGhcWithLlvmCodeGen = \"YES\"" >> $@
@echo "cGhcWithSMP :: String" >> $@
@echo "cGhcWithSMP = \"$(GhcWithSMP)\"" >> $@
@echo "cGhcRTSWays :: String" >> $@
# 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?
-- * 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,
-- | 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]
ppLlvmFunctionDecl,
ppLlvmFunctions,
ppLlvmFunction,
+
+ -- * Utility functions
llvmSDoc
) where
import Data.List ( intersperse )
import Pretty
-import qualified Outputable as Outp
+import qualified Outputable as Out
import Unique
--------------------------------------------------------------------------------
-- | 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
-- | 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
-- | 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.
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
-- | 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
-- 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.
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.
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 "
++ "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)
| 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)
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)
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
-- 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 ++ ")"
-- | 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
-- | 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) = 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
-- | 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
-- | 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
--
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)
- ++ " @" ++ 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 varg' = if varg == VarArgs then ", ..." else ""
+ 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
type LlvmFunctionDecls = [LlvmFunctionDecl]
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"
-- | Convert a Haskell Double to an LLVM hex encoded floating point form
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
#include "HsVersions.h"
+import Llvm
+
import LlvmCodeGen.Base
import LlvmCodeGen.CodeGen
import LlvmCodeGen.Data
import LlvmCodeGen.Ppr
+import CLabel
import Cmm
import CgUtils ( fixStgRegisters )
import PprCmm
import BufWrite
import DynFlags
import ErrUtils
+import FastString
import Outputable
import qualified Pretty as Prt
import UniqSupply
+import Util
import System.IO
llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
llvmCodeGen dflags h us cmms
= do
- let cmm = concat $ map extractRawCmm cmms
+ let cmm = concat $ map (\(Cmm top) -> top) cmms
bufh <- newBufHandle h
Prt.bufLeftRender bufh $ pprLlvmHeader
env <- cmmDataLlvmGens dflags bufh cmm
- cmmProcLlvmGens dflags bufh us env cmm
+ cmmProcLlvmGens dflags bufh us env cmm 1 []
bFlush bufh
return ()
- where extractRawCmm (Cmm tops) = tops
-
-- -----------------------------------------------------------------------------
-- | Do llvm code generation on all these cmms data sections.
let exData (CmmData s d) = [(s,d)]
exData _ = []
- exProclbl (CmmProc _ l _ _) = [(strCLabel_llvm l)]
- exProclbl _ = []
+ exProclbl (CmmProc i l _ _)
+ | not (null i) = [strCLabel_llvm $ entryLblToInfoLbl l]
+ exProclbl (CmmProc _ l _ _) | otherwise = [strCLabel_llvm l]
+ exProclbl _ = []
- cdata = concat $ map exData cmm
- -- put the functions into the enviornment
cproc = concat $ map exProclbl cmm
+ cdata = concat $ map exData cmm
env = foldl (\e l -> funInsert l llvmFunTy e) initLlvmEnv cproc
in cmmDataLlvmGens' dflags h env cdata []
-> UniqSupply
-> LlvmEnv
-> [RawCmmTop]
+ -> Int -- ^ count, used for generating unique subsections
+ -> [LlvmVar] -- ^ info tables that need to be marked as 'used'
-> IO ()
-cmmProcLlvmGens _ _ _ _ []
- = return ()
+cmmProcLlvmGens _ _ _ _ [] _ []
+ = return ()
-cmmProcLlvmGens dflags h us env (cmm : cmms)
+cmmProcLlvmGens dflags h _ _ [] _ ivars
+ = do
+ let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
+ let ty = (LMArray (length ivars) i8Ptr)
+ let usedArray = LMStaticArray (map cast ivars) ty
+ let lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
+ (Just $ fsLit "llvm.metadata") Nothing, Just usedArray)
+ Prt.bufLeftRender h $ pprLlvmData dflags ([lmUsed], [])
+
+cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars
= do
(us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
- Prt.bufLeftRender h $ Prt.vcat $ map (pprLlvmCmmTop dflags) llvm
+ let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop dflags env' count) llvm
+ Prt.bufLeftRender h $ Prt.vcat docs
- cmmProcLlvmGens dflags h us' env' cmms
+ cmmProcLlvmGens dflags h us' env' cmms (count + 2) (concat ivar ++ ivars)
-- | Complete llvm code generation phase for a single top-level chunk of Cmm.
let ((env', llvmBC), usGen) = initUs us $ genLlvmCode dflags env fixed_cmm
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
- (vcat $ map (docToSDoc . pprLlvmCmmTop dflags) llvmBC)
+ (vcat $ map (docToSDoc . fst . pprLlvmCmmTop dflags env' 0) llvmBC)
return (usGen, env', llvmBC)
funLookup, funInsert,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
- llvmFunSig, llvmStdFunAttrs, llvmPtrBits, llvmGhcCC,
+ llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
+ llvmPtrBits, llvmGhcCC,
- strCLabel_llvm,
- genCmmLabelRef, genStringLabelRef
+ strCLabel_llvm, genCmmLabelRef, genStringLabelRef
) where
--
-- Labels are unresolved when we haven't yet determined if they are defined in
-- the module we are currently compiling, or an external one.
-type UnresLabel = CmmLit
+type UnresLabel = CmmLit
type UnresStatic = Either UnresLabel LlvmStatic
-- ----------------------------------------------------------------------------
llvmFunTy
= LMFunction $
LlvmFunctionDecl (fsLit "a") ExternallyVisible llvmGhcCC LMVoid FixedArgs
- (Left $ map getVarType llvmFunArgs)
+ (Left $ map getVarType llvmFunArgs) llvmFunAlign
-- | Llvm Function signature
llvmFunSig :: CLabel -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig lbl link
= let n = strCLabel_llvm lbl
in LlvmFunctionDecl n link llvmGhcCC LMVoid FixedArgs
- (Right llvmFunArgs)
+ (Right llvmFunArgs) llvmFunAlign
+
+-- | Alignment to use for functions
+llvmFunAlign :: LMAlign
+llvmFunAlign = Just 4
+
+-- | Alignment to use for into tables
+llvmInfAlign :: LMAlign
+llvmInfAlign = Just 4
-- | A Function's arguments
llvmFunArgs :: [LlvmVar]
-- | Create an external definition for a 'CLabel' defined in another module.
genCmmLabelRef :: CLabel -> LMGlobal
-genCmmLabelRef cl =
- let mcl = strCLabel_llvm cl
- in (LMGlobalVar mcl (LMPointer (LMArray 0 llvmWord)) External, Nothing)
+genCmmLabelRef = genStringLabelRef . strCLabel_llvm
-- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
genStringLabelRef :: LMString -> LMGlobal
-genStringLabelRef cl =
- (LMGlobalVar cl (LMPointer (LMArray 0 llvmWord)) External, Nothing)
+genStringLabelRef cl
+ = let ty = LMPointer $ LMArray 0 llvmWord
+ in (LMGlobalVar cl ty External Nothing Nothing, Nothing)
-- ----------------------------------------------------------------------------
CmmNop -> return (env, nilOL, [])
CmmComment _ -> return (env, nilOL, []) -- nuke comments
--- CmmComment s -> return (env, unitOL $ Comment (lines $ unpackFS s),
--- [])
CmmAssign reg src -> genAssign env reg src
CmmStore addr src -> genStore env addr src
-- intrinsic function.
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])
+ let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
+ FixedArgs (Left [i1, i1, i1, i1, i1]) llvmFunAlign
let fty = LMFunction funSig
- let fv = LMGlobalVar fname fty (funcLinkage funSig)
+ let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing
let tops = case funLookup fname env of
Just _ -> []
Nothing -> [CmmData Data [([],[fty])]]
genCall env target res args ret = do
-- paramater types
- let arg_type (CmmHinted _ AddrHint) = pLift i8
+ let arg_type (CmmHinted _ AddrHint) = i8Ptr
-- cast pointers to i8*. Llvm equivalent of void*
arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType expr
-- ret type
let ret_type ([]) = LMVoid
- ret_type ([CmmHinted _ AddrHint]) = pLift i8
- ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg
+ ret_type ([CmmHinted _ AddrHint]) = i8Ptr
+ ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg
ret_type t = panic $ "genCall: Too many return values! Can only handle"
++ " 0 or 1, given " ++ show (length t) ++ "."
let ccTy = StdCall -- tail calls should be done through CmmJump
let retTy = ret_type res
let argTy = Left $ map arg_type args
- let funTy name = LMFunction $
- LlvmFunctionDecl name ExternallyVisible lmconv retTy FixedArgs argTy
+ let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible
+ lmconv retTy FixedArgs argTy llvmFunAlign
-- get paramter values
(env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
Just ty'@(LMFunction sig) -> do
-- Function in module in right form
let fun = LMGlobalVar name ty' (funcLinkage sig)
+ Nothing Nothing
return (env1, fun, nilOL, [])
Just _ -> do
-- label in module but not function pointer, convert
let fty@(LMFunction sig) = funTy name
let fun = LMGlobalVar name fty (funcLinkage sig)
+ Nothing Nothing
(v1, s1) <- doExpr (pLift fty)
$ Cast LM_Bitcast fun (pLift fty)
return (env1, v1, unitOL s1, [])
-- label not in module, create external reference
let fty@(LMFunction sig) = funTy name
let fun = LMGlobalVar name fty (funcLinkage sig)
+ Nothing Nothing
let top = CmmData Data [([],[fty])]
let env' = funInsert name fty env1
return (env', fun, nilOL, [top])
a -> panic $ "genCall: Can't cast llvmType to i8*! ("
++ show a ++ ")"
- (v2, s1) <- doExpr (pLift i8) $ Cast op v1 (pLift i8)
+ (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top')
arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
-- Referenced data exists in this module, retrieve type and make
-- pointer to it.
Just ty' -> do
- let var = LMGlobalVar label (LMPointer ty') ExternallyVisible
+ let var = LMGlobalVar label (LMPointer ty')
+ ExternallyVisible Nothing Nothing
(v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord
return (env, v1, unitOL s1, [])
in case ty of
Just ty'@(LMFunction sig) -> do
-- Function in module in right form
- let fun = LMGlobalVar fname ty' (funcLinkage sig)
+ let fun = LMGlobalVar fname ty' (funcLinkage sig) Nothing Nothing
return (env, fun, nilOL, [])
Just ty' -> do
-- label in module but not function pointer, convert
let fun = LMGlobalVar fname (pLift ty') ExternallyVisible
- (v1, s1) <- doExpr (pLift llvmFunTy) $ Cast LM_Bitcast fun (pLift llvmFunTy)
+ Nothing Nothing
+ (v1, s1) <- doExpr (pLift llvmFunTy) $
+ Cast LM_Bitcast fun (pLift llvmFunTy)
return (env, v1, unitOL s1, [])
Nothing -> do
-- label not in module, create external reference
let ty' = LMFunction $ llvmFunSig lbl ExternallyVisible
- let fun = LMGlobalVar fname ty' ExternallyVisible
+ let fun = LMGlobalVar fname ty' ExternallyVisible Nothing Nothing
let top = CmmData Data [([],[ty'])]
let env' = funInsert fname ty' env
return (env', fun, nilOL, [top])
label = strCLabel_llvm lbl
link = if (externallyVisibleCLabel lbl)
then ExternallyVisible else Internal
- glob = LMGlobalVar label alias link
+ glob = LMGlobalVar label alias link Nothing Nothing
in (env', (refs' ++ [(glob, struct)], [alias]))
-- Referenced data exists in this module, retrieve type and make
-- pointer to it.
Just ty' ->
- let var = LMGlobalVar label (LMPointer ty') ExternallyVisible
+ let var = LMGlobalVar label (LMPointer ty')
+ ExternallyVisible Nothing Nothing
ptr = LMStaticPointer var
in (env, LMPtoI ptr lmty, [Nothing])
import Cmm
import DynFlags
+import FastString
import Pretty
import Unique
+import Util
-- ----------------------------------------------------------------------------
-- * Top level
-- | LLVM module layout description for the host target
moduleLayout :: Doc
-moduleLayout =
+moduleLayout =
#ifdef i386_TARGET_ARCH
#ifdef darwin_TARGET_OS
- (text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128\"")
- $+$ (text "target triple = \"i386-apple-darwin9.8\"")
+ text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128\""
+ $+$ text "target triple = \"i386-apple-darwin9.8\""
#else
- (text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32\"")
- $+$ (text "target triple = \"i386-linux-gnu\"")
+ text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32\""
+ $+$ text "target triple = \"i386-linux-gnu\""
#endif
#else
-#ifdef x86_64_TARGET_ARCH
- (text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128\"")
- $+$ (text "target triple = \"x86_64-linux-gnu\"")
+#ifdef x86_64_TARGET_ARCH
+ text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128\""
+ $+$ text "target triple = \"x86_64-linux-gnu\""
#else /* Not i386 */
-- FIX: Other targets
#endif
+
-- | Header code for LLVM modules
pprLlvmHeader :: Doc
pprLlvmHeader = moduleLayout
+
-- | Pretty print LLVM code
-pprLlvmCmmTop :: DynFlags -> LlvmCmmTop -> Doc
-pprLlvmCmmTop dflags (CmmData _ lmdata)
- = vcat $ map (pprLlvmData dflags) lmdata
-
-pprLlvmCmmTop dflags (CmmProc info lbl _ (ListGraph blocks))
- = (
- let static = CmmDataLabel (entryLblToInfoLbl lbl) : info
- in if not (null info)
- then pprCmmStatic dflags static
- else empty
- ) $+$ (
- let link = if (externallyVisibleCLabel lbl)
- then ExternallyVisible else Internal
- funDec = llvmFunSig lbl link
- lmblocks = map (\(BasicBlock id stmts) -> LlvmBlock (getUnique id) stmts) blocks
- fun = LlvmFunction funDec [NoUnwind] lmblocks
+pprLlvmCmmTop :: DynFlags -> LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar])
+pprLlvmCmmTop dflags _ _ (CmmData _ lmdata)
+ = (vcat $ map (pprLlvmData dflags) lmdata, [])
+
+pprLlvmCmmTop dflags env count (CmmProc info lbl _ (ListGraph blks))
+ = let static = CmmDataLabel lbl : info
+ (idoc, ivar) = if not (null info)
+ then pprCmmStatic dflags env count static
+ else (empty, [])
+ in (idoc $+$ (
+ let sec = mkLayoutSection (count + 1)
+ (lbl',sec') = if not (null info)
+ then (entryLblToInfoLbl lbl, sec)
+ else (lbl, Nothing)
+ 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
in ppLlvmFunction fun
- )
+ ), ivar)
-- | Pretty print LLVM data code
pprLlvmData :: DynFlags -> LlvmData -> Doc
-pprLlvmData _ (globals, types ) =
+pprLlvmData _ (globals, types) =
let globals' = ppLlvmGlobals globals
types' = ppLlvmTypes types
in types' $+$ globals'
-- | Pretty print CmmStatic
-pprCmmStatic :: DynFlags -> [CmmStatic] -> Doc
-pprCmmStatic dflags stat
+pprCmmStatic :: DynFlags -> LlvmEnv -> Int -> [CmmStatic] -> (Doc, [LlvmVar])
+pprCmmStatic dflags env count stat
= let unres = genLlvmData dflags (Data,stat)
- (_, ldata) = resolveLlvmData dflags initLlvmEnv unres
- in pprLlvmData dflags ldata
+ (_, (ldata, ltypes)) = resolveLlvmData dflags env unres
+
+ setSection (gv@(LMGlobalVar s ty l _ _), d)
+ = let v = if l == Internal then [gv] else []
+ sec = mkLayoutSection count
+ in ((LMGlobalVar s ty l sec llvmInfAlign, d), v)
+ setSection v = (v,[])
+
+ (ldata', llvmUsed) = mapAndUnzip setSection ldata
+ in (pprLlvmData dflags (ldata', ltypes), concat llvmUsed)
+
+
+-- | Create an appropriate section declaration for subsection <n> of text
+-- WARNING: This technique could fail as gas documentation says it only
+-- supports up to 8192 subsections per section. Inspection of the source
+-- code and some test programs seem to suggest it supports more than this
+-- so we are hoping it does.
+mkLayoutSection :: Int -> LMSection
+mkLayoutSection n
+ = Just (fsLit $ ".text;.text " ++ show n ++ " #")
#ifndef OMIT_NATIVE_CODEGEN
import AsmCodeGen ( nativeCodeGen )
#endif
+import LlvmCodeGen ( llvmCodeGen )
import UniqSupply ( mkSplitUniqSupply )
-#ifndef GHCI_TABLES_NEXT_TO_CODE
-import qualified LlvmCodeGen ( llvmCodeGen )
-#endif
#ifdef JAVA
import JavaGen ( javaGen )
\begin{code}
outputLlvm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
-
-#ifndef GHCI_TABLES_NEXT_TO_CODE
outputLlvm dflags filenm flat_absC
= do ncg_uniqs <- mkSplitUniqSupply 'n'
- doOutput filenm $ \f ->
- LlvmCodeGen.llvmCodeGen dflags f ncg_uniqs flat_absC
-#else
-outputLlvm _ _ _
- = pprPanic "This compiler was built with the LLVM backend disabled"
- (text ("This is because the TABLES_NEXT_TO_CODE optimisation is"
- ++ " enabled, which the LLVM backend doesn't support right now.")
- $+$ text "Use -fasm instead")
-#endif
+ doOutput filenm $ \f -> llvmCodeGen dflags f ncg_uniqs flat_absC
\end{code}
projects / ghc-hetmet.git / commitdiff