diff options
| -rw-r--r-- | compiler/ghc.mk | 10 | ||||
| -rw-r--r-- | compiler/llvmGen/Llvm.hs | 8 | ||||
| -rw-r--r-- | compiler/llvmGen/Llvm/AbsSyn.hs | 9 | ||||
| -rw-r--r-- | compiler/llvmGen/Llvm/PpLlvm.hs | 128 | ||||
| -rw-r--r-- | compiler/llvmGen/Llvm/Types.hs | 183 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen.hs | 44 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Base.hs | 29 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 40 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Data.hs | 5 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Ppr.hs | 87 | ||||
| -rw-r--r-- | compiler/main/CodeOutput.lhs | 16 |
11 files changed, 296 insertions, 263 deletions
diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 7153dfe1ad..2daf6832f0 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -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? diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index 7a322bd86f..8291d9868f 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -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, diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index 1b8527b31f..9c255ab7df 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -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] diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 8d36511a47..8068247761 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -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) diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index a4080c4d5c..9275c07556 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -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) - ++ " @" ++ 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] @@ -432,19 +438,19 @@ data LlvmFuncAttr 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. @@ -493,7 +499,7 @@ instance Show LlvmCallConvention where 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" @@ -695,16 +701,15 @@ fToStr f = dToStr $ realToFrac f -- | 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 diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index e0485e703c..c4848c90b1 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -6,11 +6,14 @@ module LlvmCodeGen ( llvmCodeGen ) where #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 @@ -18,9 +21,11 @@ import PprCmm import BufWrite import DynFlags import ErrUtils +import FastString import Outputable import qualified Pretty as Prt import UniqSupply +import Util import System.IO @@ -30,21 +35,19 @@ 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. @@ -62,12 +65,13 @@ cmmDataLlvmGens dflags h cmm = 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 [] @@ -105,18 +109,30 @@ cmmProcLlvmGens -> 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. @@ -141,7 +157,7 @@ cmmLlvmGen dflags us env 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) diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 36ffa18d63..003c044db8 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -13,10 +13,10 @@ module LlvmCodeGen.Base ( 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 @@ -52,7 +52,7 @@ type LlvmData = ([LMGlobal], [LlvmType]) -- -- 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 -- ---------------------------------------------------------------------------- @@ -85,14 +85,22 @@ llvmFunTy :: LlvmType 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] @@ -144,14 +152,13 @@ strCLabel_llvm l = (fsLit . show . llvmSDoc . pprCLabel) l -- | 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) -- ---------------------------------------------------------------------------- diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index fb29f7acec..075a73138d 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -122,8 +122,6 @@ stmtToInstrs env stmt = case stmt of 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 @@ -154,17 +152,11 @@ genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -- 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])]] @@ -183,14 +175,14 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do 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) ++ "." @@ -226,8 +218,8 @@ genCall env target res args ret = do 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, []) @@ -246,12 +238,14 @@ genCall env target res args ret = do 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, []) @@ -260,6 +254,7 @@ genCall env target res args ret = do -- 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]) @@ -339,7 +334,7 @@ arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops) 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) @@ -829,7 +824,8 @@ genLit env cmm@(CmmLabel l) -- 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, []) @@ -901,17 +897,19 @@ getHsFunc env lbl 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]) diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index a5b82aadf2..69cd0e7c2b 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -71,7 +71,7 @@ resolveLlvmData _ env (lbl, alias, unres) = 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])) @@ -114,7 +114,8 @@ resData env (Left cmm@(CmmLabel l)) = -- 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]) diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index bccc336093..cdf968afb3 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -16,8 +16,10 @@ import CLabel import Cmm import DynFlags +import FastString import Pretty import Unique +import Util -- ---------------------------------------------------------------------------- -- * Top level @@ -25,22 +27,22 @@ import Unique -- | 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 @@ -49,43 +51,68 @@ moduleLayout = #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 ++ " #") diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 40f4f11a81..bc2dd1eafc 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -11,11 +11,9 @@ module CodeOutput( codeOutput, outputForeignStubs ) where #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 ) @@ -179,19 +177,9 @@ outputAsm _ _ _ \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} |