diff options
33 files changed, 3402 insertions, 226 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index c48269ecf5..5c026227bf 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -181,6 +181,7 @@ data ClosureTypeInfo data CmmReturnInfo = CmmMayReturn | CmmNeverReturns + deriving ( Eq ) -- TODO: These types may need refinement data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index e01d8f5cba..69320a2f66 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -6,7 +6,7 @@ -- ----------------------------------------------------------------------------- -module CmmUtils( +module CmmUtils( CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList, isNopStmt, diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 901dd96502..ce689c42f7 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -122,9 +122,10 @@ emitForeignCall' safety results target args vols _srt ret | not (playSafe safety) = do temp_args <- load_args_into_temps args let (caller_save, caller_load) = callerSaveVolatileRegs vols + let caller_load' = if ret == CmmNeverReturns then [] else caller_load stmtsC caller_save stmtC (CmmCall target results temp_args CmmUnsafe ret) - stmtsC caller_load + stmtsC caller_load' | otherwise = do -- Both 'id' and 'new_base' are GCKindNonPtr because they're diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index f8b41a087a..d22fee1e75 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -26,6 +26,7 @@ module CgUtils ( tagToClosure, callerSaveVolatileRegs, get_GlobalReg_addr, + activeStgRegs, fixStgRegisters, cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, cmmUGtWord, @@ -423,33 +424,6 @@ callerSaveVolatileRegs vols = (caller_save, caller_load) : next | otherwise = next --- ----------------------------------------------------------------------------- --- Global registers - --- We map STG registers onto appropriate CmmExprs. Either they map --- to real machine registers or stored as offsets from BaseReg. Given --- a GlobalReg, get_GlobalReg_addr always produces the --- register table address for it. --- (See also get_GlobalReg_reg_or_addr in MachRegs) - -get_GlobalReg_addr :: GlobalReg -> CmmExpr -get_GlobalReg_addr BaseReg = regTableOffset 0 -get_GlobalReg_addr mid = get_Regtable_addr_from_offset - (globalRegType mid) (baseRegOffset mid) - --- Calculate a literal representing an offset into the register table. --- Used when we don't have an actual BaseReg to offset from. -regTableOffset n = - CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n)) - -get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr -get_Regtable_addr_from_offset rep offset = -#ifdef REG_Base - CmmRegOff (CmmGlobal BaseReg) offset -#else - regTableOffset offset -#endif - -- | Returns @True@ if this global register is stored in a caller-saves -- machine register. @@ -1010,3 +984,181 @@ clHasCafRefs (ClosureInfo {closureSRT = srt}) = case srt of NoC_SRT -> NoCafRefs _ -> MayHaveCafRefs clHasCafRefs (ConInfo {}) = NoCafRefs + +-- ----------------------------------------------------------------------------- +-- +-- STG/Cmm GlobalReg +-- +-- ----------------------------------------------------------------------------- + +-- | Here is where the STG register map is defined for each target arch. +-- The order matters (for the llvm backend anyway)! We must make sure to +-- maintain the order here with the order used in the LLVM calling conventions. +-- Note that also, this isn't all registers, just the ones that are currently +-- possbily mapped to real registers. +activeStgRegs :: [GlobalReg] +activeStgRegs = [ +#ifdef REG_Base + BaseReg +#endif +#ifdef REG_Sp + ,Sp +#endif +#ifdef REG_Hp + ,Hp +#endif +#ifdef REG_R1 + ,VanillaReg 1 VGcPtr +#endif +#ifdef REG_R2 + ,VanillaReg 2 VGcPtr +#endif +#ifdef REG_R3 + ,VanillaReg 3 VGcPtr +#endif +#ifdef REG_R4 + ,VanillaReg 4 VGcPtr +#endif +#ifdef REG_R5 + ,VanillaReg 5 VGcPtr +#endif +#ifdef REG_R6 + ,VanillaReg 6 VGcPtr +#endif +#ifdef REG_R7 + ,VanillaReg 7 VGcPtr +#endif +#ifdef REG_R8 + ,VanillaReg 8 VGcPtr +#endif +#ifdef REG_SpLim + ,SpLim +#endif +#ifdef REG_F1 + ,FloatReg 1 +#endif +#ifdef REG_F2 + ,FloatReg 2 +#endif +#ifdef REG_F3 + ,FloatReg 3 +#endif +#ifdef REG_F4 + ,FloatReg 4 +#endif +#ifdef REG_D1 + ,DoubleReg 1 +#endif +#ifdef REG_D2 + ,DoubleReg 2 +#endif + ] + +-- | We map STG registers onto appropriate CmmExprs. Either they map +-- to real machine registers or stored as offsets from BaseReg. Given +-- a GlobalReg, get_GlobalReg_addr always produces the +-- register table address for it. +get_GlobalReg_addr :: GlobalReg -> CmmExpr +get_GlobalReg_addr BaseReg = regTableOffset 0 +get_GlobalReg_addr mid = get_Regtable_addr_from_offset + (globalRegType mid) (baseRegOffset mid) + +-- Calculate a literal representing an offset into the register table. +-- Used when we don't have an actual BaseReg to offset from. +regTableOffset n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n)) + +get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr +get_Regtable_addr_from_offset rep offset = +#ifdef REG_Base + CmmRegOff (CmmGlobal BaseReg) offset +#else + regTableOffset offset +#endif + +-- | Fixup global registers so that they assign to locations within the +-- RegTable if they aren't pinned for the current target. +fixStgRegisters :: RawCmmTop -> RawCmmTop +fixStgRegisters top@(CmmData _ _) = top + +fixStgRegisters (CmmProc info lbl params (ListGraph blocks)) = + let blocks' = map fixStgRegBlock blocks + in CmmProc info lbl params $ ListGraph blocks' + +fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock +fixStgRegBlock (BasicBlock id stmts) = + let stmts' = map fixStgRegStmt stmts + in BasicBlock id stmts' + +fixStgRegStmt :: CmmStmt -> CmmStmt +fixStgRegStmt stmt + = case stmt of + CmmAssign (CmmGlobal reg) src -> + let src' = fixStgRegExpr src + baseAddr = get_GlobalReg_addr reg + in case reg `elem` activeStgRegs of + True -> CmmAssign (CmmGlobal reg) src' + False -> CmmStore baseAddr src' + + CmmAssign reg src -> + let src' = fixStgRegExpr src + in CmmAssign reg src' + + CmmStore addr src -> CmmStore (fixStgRegExpr addr) (fixStgRegExpr src) + + CmmCall target regs args srt returns -> + let target' = case target of + CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv + other -> other + args' = map (\(CmmHinted arg hint) -> + (CmmHinted (fixStgRegExpr arg) hint)) args + in CmmCall target' regs args' srt returns + + CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr test) dest + + CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids + + CmmJump addr regs -> CmmJump (fixStgRegExpr addr) regs + + -- CmmNop, CmmComment, CmmBranch, CmmReturn + _other -> stmt + + +fixStgRegExpr :: CmmExpr -> CmmExpr +fixStgRegExpr expr + = case expr of + CmmLoad addr ty -> CmmLoad (fixStgRegExpr addr) ty + + CmmMachOp mop args -> CmmMachOp mop args' + where args' = map fixStgRegExpr args + + CmmReg (CmmGlobal reg) -> + -- Replace register leaves with appropriate StixTrees for + -- the given target. MagicIds which map to a reg on this + -- arch are left unchanged. For the rest, BaseReg is taken + -- to mean the address of the reg table in MainCapability, + -- and for all others we generate an indirection to its + -- location in the register table. + case reg `elem` activeStgRegs of + True -> expr + False -> + let baseAddr = get_GlobalReg_addr reg + in case reg of + BaseReg -> fixStgRegExpr baseAddr + _other -> fixStgRegExpr + (CmmLoad baseAddr (globalRegType reg)) + + CmmRegOff (CmmGlobal reg) offset -> + -- RegOf leaves are just a shorthand form. If the reg maps + -- to a real reg, we keep the shorthand, otherwise, we just + -- expand it and defer to the above code. + case reg `elem` activeStgRegs of + True -> expr + False -> fixStgRegExpr (CmmMachOp (MO_Add wordWidth) [ + CmmReg (CmmGlobal reg), + CmmLit (CmmInt (fromIntegral offset) + wordWidth)]) + + -- CmmLit, CmmReg (CmmLocal), CmmStackSlot + _other -> expr + diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 448d27bead..479e56d22e 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -130,7 +130,9 @@ Library ghci hsSyn iface + llvmGen main + nativeGen parser prelude profiling @@ -153,6 +155,16 @@ Library Id IdInfo Literal + Llvm + Llvm.AbsSyn + Llvm.PpLlvm + Llvm.Types + LlvmCodeGen + LlvmCodeGen.Base + LlvmCodeGen.CodeGen + LlvmCodeGen.Data + LlvmCodeGen.Ppr + LlvmCodeGen.Regs MkId Module Name @@ -198,6 +210,7 @@ Library MkZipCfg MkZipCfgCmm OptimizationFuel + PprBase PprC PprCmm PprCmmZ @@ -447,10 +460,9 @@ Library VectUtils Vectorise + -- We only need to expose more modules as some of the ncg code is used + -- by the LLVM backend so its always included if flag(ncg) - hs-source-dirs: - nativeGen - Exposed-Modules: AsmCodeGen TargetReg @@ -459,7 +471,6 @@ Library Size Reg RegClass - PprBase PIC Platform Alpha.Regs diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 1c61494b18..9cbacf4bd4 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -43,6 +43,12 @@ 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 $@ ... " @@ -67,6 +73,8 @@ $(compiler_CONFIG_HS) : mk/config.mk mk/project.mk @echo "cGhcWithInterpreter = \"$(GhcWithInterpreter)\"" >> $@ @echo "cGhcWithNativeCodeGen :: String" >> $@ @echo "cGhcWithNativeCodeGen = \"$(GhcWithNativeCodeGen)\"" >> $@ + @echo "cGhcWithLlvmCodeGen :: String" >> $@ + @echo "cGhcWithLlvmCodeGen = \"$(GhcWithLlvmCodeGen)\"" >> $@ @echo "cGhcWithSMP :: String" >> $@ @echo "cGhcWithSMP = \"$(GhcWithSMP)\"" >> $@ @echo "cGhcRTSWays :: String" >> $@ @@ -313,7 +321,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_stage2_CONFIGURE_OPTS += --ghc-option=-DGHCI_TABLES_NEXT_TO_CODE +compiler_CONFIGURE_OPTS += --ghc-option=-DGHCI_TABLES_NEXT_TO_CODE endif # Should the debugger commands be enabled? @@ -338,6 +346,8 @@ ifeq "$(HOSTPLATFORM)" "ia64-unknown-linux" # needed for generating proper relocation in large binaries: trac #856 compiler_CONFIGURE_OPTS += --ld-option=-Wl,--relax endif +else +compiler_CONFIGURE_OPTS += --ghc-option=-DNO_REGS endif # We need to turn on profiling either if we have been asked to diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs new file mode 100644 index 0000000000..7a322bd86f --- /dev/null +++ b/compiler/llvmGen/Llvm.hs @@ -0,0 +1,52 @@ +-- ---------------------------------------------------------------------------- +-- | This module supplies bindings to generate Llvm IR from Haskell +-- (<http://www.llvm.org/docs/LangRef.html>). +-- +-- Note: this module is developed in a demand driven way. It is no complete +-- LLVM binding library in Haskell, but enough to generate code for GHC. +-- +-- This code is derived from code taken from the Essential Haskell Compiler +-- (EHC) project (<http://www.cs.uu.nl/wiki/Ehc/WebHome>). +-- + +module Llvm ( + + -- * Modules, Functions and Blocks + LlvmModule(..), + + LlvmFunction(..), LlvmFunctionDecl(..), + LlvmFunctions, LlvmFunctionDecls, + LlvmStatement(..), LlvmExpression(..), + LlvmBlocks, LlvmBlock(..), LlvmBlockId, + + -- * Call Handling + LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..), + LlvmLinkageType(..), LlvmFuncAttr(..), + + -- * Operations and Comparisons + LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..), + + -- * Variables and Type System + LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..), + LMGlobal, LMString, LMConstant, + + -- ** Some basic types + i64, i32, i16, i8, i1, llvmWord, llvmWordPtr, + + -- ** Operations on the type system. + isGlobal, getLitType, getLit, getName, getPlainName, getVarType, + getStatType, getGlobalVar, getGlobalType, pVarLower, pLift, pLower, + isInt, isFloat, isPointer, llvmWidthInBits, + + -- * Pretty Printing + ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmConstants, + ppLlvmConstant, ppLlvmGlobals, ppLlvmGlobal, ppLlvmFunctionDecls, + ppLlvmFunctionDecl, ppLlvmFunctions, ppLlvmFunction, ppLlvmType, + ppLlvmTypes, llvmSDoc + + ) where + +import Llvm.AbsSyn +import Llvm.PpLlvm +import Llvm.Types + diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs new file mode 100644 index 0000000000..1b8527b31f --- /dev/null +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -0,0 +1,209 @@ +-------------------------------------------------------------------------------- +-- | The LLVM abstract syntax. +-- + +module Llvm.AbsSyn where + +import Llvm.Types + +import Unique + +-- | Block labels +type LlvmBlockId = Unique + +-- | A block of LLVM code. +data LlvmBlock = LlvmBlock { + -- | The code label for this block + blockLabel :: LlvmBlockId, + + -- | A list of LlvmStatement's representing the code for this block. + -- This list must end with a control flow statement. + blockStmts :: [LlvmStatement] + } + +type LlvmBlocks = [LlvmBlock] + +-- | An LLVM Module. This is a top level contianer in LLVM. +data LlvmModule = LlvmModule { + -- | Comments to include at the start of the module. + modComments :: [LMString], + + -- | Constants to include in the module. + modConstants :: [LMConstant], + + -- | Global variables to include in the module. + modGlobals :: [LMGlobal], + + -- | LLVM Functions used in this module but defined in other modules. + modFwdDecls :: LlvmFunctionDecls, + + -- | LLVM Functions defined in this module. + modFuncs :: LlvmFunctions + } + +-- | An LLVM Function +data LlvmFunction = LlvmFunction { + -- | The signature of this declared function. + funcDecl :: LlvmFunctionDecl, + + -- | The function attributes. + funcAttrs :: [LlvmFuncAttr], + + -- | The body of the functions. + funcBody :: LlvmBlocks + } + +type LlvmFunctions = [LlvmFunction] + + +-- | Llvm Statements +data LlvmStatement + {- | + Assign an expression to an variable: + * dest: Variable to assign to + * source: Source expression + -} + = Assignment LlvmVar LlvmExpression + + {- | + Always branch to the target label + -} + | Branch LlvmVar + + {- | + Branch to label targetTrue if cond is true otherwise to label targetFalse + * cond: condition that will be tested, must be of type i1 + * targetTrue: label to branch to if cond is true + * targetFalse: label to branch to if cond is false + -} + | BranchIf LlvmVar LlvmVar LlvmVar + + {- | + Comment + Plain comment. + -} + | Comment [LMString] + + {- | + Set a label on this position. + * name: Identifier of this label, unique for this module + -} + | MkLabel LlvmBlockId + + {- | + Store variable value in pointer ptr. If value is of type t then ptr must + be of type t*. + * value: Variable/Constant to store. + * ptr: Location to store the value in + -} + | Store LlvmVar LlvmVar + + {- | + Mutliway branch + * scrutinee: Variable or constant which must be of integer type that is + determines which arm is chosen. + * def: The default label if there is no match in target. + * target: A list of (value,label) where the value is an integer + constant and label the corresponding label to jump to if the + scrutinee matches the value. + -} + | Switch LlvmVar LlvmVar [(LlvmVar, LlvmVar)] + + {- | + Return a result. + * result: The variable or constant to return + -} + | Return (Maybe LlvmVar) + + {- | + An instruction for the optimizer that the code following is not reachable + -} + | Unreachable + + {- | + Raise an expression to a statement (if don't want result or want to use + Llvm unamed values. + -} + | Expr LlvmExpression + + deriving (Show, Eq) + + +-- | Llvm Expressions +data LlvmExpression + {- | + Allocate amount * sizeof(tp) bytes on the stack + * tp: LlvmType to reserve room for + * amount: The nr of tp's which must be allocated + -} + = Alloca LlvmType Int + + {- | + Perform the machine operator op on the operands left and right + * op: operator + * left: left operand + * right: right operand + -} + | LlvmOp LlvmMachOp LlvmVar LlvmVar + + {- | + Perform a compare operation on the operands left and right + * op: operator + * left: left operand + * right: right operand + -} + | Compare LlvmCmpOp LlvmVar LlvmVar + + {- | + Allocate amount * sizeof(tp) bytes on the heap + * tp: LlvmType to reserve room for + * amount: The nr of tp's which must be allocated + -} + | Malloc LlvmType Int + + {- | + Load the value at location ptr + -} + | Load LlvmVar + + {- | + Navigate in an structure, selecting elements + * ptr: Location of the structure + * indexes: A list of indexes to select the correct value. For example + the first element of the third element of the structure ptr + is selected with [3,1] (zero indexed) + -} + | GetElemPtr LlvmVar [Int] + + {- | + Cast the variable from to the to type. This is an abstraction of three + cast operators in Llvm, inttoptr, prttoint and bitcast. + * cast: Cast type + * from: Variable to cast + * to: type to cast to + -} + | Cast LlvmCastOp LlvmVar LlvmType + + {- | + Call a function. The result is the value of the expression. + * tailJumps: CallType to signal if the function should be tail called + * fnptrval: An LLVM value containing a pointer to a function to be + invoked. Can be indirect. Should be LMFunction type. + * args: Concrete arguments for the parameters + * attrs: A list of function attributes for the call. Only NoReturn, + NoUnwind, ReadOnly and ReadNone are valid here. + -} + | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr] + + {- | + Merge variables from different basic blocks which are predecessors of this + basic block in a new variable of type tp. + * tp: type of the merged variable, must match the types of the + precessors variables. + * precessors: A list of variables and the basic block that they originate + from. + -} + | Phi LlvmType [(LlvmVar,LlvmVar)] + + deriving (Show, Eq) + diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs new file mode 100644 index 0000000000..8d36511a47 --- /dev/null +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -0,0 +1,325 @@ +-------------------------------------------------------------------------------- +-- | Pretty print LLVM IR Code. +-- + +module Llvm.PpLlvm ( + + -- * Top level LLVM objects. + ppLlvmModule, + ppLlvmComments, + ppLlvmComment, + ppLlvmConstants, + ppLlvmConstant, + ppLlvmGlobals, + ppLlvmGlobal, + ppLlvmType, + ppLlvmTypes, + ppLlvmFunctionDecls, + ppLlvmFunctionDecl, + ppLlvmFunctions, + ppLlvmFunction, + llvmSDoc + + ) where + +#include "HsVersions.h" + +import Llvm.AbsSyn +import Llvm.Types + +import Data.List ( intersperse ) +import Pretty +import qualified Outputable as Outp +import Unique + +-------------------------------------------------------------------------------- +-- * Top Level Print functions +-------------------------------------------------------------------------------- + +-- | Print out a whole LLVM module. +ppLlvmModule :: LlvmModule -> Doc +ppLlvmModule (LlvmModule comments constants globals decls funcs) + = ppLlvmComments comments + $+$ empty + $+$ ppLlvmConstants constants + $+$ ppLlvmGlobals globals + $+$ empty + $+$ ppLlvmFunctionDecls decls + $+$ empty + $+$ ppLlvmFunctions funcs + +-- | Print out a multi-line comment, can be inside a function or on its own +ppLlvmComments :: [LMString] -> Doc +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) + + +-- | Print out a list of global mutable variable definitions +ppLlvmGlobals :: [LMGlobal] -> Doc +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 (var@(LMGlobalVar _ _ link), (Just stat)) = + ppAssignment var $ text (show link) <+> text "global" <+> text (show stat) + +ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth + + +-- | Print out a list global constant variable +ppLlvmConstants :: [LMConstant] -> Doc +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 + + +-- | Print out a list of LLVM type aliases. +ppLlvmTypes :: [LlvmType] -> Doc +ppLlvmTypes tys = vcat $ map ppLlvmType tys + +-- | Print out an LLVM type alias. +ppLlvmType :: LlvmType -> Doc + +ppLlvmType al@(LMAlias _ t) + = (text $ show al) <+> equals <+> (text "type") <+> (text $ show t) + +ppLlvmType (LMFunction t) + = ppLlvmFunctionDecl t + +ppLlvmType _ = empty + + +-- | Print out a list of function definitions. +ppLlvmFunctions :: LlvmFunctions -> Doc +ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs + +-- | Print out a function definition. +ppLlvmFunction :: LlvmFunction -> Doc +ppLlvmFunction (LlvmFunction dec attrs body) = + let attrDoc = ppSpaceJoin attrs + in (text "define") <+> (ppLlvmFuncDecSig dec) + <+> attrDoc + $+$ lbrace + $+$ ppLlvmBlocks body + $+$ rbrace + + +-- | Print out a list of function declaration. +ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc +ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs + +-- | Print out a function declaration. +-- 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 + + +-- | Print out a list of LLVM blocks. +ppLlvmBlocks :: LlvmBlocks -> Doc +ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks + +-- | Print out an LLVM block. +-- It must be part of a function definition. +ppLlvmBlock :: LlvmBlock -> Doc +ppLlvmBlock (LlvmBlock blockId stmts) + = ppLlvmStatement (MkLabel blockId) + $+$ nest 4 (vcat $ map ppLlvmStatement stmts) + + +-- | Print out an LLVM statement. +ppLlvmStatement :: LlvmStatement -> Doc +ppLlvmStatement stmt + = case stmt of + Assignment dst expr -> ppAssignment dst (ppLlvmExpression expr) + Branch target -> ppBranch target + BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF + Comment comments -> ppLlvmComments comments + MkLabel label -> (llvmSDoc $ pprUnique label) <> colon + Store value ptr -> ppStore value ptr + Switch scrut def tgs -> ppSwitch scrut def tgs + Return result -> ppReturn result + Expr expr -> ppLlvmExpression expr + Unreachable -> text "unreachable" + + +-- | Print out an LLVM expression. +ppLlvmExpression :: LlvmExpression -> Doc +ppLlvmExpression expr + = case expr of + Alloca tp amount -> ppAlloca tp amount + LlvmOp op left right -> ppMachOp op left right + Call tp fp args attrs -> ppCall tp fp args attrs + Cast op from to -> ppCast op from to + Compare op left right -> ppCmpOp op left right + GetElemPtr ptr indexes -> ppGetElementPtr ptr indexes + Load ptr -> ppLoad ptr + Malloc tp amount -> ppMalloc tp amount + Phi tp precessors -> ppPhi tp precessors + + +-------------------------------------------------------------------------------- +-- * Individual print functions +-------------------------------------------------------------------------------- + +-- | Should always be a function pointer. So a global var of function type +-- (since globals are always pointers) or a local var of pointer function type. +ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> Doc +ppCall ct fptr vals attrs = case fptr of + -- + -- if local var function pointer, unwrap + LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d + + -- should be function type otherwise + LMGlobalVar _ (LMFunction d) _ -> ppCall' d + + -- not pointer or function, so error + _other -> error $ "ppCall called with non LMFunction type!\nMust be " + ++ " called with either global var of function type or " + ++ "local var of pointer function type." + + where + 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 ", ...") + FixedArgs -> empty) + fnty = space <> lparen <> ppArgTy <> rparen <> (text "*") + attrDoc = ppSpaceJoin attrs + in tc <> (text "call") <+> (text $ show cc) <+> (text $ show 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) + <> comma <+> (text $ getName right) + + +ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> Doc +ppCmpOp op left right = + let cmpOp + | isInt (getVarType left) && isInt (getVarType right) = text "icmp" + | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp" + | otherwise = error ("can't compare different types, left = " + ++ (show $ getVarType left) ++ ", right = " + ++ (show $ getVarType right)) + in cmpOp <+> (text $ show op) <+> (text $ show (getVarType left)) + <+> (text $ getName left) <> comma <+> (text $ getName right) + + +ppAssignment :: LlvmVar -> Doc -> Doc +ppAssignment var expr = (text $ getName var) <+> equals <+> expr + + +ppLoad :: LlvmVar -> Doc +ppLoad var = (text "load") <+> (text $ show var) + + +ppStore :: LlvmVar -> LlvmVar -> Doc +ppStore val dst = + (text "store") <+> (text $ show val) <> comma <+> (text $ show 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) + + +ppMalloc :: LlvmType -> Int -> Doc +ppMalloc tp amount = + let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 + in (text "malloc") <+> (text $ show tp) <> comma <+> (text $ show 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') + + +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 + + +ppReturn :: Maybe LlvmVar -> Doc +ppReturn (Just var) = (text "ret") <+> (text $ show var) +ppReturn Nothing = (text "ret") <+> (text $ show LMVoid) + + +ppBranch :: LlvmVar -> Doc +ppBranch var = (text "br") <+> (text $ show var) + + +ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> Doc +ppBranchIf cond trueT falseT + = (text "br") <+> (text $ show cond) <> comma <+> (text $ show trueT) <> comma + <+> (text $ show 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)) + + +ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> Doc +ppSwitch scrut dflt targets = + let ppTarget (val, lab) = (text $ show val) <> comma <+> (text $ show lab) + ppTargets xs = brackets $ vcat (map ppTarget xs) + in (text "switch") <+> (text $ show scrut) <> comma <+> (text $ show dflt) + <+> (ppTargets targets) + + +-------------------------------------------------------------------------------- +-- * Misc functions +-------------------------------------------------------------------------------- +atsym :: Doc +atsym = text "@" + +ppCommaJoin :: (Show a) => [a] -> Doc +ppCommaJoin strs = hcat $ intersperse comma (map (text . show) strs) + +ppSpaceJoin :: (Show a) => [a] -> Doc +ppSpaceJoin strs = hcat $ intersperse space (map (text . show) strs) + +-- | Convert SDoc to Doc +llvmSDoc :: Outp.SDoc -> Doc +llvmSDoc d + = Outp.withPprStyleDoc (Outp.mkCodeStyle Outp.CStyle) d + diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs new file mode 100644 index 0000000000..a4080c4d5c --- /dev/null +++ b/compiler/llvmGen/Llvm/Types.hs @@ -0,0 +1,719 @@ +-------------------------------------------------------------------------------- +-- | The LLVM Type System. +-- + +module Llvm.Types where + +#include "HsVersions.h" +#include "ghcconfig.h" + +import Data.Char +import Numeric + +import Constants +import FastString +import Unique + +-- from NCG +import PprBase + +-- ----------------------------------------------------------------------------- +-- * LLVM Basic Types and Variables +-- + +-- | A global mutable variable. Maybe defined or external +type LMGlobal = (LlvmVar, Maybe LlvmStatic) +-- | A global constant variable +type LMConstant = (LlvmVar, LlvmStatic) +-- | A String in LLVM +type LMString = FastString + + +-- | Llvm Types. +data LlvmType + = LMInt Int -- ^ An integer with a given width in bits. + | LMFloat -- ^ 32 bit floating point + | LMDouble -- ^ 64 bit floating point + | LMFloat80 -- ^ 80 bit (x86 only) floating point + | LMFloat128 -- ^ 128 bit floating point + | LMPointer LlvmType -- ^ A pointer to a 'LlvmType' + | LMArray Int LlvmType -- ^ An array of 'LlvmType' + | LMLabel -- ^ A 'LlvmVar' can represent a label (address) + | LMVoid -- ^ Void type + | LMStruct [LlvmType] -- ^ Structure type + | LMAlias LMString LlvmType -- ^ A type alias + + -- | Function type, used to create pointers to functions + | LMFunction LlvmFunctionDecl + deriving (Eq) + +instance Show LlvmType where + show (LMInt size ) = "i" ++ show size + show (LMFloat ) = "float" + show (LMDouble ) = "double" + show (LMFloat80 ) = "x86_fp80" + show (LMFloat128 ) = "fp128" + show (LMPointer x ) = show x ++ "*" + show (LMArray nr tp ) = "[" ++ show nr ++ " x " ++ show tp ++ "]" + show (LMLabel ) = "label" + 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 (LMAlias s _ ) = "%" ++ unpackFS s + + +-- | Llvm Variables +data LlvmVar + -- | Variables with a global scope. + = LMGlobalVar LMString LlvmType LlvmLinkageType + -- | Variables local to a function or parameters. + | LMLocalVar Unique LlvmType + -- | Named local variables. Sometimes we need to be able to explicitly name + -- variables (e.g for function arguments). + | LMNLocalVar LMString LlvmType + -- | A constant variable + | LMLitVar LlvmLit + deriving (Eq) + +instance Show LlvmVar where + show (LMLitVar x) = show x + show (x ) = show (getVarType x) ++ " " ++ getName x + + +-- | Llvm Literal Data. +-- +-- These can be used inline in expressions. +data LlvmLit + -- | Refers to an integer constant (i64 42). + = LMIntLit Integer LlvmType + -- | Floating point literal + | LMFloatLit Rational LlvmType + deriving (Eq) + +instance Show LlvmLit where + show l = show (getLitType l) ++ " " ++ getLit l + + +-- | Llvm Static Data. +-- +-- These represent the possible global level variables and constants. +data LlvmStatic + = LMComment LMString -- ^ A comment in a static section + | LMStaticLit LlvmLit -- ^ A static variant of a literal value + | LMUninitType LlvmType -- ^ For uninitialised data + | LMStaticStr LMString LlvmType -- ^ Defines a static 'LMString' + | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array + | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type + | LMStaticPointer LlvmVar -- ^ A pointer to other data + + -- static expressions, could split out but leave + -- for moment for ease of use. Not many of them. + + | 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 (LMStaticLit l ) = show l + show (LMUninitType t) = show t ++ " undef" + show (LMStaticStr s t) = show t ++ " c\"" ++ unpackFS s ++ "\\00\"" + + show (LMStaticArray d t) + = let struc = case d of + [] -> "[]" + 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))) + ++ "}" + in show t ++ " " ++ struc + + show (LMStaticPointer v) = show v + + show (LMPtoI v t) + = show t ++ " ptrtoint (" ++ show v ++ " to " ++ show t ++ ")" + + show (LMAdd s1 s2) + = let ty1 = getStatType s1 + in if ty1 == getStatType s2 + then show ty1 ++ " add (" ++ show s1 ++ "," ++ show s2 ++ ")" + else error $ "LMAdd with different types! s1: " + ++ show s1 ++ ", s2: " ++ show s2 + show (LMSub s1 s2) + = let ty1 = getStatType s1 + in if ty1 == getStatType s2 + then show ty1 ++ " sub (" ++ show s1 ++ "," ++ show s2 ++ ")" + else error $ "LMSub with different types! s1: " + ++ show s1 ++ ", s2: " ++ show s2 + + +-- | Concatenate an array together, separated by commas +commaCat :: Show a => [a] -> String +commaCat [] = "" +commaCat x = show (head x) ++ (concat $ map (\y -> "," ++ show y) (tail x)) + +-- ----------------------------------------------------------------------------- +-- ** Operations on LLVM Basic Types and Variables +-- + +-- | Return the variable name or value of the 'LlvmVar' +-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@). +getName :: LlvmVar -> String +getName v@(LMGlobalVar _ _ _ ) = "@" ++ getPlainName v +getName v@(LMLocalVar _ _ ) = "%" ++ getPlainName v +getName v@(LMNLocalVar _ _ ) = "%" ++ getPlainName v +getName v@(LMLitVar _ ) = getPlainName v + +-- | 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 + +-- | Print a literal value. No type. +getLit :: LlvmLit -> String +getLit (LMIntLit i _) = show ((fromInteger i)::Int) +-- In Llvm float literals can be printed in a big-endian hexadecimal format, +-- regardless of underlying architecture. +getLit (LMFloatLit r LMFloat) = fToStr $ fromRational r +getLit (LMFloatLit r LMDouble) = dToStr $ fromRational r +getLit l = error $ "getLit: Usupported LlvmLit type! " ++ show (getLitType l) + +-- | 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 + +-- | Return the 'LlvmType' of a 'LlvmLit' +getLitType :: LlvmLit -> LlvmType +getLitType (LMIntLit _ t) = t +getLitType (LMFloatLit _ t) = t + +-- | Return the 'LlvmType' of the 'LlvmStatic' +getStatType :: LlvmStatic -> LlvmType +getStatType (LMStaticLit l ) = getLitType l +getStatType (LMUninitType t) = t +getStatType (LMStaticStr _ t) = t +getStatType (LMStaticArray _ t) = t +getStatType (LMStaticStruc _ t) = t +getStatType (LMStaticPointer v) = getVarType v +getStatType (LMPtoI _ t) = t +getStatType (LMAdd t _) = getStatType t +getStatType (LMSub t _) = getStatType t +getStatType (LMComment _) = error "Can't call getStatType on LMComment!" + +-- | Return the 'LlvmType' of the 'LMGlobal' +getGlobalType :: LMGlobal -> LlvmType +getGlobalType (v, _) = getVarType v + +-- | Return the 'LlvmVar' part of a 'LMGlobal' +getGlobalVar :: LMGlobal -> LlvmVar +getGlobalVar (v, _) = v + +-- | Return the 'LlvmLinkageType' for a 'LlvmVar' +getLink :: LlvmVar -> LlvmLinkageType +getLink (LMGlobalVar _ _ l) = l +getLink _ = ExternallyVisible + +-- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid' +-- cannot be lifted. +pLift :: LlvmType -> LlvmType +pLift (LMLabel) = error "Labels are unliftable" +pLift (LMVoid) = error "Voids are unliftable" +pLift x = LMPointer x + +-- | Remove the pointer indirection of the supplied type. Only 'LMPointer' +-- constructors can be lowered. +pLower :: LlvmType -> LlvmType +pLower (LMPointer x) = x +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!" + +-- | Test if the given 'LlvmType' is an integer +isInt :: LlvmType -> Bool +isInt (LMInt _) = True +isInt _ = False + +-- | Test if the given 'LlvmType' is a floating point type +isFloat :: LlvmType -> Bool +isFloat LMFloat = True +isFloat LMDouble = True +isFloat LMFloat80 = True +isFloat LMFloat128 = True +isFloat _ = False + +-- | Test if the given 'LlvmType' is an 'LMPointer' construct +isPointer :: LlvmType -> Bool +isPointer (LMPointer _) = True +isPointer _ = False + +-- | Test if a 'LlvmVar' is global. +isGlobal :: LlvmVar -> Bool +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 +-- 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 + + +-- ----------------------------------------------------------------------------- +-- ** 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 + +-- | The target architectures word size +llvmWord :: LlvmType +llvmWord = LMInt (wORD_SIZE * 8) + +-- | The target architectures pointer size +llvmWordPtr :: LlvmType +llvmWordPtr = pLift llvmWord + + +-- ----------------------------------------------------------------------------- +-- * LLVM Function Types +-- + +-- | An LLVM Function +data LlvmFunctionDecl = LlvmFunctionDecl { + -- | Unique identifier of the function. + decName :: LMString, + -- | LinkageType of the function. + funcLinkage :: LlvmLinkageType, + -- | The calling convention of the function. + funcCc :: LlvmCallConvention, + -- | Type of the returned value + decReturnType :: LlvmType, + -- | Indicates if this function uses varargs + decVarargs :: LlvmParameterListType, + -- | Signature of the parameters, can be just types or full vars + -- if parameter names are required. + decParams :: Either [LlvmType] [LlvmVar] + } + +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) + +type LlvmFunctionDecls = [LlvmFunctionDecl] + + +-- | Llvm Function Attributes. +-- +-- Function attributes are set to communicate additional information about a +-- function. Function attributes are considered to be part of the function, +-- not of the function type, so functions with different parameter attributes +-- can have the same function type. Functions can have multiple attributes. +-- +-- Descriptions taken from <http://llvm.org/docs/LangRef.html#fnattrs> +data LlvmFuncAttr + -- | This attribute indicates that the inliner should attempt to inline this + -- function into callers whenever possible, ignoring any active inlining + -- size threshold for this caller. + = AlwaysInline + -- | This attribute indicates that the source code contained a hint that + -- inlining this function is desirable (such as the \"inline\" keyword in + -- C/C++). It is just a hint; it imposes no requirements on the inliner. + | InlineHint + -- | This attribute indicates that the inliner should never inline this + -- function in any situation. This attribute may not be used together + -- with the alwaysinline attribute. + | NoInline + -- | This attribute suggests that optimization passes and code generator + -- passes make choices that keep the code size of this function low, and + -- otherwise do optimizations specifically to reduce code size. + | OptSize + -- | This function attribute indicates that the function never returns + -- normally. This produces undefined behavior at runtime if the function + -- ever does dynamically return. + | NoReturn + -- | This function attribute indicates that the function never returns with + -- an unwind or exceptional control flow. If the function does unwind, its + -- runtime behavior is undefined. + | NoUnwind + -- | This attribute indicates that the function computes its result (or + -- decides to unwind an exception) based strictly on its arguments, without + -- dereferencing any pointer arguments or otherwise accessing any mutable + -- state (e.g. memory, control registers, etc) visible to caller functions. + -- It does not write through any pointer arguments (including byval + -- arguments) and never changes any state visible to callers. This means + -- that it cannot unwind exceptions by calling the C++ exception throwing + -- methods, but could use the unwind instruction. + | ReadNone + -- | This attribute indicates that the function does not write through any + -- pointer arguments (including byval arguments) or otherwise modify any + -- state (e.g. memory, control registers, etc) visible to caller functions. + -- It may dereference pointer arguments and read state that may be set in + -- the caller. A readonly function always returns the same value (or unwinds + -- an exception identically) when called with the same set of arguments and + -- global state. It cannot unwind an exception by calling the C++ exception + -- throwing methods, but may use the unwind instruction. + | ReadOnly + -- | This attribute indicates that the function should emit a stack smashing + -- protector. It is in the form of a \"canary\"—a random value placed on the + -- stack before the local variables that's checked upon return from the + -- function to see if it has been overwritten. A heuristic is used to + -- determine if a function needs stack protectors or not. + -- + -- If a function that has an ssp attribute is inlined into a function that + -- doesn't have an ssp attribute, then the resulting function will have an + -- ssp attribute. + | Ssp + -- | This attribute indicates that the function should always emit a stack + -- smashing protector. This overrides the ssp function attribute. + -- + -- If a function that has an sspreq attribute is inlined into a function + -- that doesn't have an sspreq attribute or which has an ssp attribute, + -- then the resulting function will have an sspreq attribute. + | SspReq + -- | This attribute indicates that the code generator should not use a red + -- zone, even if the target-specific ABI normally permits it. + | NoRedZone + -- | This attributes disables implicit floating point instructions. + | NoImplicitFloat + -- | This attribute disables prologue / epilogue emission for the function. + -- This can have very system-specific consequences. + | Naked + 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" + + +-- | Different types to call a function. +data LlvmCallType + -- | Normal call, allocate a new stack frame. + = StdCall + -- | Tail call, perform the call in the current stack frame. + | TailCall + deriving (Eq,Show) + +-- | Different calling conventions a function can use. +data LlvmCallConvention + -- | The C calling convention. + -- This calling convention (the default if no other calling convention is + -- specified) matches the target C calling conventions. This calling + -- convention supports varargs function calls and tolerates some mismatch in + -- the declared prototype and implemented declaration of the function (as + -- does normal C). + = CC_Ccc + -- | This calling convention attempts to make calls as fast as possible + -- (e.g. by passing things in registers). This calling convention allows + -- the target to use whatever tricks it wants to produce fast code for the + -- target, without having to conform to an externally specified ABI + -- (Application Binary Interface). Implementations of this convention should + -- allow arbitrary tail call optimization to be supported. This calling + -- convention does not support varargs and requires the prototype of al + -- callees to exactly match the prototype of the function definition. + | CC_Fastcc + -- | This calling convention attempts to make code in the caller as efficient + -- as possible under the assumption that the call is not commonly executed. + -- As such, these calls often preserve all registers so that the call does + -- not break any live ranges in the caller side. This calling convention + -- does not support varargs and requires the prototype of all callees to + -- exactly match the prototype of the function definition. + | CC_Coldcc + -- | Any calling convention may be specified by number, allowing + -- target-specific calling conventions to be used. Target specific calling + -- conventions start at 64. + | CC_Ncc Int + -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it + -- rather than just using CC_Ncc. + | CC_X86_Stdcc + deriving (Eq) + +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_X86_Stdcc = "x86_stdcallcc" + + +-- | Functions can have a fixed amount of parameters, or a variable amount. +data LlvmParameterListType + -- Fixed amount of arguments. + = FixedArgs + -- Variable amount of arguments. + | VarArgs + deriving (Eq,Show) + + +-- | Linkage type of a symbol. +-- +-- The description of the constructors is copied from the Llvm Assembly Language +-- Reference Manual <http://www.llvm.org/docs/LangRef.html#linkage>, because +-- they correspond to the Llvm linkage types. +data LlvmLinkageType + -- | Global values with internal linkage are only directly accessible by + -- objects in the current module. In particular, linking code into a module + -- with an internal global value may cause the internal to be renamed as + -- necessary to avoid collisions. Because the symbol is internal to the + -- module, all references can be updated. This corresponds to the notion + -- of the @static@ keyword in C. + = Internal + -- | Globals with @linkonce@ linkage are merged with other globals of the + -- same name when linkage occurs. This is typically used to implement + -- inline functions, templates, or other code which must be generated + -- in each translation unit that uses it. Unreferenced linkonce globals are + -- allowed to be discarded. + | LinkOnce + -- | @weak@ linkage is exactly the same as linkonce linkage, except that + -- unreferenced weak globals may not be discarded. This is used for globals + -- that may be emitted in multiple translation units, but that are not + -- guaranteed to be emitted into every translation unit that uses them. One + -- example of this are common globals in C, such as @int X;@ at global + -- scope. + | Weak + -- | @appending@ linkage may only be applied to global variables of pointer + -- to array type. When two global variables with appending linkage are + -- linked together, the two global arrays are appended together. This is + -- the Llvm, typesafe, equivalent of having the system linker append + -- together @sections@ with identical names when .o files are linked. + | Appending + -- | The semantics of this linkage follow the ELF model: the symbol is weak + -- until linked, if not linked, the symbol becomes null instead of being an + -- undefined reference. + | ExternWeak + -- | The symbol participates in linkage and can be used to resolve external + -- symbol references. + | ExternallyVisible + -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM + -- assembly. + | External + deriving (Eq) + +instance Show LlvmLinkageType where + show Internal = "internal" + show LinkOnce = "linkonce" + show Weak = "weak" + show Appending = "appending" + show ExternWeak = "extern_weak" + -- ExternallyVisible does not have a textual representation, it is + -- the linkage type a function resolves to if no other is specified + -- in Llvm. + show ExternallyVisible = "" + show External = "external" + + +-- ----------------------------------------------------------------------------- +-- * LLVM Operations +-- + +-- | Llvm binary operators machine operations. +data LlvmMachOp + = LM_MO_Add -- ^ add two integer, floating point or vector values. + | LM_MO_Sub -- ^ subtract two ... + | LM_MO_Mul -- ^ multiply .. + | LM_MO_UDiv -- ^ unsigned integer or vector division. + | LM_MO_SDiv -- ^ signed integer .. + | LM_MO_FDiv -- ^ floating point .. + | LM_MO_URem -- ^ unsigned integer or vector remainder (mod) + | LM_MO_SRem -- ^ signed ... + | LM_MO_FRem -- ^ floating point ... + + -- | Left shift + | LM_MO_Shl + -- | Logical shift right + -- Shift right, filling with zero + | LM_MO_LShr + -- | Arithmetic shift right + -- The most significant bits of the result will be equal to the sign bit of + -- the left operand. + | LM_MO_AShr + + | LM_MO_And -- ^ AND bitwise logical operation. + | LM_MO_Or -- ^ OR bitwise logical operation. + | LM_MO_Xor -- ^ XOR bitwise logical operation. + deriving (Eq) + +instance Show LlvmMachOp where + show LM_MO_Add = "add" + show LM_MO_Sub = "sub" + show LM_MO_Mul = "mul" + show LM_MO_UDiv = "udiv" + show LM_MO_SDiv = "sdiv" + show LM_MO_FDiv = "fdiv" + show LM_MO_URem = "urem" + show LM_MO_SRem = "srem" + show LM_MO_FRem = "frem" + show LM_MO_Shl = "shl" + show LM_MO_LShr = "lshr" + show LM_MO_AShr = "ashr" + show LM_MO_And = "and" + show LM_MO_Or = "or" + show LM_MO_Xor = "xor" + + +-- | Llvm compare operations. +data LlvmCmpOp + = LM_CMP_Eq -- ^ Equal (Signed and Unsigned) + | LM_CMP_Ne -- ^ Not equal (Signed and Unsigned) + | LM_CMP_Ugt -- ^ Unsigned greater than + | LM_CMP_Uge -- ^ Unsigned greater than or equal + | LM_CMP_Ult -- ^ Unsigned less than + | LM_CMP_Ule -- ^ Unsigned less than or equal + | LM_CMP_Sgt -- ^ Signed greater than + | LM_CMP_Sge -- ^ Signed greater than or equal + | LM_CMP_Slt -- ^ Signed less than + | LM_CMP_Sle -- ^ Signed less than or equal + + -- Float comparisons. GHC uses a mix of ordered and unordered float + -- comparisons. + | LM_CMP_Feq -- ^ Float equal + | LM_CMP_Fne -- ^ Float not equal + | LM_CMP_Fgt -- ^ Float greater than + | LM_CMP_Fge -- ^ Float greater than or equal + | LM_CMP_Flt -- ^ Float less than + | LM_CMP_Fle -- ^ Float less than or equal + deriving (Eq) + +instance Show LlvmCmpOp where + show LM_CMP_Eq = "eq" + show LM_CMP_Ne = "ne" + show LM_CMP_Ugt = "ugt" + show LM_CMP_Uge = "uge" + show LM_CMP_Ult = "ult" + show LM_CMP_Ule = "ule" + show LM_CMP_Sgt = "sgt" + show LM_CMP_Sge = "sge" + show LM_CMP_Slt = "slt" + show LM_CMP_Sle = "sle" + show LM_CMP_Feq = "oeq" + show LM_CMP_Fne = "une" + show LM_CMP_Fgt = "ogt" + show LM_CMP_Fge = "oge" + show LM_CMP_Flt = "olt" + show LM_CMP_Fle = "ole" + + +-- | Llvm cast operations. +data LlvmCastOp + = LM_Trunc -- ^ Integer truncate + | LM_Zext -- ^ Integer extend (zero fill) + | LM_Sext -- ^ Integer extend (sign fill) + | LM_Fptrunc -- ^ Float truncate + | LM_Fpext -- ^ Float extend + | LM_Fptoui -- ^ Float to unsigned Integer + | LM_Fptosi -- ^ Float to signed Integer + | LM_Uitofp -- ^ Unsigned Integer to Float + | LM_Sitofp -- ^ Signed Int to Float + | LM_Ptrtoint -- ^ Pointer to Integer + | LM_Inttoptr -- ^ Integer to Pointer + | LM_Bitcast -- ^ Cast between types where no bit manipulation is needed + deriving (Eq) + +instance Show LlvmCastOp where + show LM_Trunc = "trunc" + show LM_Zext = "zext" + show LM_Sext = "sext" + show LM_Fptrunc = "fptrunc" + show LM_Fpext = "fpext" + show LM_Fptoui = "fptoui" + show LM_Fptosi = "fptosi" + show LM_Uitofp = "uitofp" + show LM_Sitofp = "sitofp" + show LM_Ptrtoint = "ptrtoint" + show LM_Inttoptr = "inttoptr" + show LM_Bitcast = "bitcast" + + +-- ----------------------------------------------------------------------------- +-- * Floating point conversion +-- + +-- | Convert a Haskell Float to an LLVM hex encoded floating point form +fToStr :: Float -> String +fToStr f = dToStr $ realToFrac f + +-- | Convert a Haskell Double to an LLVM hex encoded floating point form +dToStr :: Double -> String +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' + in "0x" ++ str + +-- | Reverse or leave byte data alone to fix endianness on this +-- target. LLVM generally wants things in Big-Endian form +-- regardless of target architecture. +fixEndian :: [a] -> [a] +#ifdef WORDS_BIGENDIAN +fixEndian = id +#else +fixEndian = reverse +#endif + diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs new file mode 100644 index 0000000000..e0485e703c --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -0,0 +1,166 @@ +-- ----------------------------------------------------------------------------- +-- | This is the top-level module in the LLVM code generator. +-- + +module LlvmCodeGen ( llvmCodeGen ) where + +#include "HsVersions.h" + +import LlvmCodeGen.Base +import LlvmCodeGen.CodeGen +import LlvmCodeGen.Data +import LlvmCodeGen.Ppr + +import Cmm +import CgUtils ( fixStgRegisters ) +import PprCmm + +import BufWrite +import DynFlags +import ErrUtils +import Outputable +import qualified Pretty as Prt +import UniqSupply + +import System.IO + +-- ----------------------------------------------------------------------------- +-- | Top-level of the llvm codegen +-- +llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () +llvmCodeGen dflags h us cmms + = do + let cmm = concat $ map extractRawCmm cmms + + bufh <- newBufHandle h + + Prt.bufLeftRender bufh $ pprLlvmHeader + + env <- cmmDataLlvmGens dflags bufh cmm + cmmProcLlvmGens dflags bufh us env cmm + + bFlush bufh + + return () + + where extractRawCmm (Cmm tops) = tops + + +-- ----------------------------------------------------------------------------- +-- | Do llvm code generation on all these cmms data sections. +-- +cmmDataLlvmGens + :: DynFlags + -> BufHandle + -> [RawCmmTop] + -> IO ( LlvmEnv ) + +cmmDataLlvmGens _ _ [] + = return ( initLlvmEnv ) + +cmmDataLlvmGens dflags h cmm = + let exData (CmmData s d) = [(s,d)] + exData _ = [] + + exProclbl (CmmProc _ l _ _) = [(strCLabel_llvm l)] + exProclbl _ = [] + + cdata = concat $ map exData cmm + -- put the functions into the enviornment + cproc = concat $ map exProclbl cmm + env = foldl (\e l -> funInsert l llvmFunTy e) initLlvmEnv cproc + in cmmDataLlvmGens' dflags h env cdata [] + +cmmDataLlvmGens' + :: DynFlags + -> BufHandle + -> LlvmEnv + -> [(Section, [CmmStatic])] + -> [LlvmUnresData] + -> IO ( LlvmEnv ) + +cmmDataLlvmGens' dflags h env [] lmdata + = do + let (env', lmdata') = resolveLlvmDatas dflags env lmdata [] + let lmdoc = Prt.vcat $ map (pprLlvmData dflags) lmdata' + + dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc + + Prt.bufLeftRender h lmdoc + return env' + +cmmDataLlvmGens' dflags h env (cmm:cmms) lmdata + = do + let lmdata'@(l, ty, _) = genLlvmData dflags cmm + let env' = funInsert (strCLabel_llvm l) ty env + cmmDataLlvmGens' dflags h env' cmms (lmdata ++ [lmdata']) + + +-- ----------------------------------------------------------------------------- +-- | Do llvm code generation on all these cmms procs. +-- +cmmProcLlvmGens + :: DynFlags + -> BufHandle + -> UniqSupply + -> LlvmEnv + -> [RawCmmTop] + -> IO () + +cmmProcLlvmGens _ _ _ _ [] + = return () + +cmmProcLlvmGens dflags h us env (cmm : cmms) + = do + (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm + + Prt.bufLeftRender h $ Prt.vcat $ map (pprLlvmCmmTop dflags) llvm + + cmmProcLlvmGens dflags h us' env' cmms + + +-- | Complete llvm code generation phase for a single top-level chunk of Cmm. +cmmLlvmGen + :: DynFlags + -> UniqSupply + -> LlvmEnv + -> RawCmmTop -- ^ the cmm to generate code for + -> IO ( UniqSupply, + LlvmEnv, + [LlvmCmmTop] ) -- llvm code + +cmmLlvmGen dflags us env cmm + = do + -- rewrite assignments to global regs + let fixed_cmm = fixStgRegisters cmm + + dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" + (pprCmm $ Cmm [fixed_cmm]) + + -- generate llvm code from 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) + + return (usGen, env', llvmBC) + + +-- ----------------------------------------------------------------------------- +-- | Instruction selection +-- +genLlvmCode + :: DynFlags + -> LlvmEnv + -> RawCmmTop + -> UniqSM (LlvmEnv, [LlvmCmmTop]) + +genLlvmCode _ env (CmmData _ _) + = return (env, []) + +genLlvmCode _ env (CmmProc _ _ _ (ListGraph [])) + = return (env, []) + +genLlvmCode _ env cp@(CmmProc _ _ _ _) + = genLlvmProc env cp + diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs new file mode 100644 index 0000000000..36ffa18d63 --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -0,0 +1,164 @@ +-- ---------------------------------------------------------------------------- +-- | Base LLVM Code Generation module +-- +-- Contains functions useful through out the code generator. +-- + +module LlvmCodeGen.Base ( + + LlvmCmmTop, LlvmBasicBlock, + LlvmUnresData, LlvmData, UnresLabel, UnresStatic, + + LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert, + funLookup, funInsert, + + cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, + llvmFunSig, llvmStdFunAttrs, llvmPtrBits, llvmGhcCC, + + strCLabel_llvm, + genCmmLabelRef, genStringLabelRef + + ) where + +#include "HsVersions.h" + +import Llvm +import LlvmCodeGen.Regs + +import CgUtils ( activeStgRegs ) +import CLabel +import Cmm + +import FastString +import qualified Outputable as Outp +import Unique +import UniqFM + +-- ---------------------------------------------------------------------------- +-- * Some Data Types +-- + +type LlvmCmmTop = GenCmmTop LlvmData [CmmStatic] (ListGraph LlvmStatement) +type LlvmBasicBlock = GenBasicBlock LlvmStatement + +-- | Unresolved code. +-- Of the form: (data label, data type, unresovled data) +type LlvmUnresData = (CLabel, LlvmType, [UnresStatic]) + +-- | Top level LLVM Data (globals and type aliases) +type LlvmData = ([LMGlobal], [LlvmType]) + +-- | An unresolved Label. +-- +-- 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 UnresStatic = Either UnresLabel LlvmStatic + +-- ---------------------------------------------------------------------------- +-- * Type translations +-- + +-- | Translate a basic CmmType to an LlvmType. +cmmToLlvmType :: CmmType -> LlvmType +cmmToLlvmType ty | isFloatType ty = widthToLlvmFloat $ typeWidth ty + | otherwise = widthToLlvmInt $ typeWidth ty + +-- | Translate a Cmm Float Width to a LlvmType. +widthToLlvmFloat :: Width -> LlvmType +widthToLlvmFloat W32 = LMFloat +widthToLlvmFloat W64 = LMDouble +widthToLlvmFloat W80 = LMFloat80 +widthToLlvmFloat W128 = LMFloat128 +widthToLlvmFloat w = panic $ "widthToLlvmFloat: Bad float size: " ++ show w + +-- | Translate a Cmm Bit Width to a LlvmType. +widthToLlvmInt :: Width -> LlvmType +widthToLlvmInt w = LMInt $ widthInBits w + +-- | GHC Call Convention for LLVM +llvmGhcCC :: LlvmCallConvention +llvmGhcCC = CC_Ncc 10 + +-- | Llvm Function type for Cmm function +llvmFunTy :: LlvmType +llvmFunTy + = LMFunction $ + LlvmFunctionDecl (fsLit "a") ExternallyVisible llvmGhcCC LMVoid FixedArgs + (Left $ map getVarType llvmFunArgs) + +-- | Llvm Function signature +llvmFunSig :: CLabel -> LlvmLinkageType -> LlvmFunctionDecl +llvmFunSig lbl link + = let n = strCLabel_llvm lbl + in LlvmFunctionDecl n link llvmGhcCC LMVoid FixedArgs + (Right llvmFunArgs) + +-- | A Function's arguments +llvmFunArgs :: [LlvmVar] +llvmFunArgs = map lmGlobalRegArg activeStgRegs + +-- | Llvm standard fun attributes +llvmStdFunAttrs :: [LlvmFuncAttr] +llvmStdFunAttrs = [NoUnwind] + +-- | Pointer width +llvmPtrBits :: Int +llvmPtrBits = widthInBits $ typeWidth gcWord + + +-- ---------------------------------------------------------------------------- +-- * Environment Handling +-- + +type LlvmEnvMap = UniqFM LlvmType +-- two maps, one for functions and one for local vars. +type LlvmEnv = (LlvmEnvMap, LlvmEnvMap) + +-- | Get initial Llvm environment. +initLlvmEnv :: LlvmEnv +initLlvmEnv = (emptyUFM, emptyUFM) + +-- | Clear variables from the environment. +clearVars :: LlvmEnv -> LlvmEnv +clearVars (e1, _) = (e1, emptyUFM) + +-- | Insert functions into the environment. +varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv +varInsert s t (e1, e2) = (e1, addToUFM e2 s t) +funInsert s t (e1, e2) = (addToUFM e1 s t, e2) + +-- | Lookup functions in the environment. +varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType +varLookup s (_, e2) = lookupUFM e2 s +funLookup s (e1, _) = lookupUFM e1 s + + +-- ---------------------------------------------------------------------------- +-- * Label handling +-- + +-- | Pretty print a 'CLabel'. +strCLabel_llvm :: CLabel -> LMString +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) + +-- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'. +genStringLabelRef :: LMString -> LMGlobal +genStringLabelRef cl = + (LMGlobalVar cl (LMPointer (LMArray 0 llvmWord)) External, Nothing) + + +-- ---------------------------------------------------------------------------- +-- * Misc +-- + +-- | Error function +panic :: String -> a +panic s = Outp.panic $ "LlvmCodeGen.Base." ++ s + diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs new file mode 100644 index 0000000000..fb29f7acec --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -0,0 +1,958 @@ +-- ---------------------------------------------------------------------------- +-- | Handle conversion of CmmProc to LLVM code. +-- + +module LlvmCodeGen.CodeGen ( genLlvmProc ) where + +#include "HsVersions.h" + +import Llvm +import LlvmCodeGen.Base +import LlvmCodeGen.Regs + +import BlockId +import CgUtils ( activeStgRegs ) +import CLabel +import Cmm +import qualified PprCmm +import OrdList + +import BasicTypes +import FastString +import ForeignCall +import Outputable hiding ( panic, pprPanic ) +import qualified Outputable +import UniqSupply +import Unique +import Util + +type LlvmStatements = OrdList LlvmStatement + +-- ----------------------------------------------------------------------------- +-- | Top-level of the llvm proc codegen +-- +genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop]) +genLlvmProc env (CmmData _ _) + = return (env, []) + +genLlvmProc env (CmmProc _ _ _ (ListGraph [])) + = return (env, []) + +genLlvmProc env (CmmProc info lbl params (ListGraph blocks)) + = do + (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], []) + + let proc = CmmProc info lbl params (ListGraph lmblocks) + let tops = lmdata ++ [proc] + + return (env', tops) + + +-- ----------------------------------------------------------------------------- +-- * Block code generation +-- + +-- | Generate code for a list of blocks that make up a complete procedure. +basicBlocksCodeGen :: LlvmEnv + -> [CmmBasicBlock] + -> ( [LlvmBasicBlock] , [LlvmCmmTop] ) + -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmTop] ) +basicBlocksCodeGen env ([]) (blocks, tops) + = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks + let allocs' = concat allocs + let ((BasicBlock id fstmts):rblocks) = blocks' + let fblocks = (BasicBlock id (funPrologue ++ allocs' ++ fstmts)):rblocks + return (env, fblocks, tops) + +basicBlocksCodeGen env (block:blocks) (lblocks', ltops') + = do (env', lb, lt) <- basicBlockCodeGen env block + let lblocks = lblocks' ++ lb + let ltops = ltops' ++ lt + basicBlocksCodeGen env' blocks (lblocks, ltops) + + +-- | Generate code for one block +basicBlockCodeGen :: LlvmEnv + -> CmmBasicBlock + -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmTop] ) +basicBlockCodeGen env (BasicBlock id stmts) + = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, []) + return (env', [BasicBlock id (fromOL instrs)], top) + + +-- | Allocations need to be extracted so they can be moved to the entry +-- of a function to make sure they dominate all posible paths in the CFG. +dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement]) +dominateAllocs (BasicBlock id stmts) + = (BasicBlock id allstmts, allallocs) + where + (allstmts, allallocs) = foldl split ([],[]) stmts + split (stmts', allocs) s@(Assignment _ (Alloca _ _)) + = (stmts', allocs ++ [s]) + split (stmts', allocs) other + = (stmts' ++ [other], allocs) + + +-- ----------------------------------------------------------------------------- +-- * CmmStmt code generation +-- + +-- A statement conversion return data. +-- * LlvmEnv: The new enviornment +-- * LlvmStatements: The compiled llvm statements. +-- * LlvmCmmTop: Any global data needed. +type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmTop]) + + +-- | Convert a list of CmmStmt's to LlvmStatement's +stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmTop]) + -> UniqSM StmtData +stmtsToInstrs env [] (llvm, top) + = return (env, llvm, top) + +stmtsToInstrs env (stmt : stmts) (llvm, top) + = do (env', instrs, tops) <- stmtToInstrs env stmt + stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops) + + +-- | Convert a CmmStmt to a list of LlvmStatement's +stmtToInstrs :: LlvmEnv -> CmmStmt + -> UniqSM StmtData +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 + + CmmBranch id -> genBranch env id + CmmCondBranch arg id -> genCondBranch env arg id + CmmSwitch arg ids -> genSwitch env arg ids + + -- Foreign Call + CmmCall target res args _ ret + -> genCall env target res args ret + + -- Tail call + CmmJump arg _ -> genJump env arg + + -- CPS, only tail calls, no return's + -- Actually, there are a few return statements that occur because of hand + -- written cmm code. + CmmReturn _ + -> return (env, unitOL $ Return Nothing, []) + + +-- | Foreign Calls +genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals + -> CmmReturnInfo -> UniqSM StmtData + +-- Write barrier needs to be handled specially as it is implemented as an llvm +-- 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 fty = LMFunction funSig + + let fv = LMGlobalVar fname fty (funcLinkage funSig) + let tops = case funLookup fname env of + Just _ -> [] + Nothing -> [CmmData Data [([],[fty])]] + + let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue] + let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs + let env' = funInsert fname fty env + + return (env', unitOL s1, tops) + + where + lmTrue :: LlvmVar + lmTrue = LMLitVar $ LMIntLit (-1) i1 + +-- Handle all other foreign calls and prim ops. +genCall env target res args ret = do + + -- paramater types + let arg_type (CmmHinted _ AddrHint) = pLift i8 + -- 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 t = panic $ "genCall: Too many return values! Can only handle" + ++ " 0 or 1, given " ++ show (length t) ++ "." + + -- extract cmm call convention + let cconv = case target of + CmmCallee _ conv -> conv + CmmPrim _ -> PrimCallConv + + -- translate to llvm call convention + let lmconv = case cconv of +#if i386_TARGET_ARCH || x86_64_TARGET_ARCH + StdCallConv -> CC_X86_Stdcc +#else + StdCallConv -> CC_Ccc +#endif + CCallConv -> CC_Ccc + PrimCallConv -> CC_Ccc + CmmCallConv -> panic "CmmCallConv not supported here!" + + {- + Some of the possibilities here are a worry with the use of a custom + calling convention for passing STG args. In practice the more + dangerous combinations (e.g StdCall + llvmGhcCC) don't occur. + + The native code generator only handles StdCall and CCallConv. + -} + + -- call attributes + let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs + | otherwise = llvmStdFunAttrs + + -- fun type + 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 + + -- get paramter values + (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) + + -- get the return register + let ret_reg ([CmmHinted reg hint]) = (reg, hint) + ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" + ++ " 1, given " ++ show (length t) ++ "." + + -- deal with call types + let getFunPtr :: CmmCallTarget -> UniqSM ExprData + getFunPtr targ = case targ of + CmmCallee (CmmLit (CmmLabel lbl)) _ -> do + let name = strCLabel_llvm lbl + case funLookup name env1 of + Just ty'@(LMFunction sig) -> do + -- Function in module in right form + let fun = LMGlobalVar name ty' (funcLinkage sig) + 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) + (v1, s1) <- doExpr (pLift fty) + $ Cast LM_Bitcast fun (pLift fty) + return (env1, v1, unitOL s1, []) + + Nothing -> do + -- label not in module, create external reference + let fty@(LMFunction sig) = funTy name + let fun = LMGlobalVar name fty (funcLinkage sig) + let top = CmmData Data [([],[fty])] + let env' = funInsert name fty env1 + return (env', fun, nilOL, [top]) + + CmmCallee expr _ -> do + (env', v1, stmts, top) <- exprToVar env1 expr + let fty = funTy $ fsLit "dynamic" + let cast = case getVarType v1 of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + ty -> panic $ "genCall: Expr is of bad type for function" + ++ " call! (" ++ show (ty) ++ ")" + + (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) + return (env', v2, stmts `snocOL` s1, top) + + CmmPrim mop -> do + let name = cmmPrimOpFunctions mop + let lbl = mkForeignLabel name Nothing + ForeignLabelInExternalPackage IsFunction + getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv + + (env2, fptr, stmts2, top2) <- getFunPtr target + + let retStmt | ccTy == TailCall = unitOL $ Return Nothing + | ret == CmmNeverReturns = unitOL $ Unreachable + | otherwise = nilOL + + -- make the actual call + case retTy of + LMVoid -> do + let s1 = Expr $ Call ccTy fptr argVars fnAttrs + let allStmts = stmts1 `appOL` stmts2 `snocOL` s1 `appOL` retStmt + return (env2, allStmts, top1 ++ top2) + + _ -> do + let (creg, _) = ret_reg res + let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg) + let allStmts = stmts1 `appOL` stmts2 `appOL` stmts3 + (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs + if retTy == pLower (getVarType vreg) + then do + let s2 = Store v1 vreg + return (env3, allStmts `snocOL` s1 `snocOL` s2 + `appOL` retStmt, top1 ++ top2 ++ top3) + else do + let ty = pLower $ getVarType vreg + let op = case ty of + vt | isPointer vt -> LM_Bitcast + | isInt vt -> LM_Ptrtoint + | otherwise -> + panic $ "genCall: CmmReg bad match for" + ++ " returned type!" + + (v2, s2) <- doExpr ty $ Cast op v1 ty + let s3 = Store v2 vreg + return (env3, allStmts `snocOL` s1 `snocOL` s2 `snocOL` s3 + `appOL` retStmt, top1 ++ top2 ++ top3) + + +-- | Conversion of call arguments. +arg_vars :: LlvmEnv + -> HintedCmmActuals + -> ([LlvmVar], LlvmStatements, [LlvmCmmTop]) + -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop]) + +arg_vars env [] (vars, stmts, tops) + = return (env, vars, stmts, tops) + +arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops) + = do (env', v1, stmts', top') <- exprToVar env e + let op = case getVarType v1 of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + a -> panic $ "genCall: Can't cast llvmType to i8*! (" + ++ show a ++ ")" + + (v2, s1) <- doExpr (pLift i8) $ Cast op v1 (pLift i8) + arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top') + +arg_vars env (CmmHinted e _:rest) (vars, stmts, tops) + = do (env', v1, stmts', top') <- exprToVar env e + arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') + +-- | Decide what C function to use to implement a CallishMachOp +cmmPrimOpFunctions :: CallishMachOp -> FastString +cmmPrimOpFunctions mop + = case mop of + MO_F32_Exp -> fsLit "expf" + MO_F32_Log -> fsLit "logf" + MO_F32_Sqrt -> fsLit "sqrtf" + MO_F32_Pwr -> fsLit "powf" + + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + + MO_F64_Exp -> fsLit "exp" + MO_F64_Log -> fsLit "log" + MO_F64_Sqrt -> fsLit "sqrt" + MO_F64_Pwr -> fsLit "pow" + + MO_F64_Sin -> fsLit "sin" + MO_F64_Cos -> fsLit "cos" + MO_F64_Tan -> fsLit "tan" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + + a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")" + + +-- | Tail function calls +genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData + +-- Call to known function +genJump env (CmmLit (CmmLabel lbl)) = do + (env', vf, stmts, top) <- getHsFunc env lbl + (stgRegs, stgStmts) <- funEpilogue + let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs + let s2 = Return Nothing + return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) + + +-- Call to unknown function / address +genJump env expr = do + let fty = llvmFunTy + (env', vf, stmts, top) <- exprToVar env expr + + let cast = case getVarType vf of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + ty -> panic $ "genJump: Expr is of bad type for function call! (" + ++ show (ty) ++ ")" + + (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) + (stgRegs, stgStmts) <- funEpilogue + let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs + let s3 = Return Nothing + return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, + top) + + +-- | CmmAssign operation +-- +-- We use stack allocated variables for CmmReg. The optimiser will replace +-- these with registers when possible. +genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData +genAssign env reg val = do + let (env1, vreg, stmts1, top1) = getCmmReg env reg + (env2, vval, stmts2, top2) <- exprToVar env1 val + let s1 = Store vval vreg + return (env2, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) + + +-- | CmmStore operation +genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData +genStore env addr val = do + (env1, vaddr, stmts1, top1) <- exprToVar env addr + (env2, vval, stmts2, top2) <- exprToVar env1 val + if getVarType vaddr == llvmWord + then do + let vty = pLift $ getVarType vval + (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty + let s2 = Store vval vptr + return (env2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, + top1 ++ top2) + + else + panic $ "genStore: ptr not of word size! (" ++ show vaddr ++ ")" + + +-- | Unconditional branch +genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData +genBranch env id = + let label = blockIdToLlvm id + in return (env, unitOL $ Branch label, []) + + +-- | Conditional branch +genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData +genCondBranch env cond idT = do + idF <- getUniqueUs + let labelT = blockIdToLlvm idT + let labelF = LMLocalVar idF LMLabel + (env', vc, stmts, top) <- exprToVarOpt env i1Option cond + if getVarType vc == i1 + then do + let s1 = BranchIf vc labelT labelF + let s2 = MkLabel idF + return $ (env', stmts `snocOL` s1 `snocOL` s2, top) + else + panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")" + + +-- | Switch branch +-- +-- N.B. we remove Nothing's from the list of branches, as they are 'undefined'. +-- However, they may be defined one day, so we better document this behaviour. +genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData +genSwitch env cond maybe_ids = do + (env', vc, stmts, top) <- exprToVar env cond + let ty = getVarType vc + + let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ] + let labels = map (\(ix, b) -> (mkIntLit ix ty, blockIdToLlvm b)) pairs + -- out of range is undefied, so lets just branch to first label + let (_, defLbl) = head labels + + let s1 = Switch vc defLbl labels + return $ (env', stmts `snocOL` s1, top) + + +-- ----------------------------------------------------------------------------- +-- * CmmExpr code generation +-- + +-- | An expression conversion return data: +-- * LlvmEnv: The new enviornment +-- * LlvmVar: The var holding the result of the expression +-- * LlvmStatements: Any statements needed to evaluate the expression +-- * LlvmCmmTop: Any global data needed for this expression +type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmTop]) + +-- | Values which can be passed to 'exprToVar' to configure its +-- behaviour in certain circumstances. +data EOption = EOption { + -- | The expected LlvmType for the returned variable. + -- + -- Currently just used for determining if a comparison should return + -- a boolean (i1) or a int (i32/i64). + eoExpectedType :: Maybe LlvmType + } + +i1Option :: EOption +i1Option = EOption (Just i1) + +wordOption :: EOption +wordOption = EOption (Just llvmWord) + + +-- | Convert a CmmExpr to a list of LlvmStatements with the result of the +-- expression being stored in the returned LlvmVar. +exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData +exprToVar env = exprToVarOpt env wordOption + +exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData +exprToVarOpt env opt e = case e of + + CmmLit lit + -> genLit env lit + + CmmLoad e' ty + -> genCmmLoad env e' ty + + -- Cmmreg in expression is the value, so must load. If you want actual + -- reg pointer, call getCmmReg directly. + CmmReg r -> do + let (env', vreg, stmts, top) = getCmmReg env r + (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg + return (env', v1, stmts `snocOL` s1 , top) + + CmmMachOp op exprs + -> genMachOp env opt op exprs + + CmmRegOff r i + -> exprToVar env $ expandCmmReg (r, i) + + CmmStackSlot _ _ + -> panic "exprToVar: CmmStackSlot not supported!" + + +-- | Handle CmmMachOp expressions +genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData + +-- Unary Machop +genMachOp env _ op [x] = case op of + + MO_Not w -> + let all1 = mkIntLit (-1::Int) (widthToLlvmInt w) + in negate (widthToLlvmInt w) all1 LM_MO_Xor + + MO_S_Neg w -> + let all0 = mkIntLit (0::Int) (widthToLlvmInt w) + in negate (widthToLlvmInt w) all0 LM_MO_Sub + + MO_F_Neg w -> + let all0 = LMLitVar $ LMFloatLit 0 (widthToLlvmFloat w) + in negate (widthToLlvmFloat w) all0 LM_MO_Sub + + MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp + MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi + + MO_SS_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext + + MO_UU_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext + + MO_FF_Conv from to + -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext + + a -> panic $ "genMachOp: unmatched unary CmmMachOp! (" ++ show a ++ ")" + + where + negate ty v2 negOp = do + (env', vx, stmts, top) <- exprToVar env x + (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx + return (env', v1, stmts `snocOL` s1, top) + + fiConv ty convOp = do + (env', vx, stmts, top) <- exprToVar env x + (v1, s1) <- doExpr ty $ Cast convOp vx ty + return (env', v1, stmts `snocOL` s1, top) + + sameConv from ty reduce expand = do + x'@(env', vx, stmts, top) <- exprToVar env x + let sameConv' op = do + (v1, s1) <- doExpr ty $ Cast op vx ty + return (env', v1, stmts `snocOL` s1, top) + let toWidth = llvmWidthInBits ty + -- LLVM doesn't like trying to convert to same width, so + -- need to check for that as we do get cmm code doing it. + case widthInBits from of + w | w < toWidth -> sameConv' expand + w | w > toWidth -> sameConv' reduce + _w -> return x' + + +-- Binary MachOp +genMachOp env opt op [x, y] = case op of + + MO_Eq _ -> genBinComp opt LM_CMP_Eq + MO_Ne _ -> genBinComp opt LM_CMP_Ne + + MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt + MO_S_Ge _ -> genBinComp opt LM_CMP_Sge + MO_S_Lt _ -> genBinComp opt LM_CMP_Slt + MO_S_Le _ -> genBinComp opt LM_CMP_Sle + + MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt + MO_U_Ge _ -> genBinComp opt LM_CMP_Uge + MO_U_Lt _ -> genBinComp opt LM_CMP_Ult + MO_U_Le _ -> genBinComp opt LM_CMP_Ule + + MO_Add _ -> genBinMach LM_MO_Add + MO_Sub _ -> genBinMach LM_MO_Sub + MO_Mul _ -> genBinMach LM_MO_Mul + + MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!" + + MO_S_MulMayOflo w -> isSMulOK w x y + + MO_S_Quot _ -> genBinMach LM_MO_SDiv + MO_S_Rem _ -> genBinMach LM_MO_SRem + + MO_U_Quot _ -> genBinMach LM_MO_UDiv + MO_U_Rem _ -> genBinMach LM_MO_URem + + MO_F_Eq _ -> genBinComp opt LM_CMP_Feq + MO_F_Ne _ -> genBinComp opt LM_CMP_Fne + MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt + MO_F_Ge _ -> genBinComp opt LM_CMP_Fge + MO_F_Lt _ -> genBinComp opt LM_CMP_Flt + MO_F_Le _ -> genBinComp opt LM_CMP_Fle + + MO_F_Add _ -> genBinMach LM_MO_Add + MO_F_Sub _ -> genBinMach LM_MO_Sub + MO_F_Mul _ -> genBinMach LM_MO_Mul + MO_F_Quot _ -> genBinMach LM_MO_FDiv + + MO_And _ -> genBinMach LM_MO_And + MO_Or _ -> genBinMach LM_MO_Or + MO_Xor _ -> genBinMach LM_MO_Xor + MO_Shl _ -> genBinMach LM_MO_Shl + MO_U_Shr _ -> genBinMach LM_MO_LShr + MO_S_Shr _ -> genBinMach LM_MO_AShr + + a -> panic $ "genMachOp: unmatched binary CmmMachOp! (" ++ show a ++ ")" + + where + binLlvmOp ty binOp = do + (env1, vx, stmts1, top1) <- exprToVar env x + (env2, vy, stmts2, top2) <- exprToVar env1 y + if getVarType vx == getVarType vy + then do + (v1, s1) <- doExpr (ty vx) $ binOp vx vy + return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1, + top1 ++ top2) + + else do + -- XXX: Error. Continue anyway so we can debug the generated + -- ll file. + let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr) + let dx = Comment $ map fsLit $ cmmToStr x + let dy = Comment $ map fsLit $ cmmToStr y + (v1, s1) <- doExpr (ty vx) $ binOp vx vy + let allStmts = stmts1 `appOL` stmts2 `snocOL` dx + `snocOL` dy `snocOL` s1 + return (env2, v1, allStmts, top1 ++ top2) + + -- let o = case binOp vx vy of + -- Compare op _ _ -> show op + -- LlvmOp op _ _ -> show op + -- _ -> "unknown" + -- panic $ "genMachOp: comparison between different types (" + -- ++ o ++ " "++ show vx ++ ", " ++ show vy ++ ")" + -- ++ "\ne1: " ++ (show.llvmSDoc.PprCmm.pprExpr $ x) + -- ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr $ y) + + -- | Need to use EOption here as Cmm expects word size results from + -- comparisons while llvm return i1. Need to extend to llvmWord type + -- if expected + genBinComp opt cmp = do + ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp + + if getVarType v1 == i1 + then + case eoExpectedType opt of + Nothing -> + return ed + + Just t | t == i1 -> + return ed + + | isInt t -> do + (v2, s1) <- doExpr t $ Cast LM_Zext v1 t + return (env', v2, stmts `snocOL` s1, top) + + | otherwise -> + panic $ "genBinComp: Can't case i1 compare" + ++ "res to non int type " ++ show (t) + else + panic $ "genBinComp: Compare returned type other then i1! " + ++ (show $ getVarType v1) + + genBinMach op = binLlvmOp getVarType (LlvmOp op) + + -- | Detect if overflow will occur in signed multiply of the two + -- CmmExpr's. This is the LLVM assembly equivalent of the NCG + -- implementation. Its much longer due to type information/safety. + -- This should actually compile to only about 3 asm instructions. + isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData + isSMulOK _ x y = do + (env1, vx, stmts1, top1) <- exprToVar env x + (env2, vy, stmts2, top2) <- exprToVar env1 y + + let word = getVarType vx + let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx) + let shift = llvmWidthInBits word + let shift1 = mkIntLit (shift - 1) llvmWord + let shift2 = mkIntLit shift llvmWord + + if isInt word + then do + (x1, s1) <- doExpr word2 $ Cast LM_Sext vx word2 + (y1, s2) <- doExpr word2 $ Cast LM_Sext vy word2 + (r1, s3) <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1 + (rlow1, s4) <- doExpr word $ Cast LM_Trunc r1 word + (rlow2, s5) <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1 + (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2 + (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word + (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2 + let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4 + `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8 + return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts, + top1 ++ top2) + + else + panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")" + + +-- More then two expression, invalid! +genMachOp _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" + + +-- | Handle CmmLoad expression +genCmmLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData +genCmmLoad env e ty = do + (env', iptr, stmts, tops) <- exprToVar env e + let ety = getVarType iptr + case (isInt ety) of + True | llvmPtrBits == llvmWidthInBits ety -> do + let pty = LMPointer $ cmmToLlvmType ty + (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty + (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr + return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) + + | otherwise + -> pprPanic + ("exprToVar: can't cast to pointer as int not of " + ++ "pointer size!") + (PprCmm.pprExpr e <+> text ( + "Size of Ptr: " ++ show llvmPtrBits ++ + ", Size of var: " ++ show (llvmWidthInBits ety) ++ + ", Var: " ++ show iptr)) + + False -> panic "exprToVar: CmmLoad expression is not of type int!" + + +-- | Handle CmmReg expression +-- +-- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an +-- equivalent SSA form and avoids having to deal with Phi node insertion. +-- This is also the approach recommended by llvm developers. +getCmmReg :: LlvmEnv -> CmmReg -> ExprData +getCmmReg env r@(CmmLocal (LocalReg un _)) + = let exists = varLookup un env + + (newv, stmts) = allocReg r + nenv = varInsert un (pLower $ getVarType newv) env + in case exists of + Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, []) + Nothing -> (nenv, newv, stmts, []) + +getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, []) + + +-- | Allocate a CmmReg on the stack +allocReg :: CmmReg -> (LlvmVar, LlvmStatements) +allocReg (CmmLocal (LocalReg un ty)) + = let ty' = cmmToLlvmType ty + var = LMLocalVar un (LMPointer ty') + alc = Alloca ty' 1 + in (var, unitOL $ Assignment var alc) + +allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" + ++ " have been handled elsewhere!" + + +-- | Generate code for a literal +genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData +genLit env (CmmInt i w) + = return (env, mkIntLit i (LMInt $ widthInBits w), nilOL, []) + +genLit env (CmmFloat r w) + = return (env, LMLitVar $ LMFloatLit r (widthToLlvmFloat w), nilOL, []) + +genLit env cmm@(CmmLabel l) + = let label = strCLabel_llvm l + ty = funLookup label env + lmty = cmmToLlvmType $ cmmLitType cmm + in case ty of + -- Make generic external label defenition and then pointer to it + Nothing -> do + let glob@(var, _) = genStringLabelRef label + let ldata = [CmmData Data [([glob], [])]] + let env' = funInsert label (pLower $ getVarType var) env + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord + return (env', v1, unitOL s1, ldata) + -- Referenced data exists in this module, retrieve type and make + -- pointer to it. + Just ty' -> do + let var = LMGlobalVar label (LMPointer ty') ExternallyVisible + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord + return (env, v1, unitOL s1, []) + +genLit env (CmmLabelOff label off) = do + (env', vlbl, stmts, stat) <- genLit env (CmmLabel label) + let voff = mkIntLit off llvmWord + (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff + return (env', v1, stmts `snocOL` s1, stat) + +genLit env (CmmLabelDiffOff l1 l2 off) = do + (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1) + (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2) + let voff = mkIntLit off llvmWord + let ty1 = getVarType vl1 + let ty2 = getVarType vl2 + if (isInt ty1) && (isInt ty2) + && (llvmWidthInBits ty1 == llvmWidthInBits ty2) + + then do + (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 + (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff + return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, + stat1 ++ stat2) + + else + panic "genLit: CmmLabelDiffOff encountered with different label ty!" + +genLit env (CmmBlock b) + = genLit env (CmmLabel $ infoTblLbl b) + +genLit _ CmmHighStackMark + = panic "genStaticLit - CmmHighStackMark unsupported!" + + +-- ----------------------------------------------------------------------------- +-- * Misc +-- + +-- | Function prologue. Load STG arguments into variables for function. +funPrologue :: [LlvmStatement] +funPrologue = concat $ map getReg activeStgRegs + where getReg rr = + let reg = lmGlobalRegVar rr + arg = lmGlobalRegArg rr + alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 + store = Store arg reg + in [alloc, store] + + +-- | Function epilogue. Load STG variables to use as argument for call. +funEpilogue :: UniqSM ([LlvmVar], LlvmStatements) +funEpilogue = do + let loadExpr r = do + (v,s) <- doExpr (pLower $ getVarType r) $ Load r + return (v, unitOL s) + loads <- mapM (loadExpr . lmGlobalRegVar) activeStgRegs + let (vars, stmts) = unzip loads + return (vars, concatOL stmts) + + +-- | Get a function pointer to the CLabel specified. +-- +-- This is for Haskell functions, function type is assumed, so doesn't work +-- with foreign functions. +getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData +getHsFunc env lbl + = let fname = strCLabel_llvm lbl + ty = funLookup fname env + in case ty of + Just ty'@(LMFunction sig) -> do + -- Function in module in right form + let fun = LMGlobalVar fname ty' (funcLinkage sig) + 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) + 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 top = CmmData Data [([],[ty'])] + let env' = funInsert fname ty' env + return (env', fun, nilOL, [top]) + + +-- | Create a new local var +mkLocalVar :: LlvmType -> UniqSM LlvmVar +mkLocalVar ty = do + un <- getUniqueUs + return $ LMLocalVar un ty + + +-- | Execute an expression, assigning result to a var +doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement) +doExpr ty expr = do + v <- mkLocalVar ty + return (v, Assignment v expr) + + +-- | Expand CmmRegOff +expandCmmReg :: (CmmReg, Int) -> CmmExpr +expandCmmReg (reg, off) + = let width = typeWidth (cmmRegType reg) + voff = CmmLit $ CmmInt (fromIntegral off) width + in CmmMachOp (MO_Add width) [CmmReg reg, voff] + + +-- | Convert a block id into a appropriate Llvm label +blockIdToLlvm :: BlockId -> LlvmVar +blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel + + +-- | Create Llvm int Literal +mkIntLit :: Integral a => a -> LlvmType -> LlvmVar +mkIntLit i ty = LMLitVar $ LMIntLit (toInteger i) ty + + +-- | Error functions +panic :: String -> a +panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s + +pprPanic :: String -> SDoc -> a +pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d + diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs new file mode 100644 index 0000000000..a5b82aadf2 --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -0,0 +1,190 @@ +-- ---------------------------------------------------------------------------- +-- | Handle conversion of CmmData to LLVM code. +-- + +module LlvmCodeGen.Data ( + genLlvmData, resolveLlvmDatas, resolveLlvmData + ) where + +#include "HsVersions.h" + +import Llvm +import LlvmCodeGen.Base + +import BlockId +import CLabel +import Cmm + +import DynFlags +import FastString +import qualified Outputable + +import Data.Maybe + + +-- ---------------------------------------------------------------------------- +-- * Constants +-- + +-- | The string appended to a variable name to create its structure type alias +structStr :: LMString +structStr = fsLit "_struct" + +-- ---------------------------------------------------------------------------- +-- * Top level +-- + +-- | Pass a CmmStatic section to an equivalent Llvm code. Can't +-- complete this completely though as we need to pass all CmmStatic +-- sections before all references can be resolved. This last step is +-- done by 'resolveLlvmData'. +genLlvmData :: DynFlags -> (Section, [CmmStatic]) -> LlvmUnresData +genLlvmData _ ( _ , (CmmDataLabel lbl):xs) = + let static = map genData xs + label = strCLabel_llvm lbl + + types = map getStatTypes static + getStatTypes (Left x) = cmmToLlvmType $ cmmLitType x + getStatTypes (Right x) = getStatType x + + strucTy = LMStruct types + alias = LMAlias (label `appendFS` structStr) strucTy + in (lbl, alias, static) + +genLlvmData _ _ = panic "genLlvmData: CmmData section doesn't start with label!" + +resolveLlvmDatas :: DynFlags -> LlvmEnv -> [LlvmUnresData] -> [LlvmData] + -> (LlvmEnv, [LlvmData]) +resolveLlvmDatas _ env [] ldata + = (env, ldata) + +resolveLlvmDatas dflags env (udata : rest) ldata + = let (env', ndata) = resolveLlvmData dflags env udata + in resolveLlvmDatas dflags env' rest (ldata ++ [ndata]) + +-- | Fix up CLabel references now that we should have passed all CmmData. +resolveLlvmData :: DynFlags -> LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData) +resolveLlvmData _ env (lbl, alias, unres) = + let (env', static, refs) = resDatas env unres ([], []) + refs' = catMaybes refs + struct = Just $ LMStaticStruc static alias + label = strCLabel_llvm lbl + link = if (externallyVisibleCLabel lbl) + then ExternallyVisible else Internal + glob = LMGlobalVar label alias link + in (env', (refs' ++ [(glob, struct)], [alias])) + + +-- ---------------------------------------------------------------------------- +-- ** Resolve Data/CLabel references +-- + +-- | Resolve data list +resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [Maybe LMGlobal]) + -> (LlvmEnv, [LlvmStatic], [Maybe LMGlobal]) + +resDatas env [] (stat, glob) + = (env, stat, glob) + +resDatas env (cmm : rest) (stats, globs) + = let (env', nstat, nglob) = resData env cmm + in resDatas env' rest (stats ++ [nstat], globs ++ nglob) + +-- | Resolve an individual static label if it needs to be. +-- +-- We check the 'LlvmEnv' to see if the reference has been defined in this +-- module. If it has we can retrieve its type and make a pointer, otherwise +-- we introduce a generic external defenition for the referenced label and +-- then make a pointer. +resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [Maybe LMGlobal]) + +resData env (Right stat) = (env, stat, [Nothing]) + +resData env (Left cmm@(CmmLabel l)) = + let label = strCLabel_llvm l + ty = funLookup label env + lmty = cmmToLlvmType $ cmmLitType cmm + in case ty of + -- Make generic external label defenition and then pointer to it + Nothing -> + let glob@(var, _) = genStringLabelRef label + env' = funInsert label (pLower $ getVarType var) env + ptr = LMStaticPointer var + in (env', LMPtoI ptr lmty, [Just glob]) + -- Referenced data exists in this module, retrieve type and make + -- pointer to it. + Just ty' -> + let var = LMGlobalVar label (LMPointer ty') ExternallyVisible + ptr = LMStaticPointer var + in (env, LMPtoI ptr lmty, [Nothing]) + +resData env (Left (CmmLabelOff label off)) = + let (env', var, glob) = resData env (Left (CmmLabel label)) + offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord + in (env', LMAdd var offset, glob) + +resData env (Left (CmmLabelDiffOff l1 l2 off)) = + let (env1, var1, glob1) = resData env (Left (CmmLabel l1)) + (env2, var2, glob2) = resData env1 (Left (CmmLabel l2)) + var = LMSub var1 var2 + offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord + in (env2, LMAdd var offset, glob1 ++ glob2) + +resData _ _ = panic "resData: Non CLabel expr as left type!" + +-- ---------------------------------------------------------------------------- +-- * Generate static data +-- + +-- | Handle static data +-- Don't handle 'CmmAlign' or a 'CmmDataLabel'. +genData :: CmmStatic -> UnresStatic + +genData (CmmString str) = + let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str + ve = v ++ [LMStaticLit $ LMIntLit 0 i8] + in Right $ LMStaticArray ve (LMArray (length ve) i8) + +genData (CmmUninitialised bytes) + = Right $ LMUninitType (LMArray bytes i8) + +genData (CmmStaticLit lit) + = genStaticLit lit + +genData (CmmAlign _) + = panic "genData: Can't handle CmmAlign!" + +genData (CmmDataLabel _) + = panic "genData: Can't handle data labels not at top of data!" + + +-- | Generate Llvm code for a static literal. +-- +-- Will either generate the code or leave it unresolved if it is a 'CLabel' +-- which isn't yet known. +genStaticLit :: CmmLit -> UnresStatic +genStaticLit (CmmInt i w) + = Right $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) + +genStaticLit (CmmFloat r w) + = Right $ LMStaticLit (LMFloatLit r (widthToLlvmFloat w)) + +-- Leave unresolved, will fix later +genStaticLit c@(CmmLabel _ ) = Left $ c +genStaticLit c@(CmmLabelOff _ _) = Left $ c +genStaticLit c@(CmmLabelDiffOff _ _ _) = Left $ c + +genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b + +genStaticLit (CmmHighStackMark) + = panic "genStaticLit: CmmHighStackMark unsupported!" + + +-- ----------------------------------------------------------------------------- +-- * Misc +-- + +-- | Error Function +panic :: String -> a +panic s = Outputable.panic $ "LlvmCodeGen.Data." ++ s + diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs new file mode 100644 index 0000000000..bccc336093 --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -0,0 +1,91 @@ +-- ---------------------------------------------------------------------------- +-- | Pretty print helpers for the LLVM Code generator. +-- + +module LlvmCodeGen.Ppr ( + pprLlvmHeader, pprLlvmCmmTop, pprLlvmData + ) where + +#include "HsVersions.h" + +import Llvm +import LlvmCodeGen.Base +import LlvmCodeGen.Data + +import CLabel +import Cmm + +import DynFlags +import Pretty +import Unique + +-- ---------------------------------------------------------------------------- +-- * Top level +-- + +-- | LLVM module layout description for the host target +moduleLayout :: Doc +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\"") +#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\"") +#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\"") + +#else /* Not i386 */ + -- FIX: Other targets + empty +#endif + +#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 + in ppLlvmFunction fun + ) + + +-- | Pretty print LLVM data code +pprLlvmData :: DynFlags -> LlvmData -> Doc +pprLlvmData _ (globals, types ) = + let globals' = ppLlvmGlobals globals + types' = ppLlvmTypes types + in types' $+$ globals' + + +-- | Pretty print CmmStatic +pprCmmStatic :: DynFlags -> [CmmStatic] -> Doc +pprCmmStatic dflags stat + = let unres = genLlvmData dflags (Data,stat) + (_, ldata) = resolveLlvmData dflags initLlvmEnv unres + in pprLlvmData dflags ldata + diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs new file mode 100644 index 0000000000..b731a863e2 --- /dev/null +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -0,0 +1,54 @@ +-- ---------------------------------------------------------------------------- +-- | Deal with Cmm registers +-- + +module LlvmCodeGen.Regs ( + lmGlobalRegArg, lmGlobalRegVar + ) where + +#include "HsVersions.h" + +import Llvm + +import CmmExpr +import Outputable ( panic ) +import FastString + +-- | Get the LlvmVar function variable storing the real register +lmGlobalRegVar :: GlobalReg -> LlvmVar +lmGlobalRegVar = lmGlobalReg "_Var" + +-- | Get the LlvmVar function argument storing the real register +lmGlobalRegArg :: GlobalReg -> LlvmVar +lmGlobalRegArg = (pVarLower . lmGlobalReg "_Arg") + +{- Need to make sure the names here can't conflict with the unique generated + names. Uniques generated names containing only base62 chars. So using say + the '_' char guarantees this. +-} +lmGlobalReg :: String -> GlobalReg -> LlvmVar +lmGlobalReg suf reg + = case reg of + BaseReg -> wordGlobal $ "Base" ++ suf + Sp -> wordGlobal $ "Sp" ++ suf + Hp -> wordGlobal $ "Hp" ++ suf + VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf + VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf + VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf + VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf + VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf + VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf + SpLim -> wordGlobal $ "SpLim" ++ suf + FloatReg 1 -> floatGlobal $"F1" ++ suf + FloatReg 2 -> floatGlobal $"F2" ++ suf + FloatReg 3 -> floatGlobal $"F3" ++ suf + FloatReg 4 -> floatGlobal $"F4" ++ suf + DoubleReg 1 -> doubleGlobal $ "D1" ++ suf + DoubleReg 2 -> doubleGlobal $ "D2" ++ suf + _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) + ++ ") not supported!" + where + wordGlobal name = LMNLocalVar (fsLit name) llvmWordPtr + floatGlobal name = LMNLocalVar (fsLit name) $ pLift LMFloat + doubleGlobal name = LMNLocalVar (fsLit name) $ pLift LMDouble + diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 83f23cfbc3..40f4f11a81 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -9,10 +9,14 @@ module CodeOutput( codeOutput, outputForeignStubs ) where #include "HsVersions.h" #ifndef OMIT_NATIVE_CODEGEN -import UniqSupply ( mkSplitUniqSupply ) import AsmCodeGen ( nativeCodeGen ) #endif +import UniqSupply ( mkSplitUniqSupply ) +#ifndef GHCI_TABLES_NEXT_TO_CODE +import qualified LlvmCodeGen ( llvmCodeGen ) +#endif + #ifdef JAVA import JavaGen ( javaGen ) import qualified PrintJava @@ -81,6 +85,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC HscInterpreted -> return (); HscAsm -> outputAsm dflags filenm flat_abstractC; HscC -> outputC dflags filenm flat_abstractC pkg_deps; + HscLlvm -> outputLlvm dflags filenm flat_abstractC; HscJava -> #ifdef JAVA outputJava dflags filenm mod_name tycons core_binds; @@ -168,6 +173,30 @@ outputAsm _ _ _ %************************************************************************ %* * +\subsection{LLVM} +%* * +%************************************************************************ + +\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 +\end{code} + + +%************************************************************************ +%* * \subsection{Java} %* * %************************************************************************ diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index eb64134626..398da79b79 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -80,6 +80,9 @@ data Phase | SplitMangle -- after mangler if splitting | SplitAs | As + | LlvmAs -- LLVM assembly to bitcode file + | LlvmOpt -- Run LLVM opt tool over llvm assembly + | LlvmLlc -- LLVM bitcode to native assembly | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code @@ -109,6 +112,9 @@ eqPhase Mangle Mangle = True eqPhase SplitMangle SplitMangle = True eqPhase SplitAs SplitAs = True eqPhase As As = True +eqPhase LlvmAs LlvmAs = True +eqPhase LlvmOpt LlvmOpt = True +eqPhase LlvmLlc LlvmLlc = True eqPhase CmmCpp CmmCpp = True eqPhase Cmm Cmm = True eqPhase StopLn StopLn = True @@ -133,6 +139,9 @@ nextPhase HCc = Mangle nextPhase Mangle = SplitMangle nextPhase SplitMangle = As nextPhase As = SplitAs +nextPhase LlvmAs = LlvmOpt +nextPhase LlvmOpt = LlvmLlc +nextPhase LlvmLlc = As nextPhase SplitAs = StopLn nextPhase Ccpp = As nextPhase Cc = As @@ -160,6 +169,9 @@ startPhase "raw_s" = Mangle startPhase "split_s" = SplitMangle startPhase "s" = As startPhase "S" = As +startPhase "ll" = LlvmAs +startPhase "bc" = LlvmOpt +startPhase "opt_bc" = LlvmLlc startPhase "o" = StopLn startPhase "cmm" = CmmCpp startPhase "cmmcpp" = Cmm @@ -184,6 +196,9 @@ phaseInputExt Cc = "c" phaseInputExt Mangle = "raw_s" phaseInputExt SplitMangle = "split_s" -- not really generated phaseInputExt As = "s" +phaseInputExt LlvmAs = "ll" +phaseInputExt LlvmOpt = "bc" +phaseInputExt LlvmLlc = "opt_bc" phaseInputExt SplitAs = "split_s" -- not really generated phaseInputExt CmmCpp = "cmm" phaseInputExt Cmm = "cmmcpp" @@ -195,7 +210,7 @@ haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, haskellish_src_suffixes = haskellish_user_src_suffixes ++ [ "hspp", "hscpp", "hcr", "cmm" ] haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"] -cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S" ] +cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "opt_bc" ] extcoreish_suffixes = [ "hcr" ] -- Will not be deleted as temp files: haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ] diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index c6d3d0a47c..7274f2a9b2 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -605,6 +605,7 @@ getOutputFilename stop_phase output basename keep_hc = dopt Opt_KeepHcFiles dflags keep_raw_s = dopt Opt_KeepRawSFiles dflags keep_s = dopt Opt_KeepSFiles dflags + keep_bc = dopt Opt_KeepLlvmFiles dflags myPhaseInputExt HCc = hcsuf myPhaseInputExt StopLn = osuf @@ -615,11 +616,13 @@ getOutputFilename stop_phase output basename -- sometimes, we keep output from intermediate stages keep_this_output = case next_phase of - StopLn -> True - Mangle | keep_raw_s -> True - As | keep_s -> True - HCc | keep_hc -> True - _other -> False + StopLn -> True + Mangle | keep_raw_s -> True + As | keep_s -> True + LlvmAs | keep_bc -> True + LlvmOpt | keep_bc -> True + HCc | keep_hc -> True + _other -> False suffix = myPhaseInputExt next_phase @@ -1232,6 +1235,77 @@ runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc return (StopLn, dflags, maybe_loc, output_fn) + +----------------------------------------------------------------------------- +-- LlvmAs phase + +runPhase LlvmAs _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = liftIO $ do + let dflags = hsc_dflags hsc_env + let la_opts = getOpts dflags opt_la + + output_fn <- get_output_fn dflags LlvmOpt maybe_loc + + SysTools.runLlvmAs dflags + (map SysTools.Option la_opts + ++ [ SysTools.FileOption "" input_fn, + SysTools.Option "-o", SysTools.FileOption "" output_fn]) + + return (LlvmOpt, dflags, maybe_loc, output_fn) + + +----------------------------------------------------------------------------- +-- LlvmOpt phase + +runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = liftIO $ do + let dflags = hsc_dflags hsc_env + let lo_opts = getOpts dflags opt_lo + let opt_lvl = max 0 (min 2 $ optLevel dflags) + + -- only run if > 0 OR opt options given by user + if opt_lvl /= 0 || lo_opts /= [] + then do + output_fn <- get_output_fn dflags LlvmLlc maybe_loc + + SysTools.runLlvmOpt dflags + (map SysTools.Option lo_opts + ++ [ SysTools.FileOption "" input_fn, + SysTools.Option (llvmOpts !! opt_lvl), + SysTools.Option "-o", + SysTools.FileOption "" output_fn]) + + return (LlvmLlc, dflags, maybe_loc, output_fn) + + else + return (LlvmLlc, dflags, maybe_loc, input_fn) + where + llvmOpts = ["-O1", "-O2", "-O3"] + + +----------------------------------------------------------------------------- +-- LlvmLlc phase + +runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc + = liftIO $ do + let dflags = hsc_dflags hsc_env + let lc_opts = getOpts dflags opt_lc + let opt_lvl = max 0 (min 2 $ optLevel dflags) + + output_fn <- get_output_fn dflags As maybe_loc + + SysTools.runLlvmLlc dflags + (map SysTools.Option lc_opts + ++ [ -- SysTools.Option "-tailcallopt", + SysTools.Option (llvmOpts !! opt_lvl), + SysTools.FileOption "" input_fn, + SysTools.Option "-o", SysTools.FileOption "" output_fn]) + + return (As, dflags, maybe_loc, output_fn) + where + llvmOpts = ["", "-O2", "-O3"] + + -- warning suppression runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc = panic ("runPhase: don't know how to run phase " ++ show other) @@ -1832,6 +1906,7 @@ hscNextPhase dflags _ hsc_lang = HscC -> HCc HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle | otherwise -> As + HscLlvm -> LlvmAs HscNothing -> StopLn HscInterpreted -> StopLn _other -> StopLn diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 1f83d29c34..70b135592e 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -107,6 +107,8 @@ data DynFlag | Opt_D_dump_asm_conflicts | Opt_D_dump_asm_stats | Opt_D_dump_asm_expanded + | Opt_D_dump_llvm + | Opt_D_dump_llvm_opt | Opt_D_dump_cpranal | Opt_D_dump_deriv | Opt_D_dump_ds @@ -332,6 +334,7 @@ data DynFlag | Opt_KeepRawSFiles | Opt_KeepTmpFiles | Opt_KeepRawTokenStream + | Opt_KeepLlvmFiles deriving (Eq, Show) @@ -420,6 +423,9 @@ data DynFlags = DynFlags { opt_a :: [String], opt_l :: [String], opt_windres :: [String], + opt_la :: [String], -- LLVM: llvm-as assembler + opt_lo :: [String], -- LLVM: llvm optimiser + opt_lc :: [String], -- LLVM: llc static compiler -- commands for particular phases pgm_L :: String, @@ -434,6 +440,9 @@ data DynFlags = DynFlags { pgm_T :: String, pgm_sysman :: String, pgm_windres :: String, + pgm_la :: (String,[Option]), -- LLVM: llvm-as assembler + pgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser + pgm_lc :: (String,[Option]), -- LLVM: llc static compiler -- For ghc -M depMakefile :: FilePath, @@ -498,6 +507,7 @@ wayNames = map wayName . ways data HscTarget = HscC -- ^ Generate C code. | HscAsm -- ^ Generate assembly using the native code generator. + | HscLlvm -- ^ Generate assembly using the llvm code generator. | HscJava -- ^ Generate Java bytecode. | HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory') | HscNothing -- ^ Don't generate any code. See notes above. @@ -507,6 +517,7 @@ data HscTarget isObjectTarget :: HscTarget -> Bool isObjectTarget HscC = True isObjectTarget HscAsm = True +isObjectTarget HscLlvm = True isObjectTarget _ = False -- | The 'GhcMode' tells us whether we're doing multi-module @@ -656,6 +667,9 @@ defaultDynFlags = opt_m = [], opt_l = [], opt_windres = [], + opt_la = [], + opt_lo = [], + opt_lc = [], extraPkgConfs = [], packageFlags = [], @@ -682,6 +696,9 @@ defaultDynFlags = pgm_T = panic "defaultDynFlags: No pgm_T", pgm_sysman = panic "defaultDynFlags: No pgm_sysman", pgm_windres = panic "defaultDynFlags: No pgm_windres", + pgm_la = panic "defaultDynFlags: No pgm_la", + pgm_lo = panic "defaultDynFlags: No pgm_lo", + pgm_lc = panic "defaultDynFlags: No pgm_lc", -- end of initSysTools values -- ghc -M values depMakefile = "Makefile", @@ -770,8 +787,9 @@ getVerbFlag dflags setObjectDir, setHiDir, setStubDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, setPgmP, setPgmL, setPgmF, setPgmc, setPgmm, setPgms, setPgma, setPgml, setPgmdll, setPgmwindres, - addOptL, addOptP, addOptF, addOptc, addOptm, addOpta, addOptl, addOptwindres, - addCmdlineFramework, addHaddockOpts + setPgmla, setPgmlo, setPgmlc, + addOptL, addOptP, addOptF, addOptc, addOptm, addOpta, addOptl, addOptwindres, addOptla, addOptlo, + addOptlc, addCmdlineFramework, addHaddockOpts :: String -> DynFlags -> DynFlags setOutputFile, setOutputHi, setDumpPrefixForce :: Maybe String -> DynFlags -> DynFlags @@ -815,6 +833,9 @@ setPgma f d = d{ pgm_a = (f,[])} setPgml f d = d{ pgm_l = (f,[])} setPgmdll f d = d{ pgm_dll = (f,[])} setPgmwindres f d = d{ pgm_windres = f} +setPgmla f d = d{ pgm_la = (f,[])} +setPgmlo f d = d{ pgm_lo = (f,[])} +setPgmlc f d = d{ pgm_lc = (f,[])} addOptL f d = d{ opt_L = f : opt_L d} addOptP f d = d{ opt_P = f : opt_P d} @@ -824,6 +845,9 @@ addOptm f d = d{ opt_m = f : opt_m d} addOpta f d = d{ opt_a = f : opt_a d} addOptl f d = d{ opt_l = f : opt_l d} addOptwindres f d = d{ opt_windres = f : opt_windres d} +addOptla f d = d{ opt_la = f : opt_la d} +addOptlo f d = d{ opt_lo = f : opt_lo d} +addOptlc f d = d{ opt_lc = f : opt_lc d} setDepMakefile :: FilePath -> DynFlags -> DynFlags setDepMakefile f d = d { depMakefile = deOptDep f } @@ -1018,6 +1042,11 @@ dynamic_flags = [ , Flag "v" (OptIntSuffix setVerbosity) Supported ------- Specific phases -------------------------------------------- + -- need to appear before -pgmL to be parsed as LLVM flags. + , Flag "pgmla" (HasArg (upd . setPgmla)) Supported + , Flag "pgmlo" (HasArg (upd . setPgmlo)) Supported + , Flag "pgmlc" (HasArg (upd . setPgmlc)) Supported + , Flag "pgmL" (HasArg (upd . setPgmL)) Supported , Flag "pgmP" (HasArg (upd . setPgmP)) Supported , Flag "pgmF" (HasArg (upd . setPgmF)) Supported @@ -1029,6 +1058,11 @@ dynamic_flags = [ , Flag "pgmdll" (HasArg (upd . setPgmdll)) Supported , Flag "pgmwindres" (HasArg (upd . setPgmwindres)) Supported + -- need to appear before -optl/-opta to be parsed as LLVM flags. + , Flag "optla" (HasArg (upd . addOptla)) Supported + , Flag "optlo" (HasArg (upd . addOptlo)) Supported + , Flag "optlc" (HasArg (upd . addOptlc)) Supported + , Flag "optL" (HasArg (upd . addOptL)) Supported , Flag "optP" (HasArg (upd . addOptP)) Supported , Flag "optF" (HasArg (upd . addOptF)) Supported @@ -1102,6 +1136,8 @@ dynamic_flags = [ , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) Supported , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles)) Supported , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles)) Supported + , Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) Supported + , Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) Supported -- This only makes sense as plural , Flag "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) Supported @@ -1162,6 +1198,11 @@ dynamic_flags = [ Supported , Flag "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) Supported + , Flag "ddump-llvm" (NoArg (do { setObjTarget HscLlvm + ; setDumpFlag' Opt_D_dump_llvm})) + Supported + , Flag "ddump-opt-llvm" (setDumpFlag Opt_D_dump_llvm_opt) + Supported , Flag "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) Supported , Flag "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) @@ -1384,6 +1425,7 @@ dynamic_flags = [ , Flag "fasm" (NoArg (setObjTarget HscAsm)) Supported , Flag "fvia-c" (NoArg (setObjTarget HscC)) Supported , Flag "fvia-C" (NoArg (setObjTarget HscC)) Supported + , Flag "fllvm" (NoArg (setObjTarget HscLlvm)) Supported , Flag "fno-code" (NoArg (do upd $ \d -> d{ ghcLink=NoLink } setTarget HscNothing)) @@ -1787,9 +1829,12 @@ unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) -------------------------- setDumpFlag :: DynFlag -> OptKind DynP -setDumpFlag dump_flag - = NoArg (do { setDynFlag dump_flag - ; when want_recomp forceRecompile }) +setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) + +setDumpFlag' :: DynFlag -> DynP () +setDumpFlag' dump_flag + = do { setDynFlag dump_flag + ; when want_recomp forceRecompile } where -- Certain dumpy-things are really interested in what's going -- on during recompilation checking, so in those cases we @@ -2185,6 +2230,7 @@ compilerInfo = [("Project name", String cProjectName), ("Have interpreter", String cGhcWithInterpreter), ("Object splitting", String cSplitObjs), ("Have native code generator", String cGhcWithNativeCodeGen), + ("Have llvm code generator", String cGhcWithLlvmCodeGen), ("Support SMP", String cGhcWithSMP), ("Unregisterised", String cGhcUnregisterised), ("Tables next to code", String cGhcEnableTablesNextToCode), diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index c479a66ab5..29889db4f3 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -18,6 +18,9 @@ module SysTools ( runAs, runLink, -- [Option] -> IO () runMkDLL, runWindres, + runLlvmAs, + runLlvmOpt, + runLlvmLlc, touch, -- String -> String -> IO () copy, @@ -219,6 +222,11 @@ initSysTools mbMinusB dflags0 ; let as_prog = gcc_prog ld_prog = gcc_prog + -- figure out llvm location. (TODO: Acutally implement). + ; let la_prog = "llvm-as" + lc_prog = "llc" + lo_prog = "opt" + ; return dflags1{ ghcUsagePath = ghc_usage_msg_path, ghciUsagePath = ghci_usage_msg_path, @@ -235,7 +243,10 @@ initSysTools mbMinusB dflags0 pgm_dll = (mkdll_prog,mkdll_args), pgm_T = touch_path, pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan", - pgm_windres = windres_path + pgm_windres = windres_path, + pgm_la = (la_prog,[]), + pgm_lo = (lo_prog,[]), + pgm_lc = (lc_prog,[]) -- Hans: this isn't right in general, but you can -- elaborate it in the same way as the others } @@ -381,6 +392,21 @@ runAs dflags args = do mb_env <- getGccEnv args1 runSomethingFiltered dflags id "Assembler" p args1 mb_env +runLlvmAs :: DynFlags -> [Option] -> IO () +runLlvmAs dflags args = do + let (p,args0) = pgm_la dflags + runSomething dflags "LLVM Assembler" p (args0++args) + +runLlvmOpt :: DynFlags -> [Option] -> IO () +runLlvmOpt dflags args = do + let (p,args0) = pgm_lo dflags + runSomething dflags "LLVM Optimiser" p (args0++args) + +runLlvmLlc :: DynFlags -> [Option] -> IO () +runLlvmLlc dflags args = do + let (p,args0) = pgm_lc dflags + runSomething dflags "LLVM Compiler" p (args0++args) + runLink :: DynFlags -> [Option] -> IO () runLink dflags args = do let (p,args0) = pgm_l dflags diff --git a/compiler/nativeGen/Alpha/Regs.hs b/compiler/nativeGen/Alpha/Regs.hs index 2d85c5f141..ee490509de 100644 --- a/compiler/nativeGen/Alpha/Regs.hs +++ b/compiler/nativeGen/Alpha/Regs.hs @@ -27,7 +27,6 @@ import RegsBase import BlockId import Cmm -import CgUtils ( get_GlobalReg_addr ) import CLabel ( CLabel, mkMainCapabilityLabel ) import Pretty import Outputable ( Outputable(..), pprPanic, panic ) diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index d79fbb69e0..d73cb89984 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -73,6 +73,7 @@ import RegClass import NCGMonad import BlockId +import CgUtils ( fixStgRegisters ) import Cmm import CmmOpt ( cmmMiniInline, cmmMachOpFold ) import PprCmm @@ -278,9 +279,9 @@ cmmNativeGen dflags us cmm count = do -- rewrite assignments to global regs - let (fixed_cmm, usFix) = - {-# SCC "fixAssignsTop" #-} - initUs us $ fixAssignsTop cmm + let fixed_cmm = + {-# SCC "fixStgRegisters" #-} + fixStgRegisters cmm -- cmm to cmm optimisations let (opt_cmm, imports) = @@ -294,13 +295,12 @@ cmmNativeGen dflags us cmm count -- generate native code from cmm let ((native, lastMinuteImports), usGen) = {-# SCC "genMachCode" #-} - initUs usFix $ genMachCode dflags opt_cmm + initUs us $ genMachCode dflags opt_cmm dumpIfSet_dyn dflags Opt_D_dump_asm_native "Native code" (vcat $ map (docToSDoc . pprNatCmmTop) native) - -- tag instructions with register liveness information let (withLiveness, usLive) = {-# SCC "regLiveness" #-} @@ -309,7 +309,6 @@ cmmNativeGen dflags us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" (vcat $ map ppr withLiveness) - -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- @@ -323,7 +322,6 @@ cmmNativeGen dflags us cmm count emptyUFM $ allocatableRegs - -- do the graph coloring register allocation let ((alloced, regAllocStats), usAlloc) = {-# SCC "RegAlloc" #-} @@ -697,44 +695,6 @@ genMachCode dflags cmm_top else pprPanic "genMachCode: nonzero final delta" (int final_delta) } --- ----------------------------------------------------------------------------- --- Fixup assignments to global registers so that they assign to --- locations within the RegTable, if appropriate. - --- Note that we currently don't fixup reads here: they're done by --- the generic optimiser below, to avoid having two separate passes --- over the Cmm. - -fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop -fixAssignsTop top@(CmmData _ _) = returnUs top -fixAssignsTop (CmmProc info lbl params (ListGraph blocks)) = - mapUs fixAssignsBlock blocks `thenUs` \ blocks' -> - returnUs (CmmProc info lbl params (ListGraph blocks')) - -fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock -fixAssignsBlock (BasicBlock id stmts) = - fixAssigns stmts `thenUs` \ stmts' -> - returnUs (BasicBlock id stmts') - -fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt] -fixAssigns stmts = - mapUs fixAssign stmts `thenUs` \ stmtss -> - returnUs (concat stmtss) - -fixAssign :: CmmStmt -> UniqSM [CmmStmt] -fixAssign (CmmAssign (CmmGlobal reg) src) - | Left realreg <- reg_or_addr - = returnUs [CmmAssign (CmmGlobal reg) src] - | Right baseRegAddr <- reg_or_addr - = returnUs [CmmStore baseRegAddr src] - -- Replace register leaves with appropriate StixTrees for - -- the given target. GlobalRegs which map to a reg on this - -- arch are left unchanged. Assigning to BaseReg is always - -- illegal, so we check for that. - where - reg_or_addr = get_GlobalReg_reg_or_addr reg - -fixAssign other_stmt = returnUs [other_stmt] -- ----------------------------------------------------------------------------- -- Generic Cmm optimiser @@ -745,10 +705,7 @@ Here we do: (a) Constant folding (b) Simple inlining: a temporary which is assigned to and then used, once, can be shorted. - (c) Replacement of references to GlobalRegs which do not have - machine registers by the appropriate memory load (eg. - Hp ==> *(BaseReg + 34) ). - (d) Position independent code and dynamic linking + (c) Position independent code and dynamic linking (i) introduce the appropriate indirections and position independent refs (ii) compile a list of imported symbols @@ -883,42 +840,8 @@ cmmExprConFold referenceKind expr CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) #endif - CmmReg (CmmGlobal mid) - -- Replace register leaves with appropriate StixTrees for - -- the given target. MagicIds which map to a reg on this - -- arch are left unchanged. For the rest, BaseReg is taken - -- to mean the address of the reg table in MainCapability, - -- and for all others we generate an indirection to its - -- location in the register table. - -> case get_GlobalReg_reg_or_addr mid of - Left realreg -> return expr - Right baseRegAddr - -> case mid of - BaseReg -> cmmExprConFold DataReference baseRegAddr - other -> cmmExprConFold DataReference - (CmmLoad baseRegAddr (globalRegType mid)) - -- eliminate zero offsets - CmmRegOff reg 0 - -> cmmExprConFold referenceKind (CmmReg reg) - - CmmRegOff (CmmGlobal mid) offset - -- RegOf leaves are just a shorthand form. If the reg maps - -- to a real reg, we keep the shorthand, otherwise, we just - -- expand it and defer to the above code. - -> case get_GlobalReg_reg_or_addr mid of - Left realreg -> return expr - Right baseRegAddr - -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordWidth) [ - CmmReg (CmmGlobal mid), - CmmLit (CmmInt (fromIntegral offset) - wordWidth)]) other -> return other --- ----------------------------------------------------------------------------- --- Utils - -bind f x = x $! f - \end{code} diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index a1b55ce412..8a4228b578 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -180,12 +180,12 @@ getRegisterReg (CmmLocal (LocalReg u pk)) = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) getRegisterReg (CmmGlobal mid) - = case get_GlobalReg_reg_or_addr mid of - Left reg -> reg - _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) - -- By this stage, the only MagicIds remaining should be the - -- ones which map to a real machine register on this - -- platform. Hence ... + = case globalRegMaybe mid of + Just reg -> reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence ... {- diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index d649d847f1..e00dd7e496 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -40,7 +40,6 @@ module PPC.Regs ( -- horrow show freeReg, globalRegMaybe, - get_GlobalReg_reg_or_addr, allocatableRegs ) @@ -55,7 +54,6 @@ import Reg import RegClass import Size -import CgUtils ( get_GlobalReg_addr ) import BlockId import Cmm import CLabel ( CLabel ) @@ -595,20 +593,6 @@ globalRegMaybe _ = panic "PPC.Regs.globalRegMaybe: not defined" #endif /* powerpc_TARGET_ARCH */ --- We map STG registers onto appropriate CmmExprs. Either they map --- to real machine registers or stored as offsets from BaseReg. Given --- a GlobalReg, get_GlobalReg_reg_or_addr produces either the real --- register it is in, on this platform, or a CmmExpr denoting the --- address in the register table holding it. --- (See also get_GlobalReg_addr in CgUtils.) - -get_GlobalReg_reg_or_addr :: GlobalReg -> Either Reg CmmExpr -get_GlobalReg_reg_or_addr mid - = case globalRegMaybe mid of - Just rr -> Left rr - Nothing -> Right (get_GlobalReg_addr mid) - - -- allocatableRegs is allMachRegNos with the fixed-use regs removed. -- i.e., these are the regs for which we are prepared to allow the -- register allocator to attempt to map VRegs to. diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index 54bbf9b51a..c85d8065ad 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -18,6 +18,7 @@ import SPARC.Instr import SPARC.Cond import SPARC.AddrMode import SPARC.Regs +import SPARC.RegPlate import Size import Reg @@ -95,11 +96,11 @@ getRegisterReg (CmmLocal (LocalReg u pk)) = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) getRegisterReg (CmmGlobal mid) - = case get_GlobalReg_reg_or_addr mid of - Left rr -> RegReal rr - - _ -> pprPanic "SPARC.CodeGen.Base.getRegisterReg: global is in memory" - (ppr $ CmmGlobal mid) + = case globalRegMaybe mid of + Just reg -> RegReal reg + Nothing -> pprPanic + "SPARC.CodeGen.Base.getRegisterReg: global is in memory" + (ppr $ CmmGlobal mid) -- Expand CmmRegOff. ToDo: should we do it this way around, or convert diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs index cd19138aa4..98151ecfa5 100644 --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -18,7 +18,6 @@ module SPARC.Regs ( -- allocatable allocatableRegs, - get_GlobalReg_reg_or_addr, -- args argRegs, @@ -38,9 +37,7 @@ import Reg import RegClass import Size -import Cmm import PprCmm () -import CgUtils ( get_GlobalReg_addr ) import Unique import Outputable @@ -214,21 +211,6 @@ allocatableRegs in filter isFree allRealRegs - --- We map STG registers onto appropriate CmmExprs. Either they map --- to real machine registers or stored as offsets from BaseReg. Given --- a GlobalReg, get_GlobalReg_reg_or_addr produces either the real --- register it is in, on this platform, or a CmmExpr denoting the --- address in the register table holding it. --- (See also get_GlobalReg_addr in CgUtils.) - -get_GlobalReg_reg_or_addr :: GlobalReg -> Either RealReg CmmExpr -get_GlobalReg_reg_or_addr mid - = case globalRegMaybe mid of - Just rr -> Left rr - Nothing -> Right (get_GlobalReg_addr mid) - - -- | The registers to place arguments for function calls, -- for some number of arguments. -- diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 2698406aac..89a26a9772 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -226,12 +226,12 @@ getRegisterReg use_sse2 (CmmLocal (LocalReg u pk)) else RegVirtual (mkVirtualReg u sz) getRegisterReg _ (CmmGlobal mid) - = case get_GlobalReg_reg_or_addr mid of - Left reg -> RegReal $ reg - _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) - -- By this stage, the only MagicIds remaining should be the - -- ones which map to a real machine register on this - -- platform. Hence ... + = case globalRegMaybe mid of + Just reg -> RegReal $ reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence ... -- | Memory addressing modes passed up the tree. diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index a04e854787..b9a23a6510 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -40,7 +40,6 @@ module X86.Regs ( freeReg, globalRegMaybe, - get_GlobalReg_reg_or_addr, allocatableRegs ) @@ -54,7 +53,6 @@ where import Reg import RegClass -import CgUtils ( get_GlobalReg_addr ) import BlockId import Cmm import CLabel ( CLabel ) @@ -662,20 +660,6 @@ callClobberedRegs = panic "X86.Regs.globalRegMaybe: not defined" #endif --- We map STG registers onto appropriate CmmExprs. Either they map --- to real machine registers or stored as offsets from BaseReg. Given --- a GlobalReg, get_GlobalReg_reg_or_addr produces either the real --- register it is in, on this platform, or a CmmExpr denoting the --- address in the register table holding it. --- (See also get_GlobalReg_addr in CgUtils.) - -get_GlobalReg_reg_or_addr :: GlobalReg -> Either RealReg CmmExpr -get_GlobalReg_reg_or_addr mid - = case globalRegMaybe mid of - Just rr -> Left rr - Nothing -> Right (get_GlobalReg_addr mid) - - -- allocatableRegs is allMachRegNos with the fixed-use regs removed. -- i.e., these are the regs for which we are prepared to allow the -- register allocator to attempt to map VRegs to. diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index fdb7ce5f23..935127c587 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -94,7 +94,7 @@ tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) = ASSERT( null arg_tys ) - do { checkCg checkCOrAsmOrInterp + do { checkCg checkCOrAsmOrLlvmOrInterp ; checkSafety safety ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty) ; return idecl } -- NB check res_ty not sig_ty! @@ -106,7 +106,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well -- as ft -> IO Addr is accepted, too. The use of the latter two forms -- is DEPRECATED, though. - checkCg checkCOrAsmOrInterp + checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv checkSafety safety case arg_tys of @@ -121,7 +121,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target)) | isDynamicTarget target = do -- Foreign import dynamic - checkCg checkCOrAsmOrInterp + checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv checkSafety safety case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr @@ -139,7 +139,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar dflags <- getDOpts check (dopt Opt_GHCForeignImportPrim dflags) (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.") - checkCg (checkCOrAsmOrDotNetOrInterp) + checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) checkCTarget target check (playSafe safety) (text "The safe/unsafe annotation should not be used with `foreign import prim'.") @@ -148,7 +148,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty return idecl | otherwise = do -- Normal foreign import - checkCg (checkCOrAsmOrDotNetOrInterp) + checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) checkCConv cconv checkSafety safety checkCTarget target @@ -163,7 +163,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar -- that the C identifier is valid for C checkCTarget :: CCallTarget -> TcM () checkCTarget (StaticTarget str _) = do - checkCg checkCOrAsmOrDotNetOrInterp + checkCg checkCOrAsmOrLlvmOrDotNetOrInterp check (isCLabelString str) (badCName str) checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" @@ -247,7 +247,7 @@ tcFExport d = pprPanic "tcFExport" (ppr d) \begin{code} tcCheckFEType :: Type -> ForeignExport -> TcM () tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do - checkCg checkCOrAsm + checkCg checkCOrAsmOrLlvm check (isCLabelString str) (badCName str) checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys @@ -297,25 +297,28 @@ checkForeignRes non_io_result_ok pred_res_ty ty \end{code} \begin{code} -checkCOrAsm :: HscTarget -> Maybe SDoc -checkCOrAsm HscC = Nothing -checkCOrAsm HscAsm = Nothing -checkCOrAsm _ - = Just (text "requires via-C or native code generation (-fvia-C)") - -checkCOrAsmOrInterp :: HscTarget -> Maybe SDoc -checkCOrAsmOrInterp HscC = Nothing -checkCOrAsmOrInterp HscAsm = Nothing -checkCOrAsmOrInterp HscInterpreted = Nothing -checkCOrAsmOrInterp _ - = Just (text "requires interpreted, C or native code generation") - -checkCOrAsmOrDotNetOrInterp :: HscTarget -> Maybe SDoc -checkCOrAsmOrDotNetOrInterp HscC = Nothing -checkCOrAsmOrDotNetOrInterp HscAsm = Nothing -checkCOrAsmOrDotNetOrInterp HscInterpreted = Nothing -checkCOrAsmOrDotNetOrInterp _ - = Just (text "requires interpreted, C or native code generation") +checkCOrAsmOrLlvm :: HscTarget -> Maybe SDoc +checkCOrAsmOrLlvm HscC = Nothing +checkCOrAsmOrLlvm HscAsm = Nothing +checkCOrAsmOrLlvm HscLlvm = Nothing +checkCOrAsmOrLlvm _ + = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)") + +checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc +checkCOrAsmOrLlvmOrInterp HscC = Nothing +checkCOrAsmOrLlvmOrInterp HscAsm = Nothing +checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing +checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing +checkCOrAsmOrLlvmOrInterp _ + = Just (text "requires interpreted, C, Llvm or native code generation") + +checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc +checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing +checkCOrAsmOrLlvmOrDotNetOrInterp HscAsm = Nothing +checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing +checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing +checkCOrAsmOrLlvmOrDotNetOrInterp _ + = Just (text "requires interpreted, C, Llvm or native code generation") checkCg :: (HscTarget -> Maybe SDoc) -> TcM () checkCg check = do diff --git a/driver/mangler/ghc-asm.lprl b/driver/mangler/ghc-asm.lprl index 1ff78a4aa8..a354caada7 100644 --- a/driver/mangler/ghc-asm.lprl +++ b/driver/mangler/ghc-asm.lprl @@ -1445,7 +1445,8 @@ sub mangle_asm { # If this is an entry point with an info table, # eliminate the entry symbol and all directives involving it. - if (defined($infochk{$symb}) && $TargetPlatform !~ /^ia64-/m) { + if (defined($infochk{$symb}) && $TargetPlatform !~ /^ia64-/m + && $TABLES_NEXT_TO_CODE ~~ "YES") { @o = (); foreach $l (split(/\n/m,$c)) { next if $l =~ /^.*$symb_(entry|ret)${T_POST_LBL}/m; @@ -1880,7 +1881,8 @@ sub rev_tbl { # use vars '$discard1'; # Unused? local($symb, $tbl, $discard1) = @_; - return ($tbl) if ($TargetPlatform =~ /^ia64-/m); + return ($tbl) if ($TargetPlatform =~ /^ia64-/m + || $TABLES_NEXT_TO_CODE ~~ "NO"); local($before) = ''; local($label) = ''; diff --git a/mk/config.mk.in b/mk/config.mk.in index 40f1ea7c4f..e1a124c579 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -139,6 +139,9 @@ GhcWithNativeCodeGen=$(strip\ $(if $(filter YESYESNO,\ $(OsSupportsNCG)$(ArchSupportsNCG)$(GhcUnregisterised)),YES,NO)) +# Build a compiler with the llvm code generator backend +GhcWithLlvmCodeGen=NO + HaveLibDL = @HaveLibDL@ # ArchSupportsSMP should be set iff there is support for that arch in diff --git a/rules/build-perl.mk b/rules/build-perl.mk index cfa71cc53d..5ee1d2350b 100644 --- a/rules/build-perl.mk +++ b/rules/build-perl.mk @@ -45,6 +45,7 @@ $1/$2/$$($1_$2_PROG): $1/$2/$$($1_$2_PROG).prl "$$(RM)" $$(RM_OPTS) $$@ echo '#!$$(PERL)' >> $$@ echo '$$$$TARGETPLATFORM = "$$(TARGETPLATFORM)";' >> $$@ + echo '$$$$TABLES_NEXT_TO_CODE = "$(GhcEnableTablesNextToCode)";' >> $$@ cat $$< >> $$@ $$($1_$2_INPLACE): $1/$2/$$($1_$2_PROG) | $$$$(dir $$$$@)/. |