data CmmReturnInfo = CmmMayReturn
| CmmNeverReturns
+ deriving ( Eq )
-- TODO: These types may need refinement
data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
--
-----------------------------------------------------------------------------
-module CmmUtils(
+module CmmUtils(
CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList,
isNopStmt,
| 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
tagToClosure,
callerSaveVolatileRegs, get_GlobalReg_addr,
+ activeStgRegs, fixStgRegisters,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
cmmUGtWord,
: 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.
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
+
ghci
hsSyn
iface
+ llvmGen
main
+ nativeGen
parser
prelude
profiling
Id
IdInfo
Literal
+ Llvm
+ Llvm.AbsSyn
+ Llvm.PpLlvm
+ Llvm.Types
+ LlvmCodeGen
+ LlvmCodeGen.Base
+ LlvmCodeGen.CodeGen
+ LlvmCodeGen.Data
+ LlvmCodeGen.Ppr
+ LlvmCodeGen.Regs
MkId
Module
Name
MkZipCfg
MkZipCfgCmm
OptimizationFuel
+ PprBase
PprC
PprCmm
PprCmmZ
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
Size
Reg
RegClass
- PprBase
PIC
Platform
Alpha.Regs
compiler/stage3/package-data.mk : $(compiler_CONFIG_HS)
endif
+ifeq "$(GhcEnableTablesNextToCode)" "NO"
+GhcWithLlvmCodeGen = YES
+else
+GhcWithLlvmCodeGen = NO
+endif
+
$(compiler_CONFIG_HS) : mk/config.mk mk/project.mk
"$(RM)" $(RM_OPTS) $@
@echo "Creating $@ ... "
@echo "cGhcWithInterpreter = \"$(GhcWithInterpreter)\"" >> $@
@echo "cGhcWithNativeCodeGen :: String" >> $@
@echo "cGhcWithNativeCodeGen = \"$(GhcWithNativeCodeGen)\"" >> $@
+ @echo "cGhcWithLlvmCodeGen :: String" >> $@
+ @echo "cGhcWithLlvmCodeGen = \"$(GhcWithLlvmCodeGen)\"" >> $@
@echo "cGhcWithSMP :: String" >> $@
@echo "cGhcWithSMP = \"$(GhcWithSMP)\"" >> $@
@echo "cGhcRTSWays :: String" >> $@
# or not?
# XXX This should logically be a CPP option, but there doesn't seem to
# be a flag for that
-compiler_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?
# 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
--- /dev/null
+-- ----------------------------------------------------------------------------
+-- | 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
+
--- /dev/null
+--------------------------------------------------------------------------------
+-- | 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)
+
--- /dev/null
+--------------------------------------------------------------------------------
+-- | 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
+
--- /dev/null
+--------------------------------------------------------------------------------
+-- | 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
+
--- /dev/null
+-- -----------------------------------------------------------------------------
+-- | 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
+
--- /dev/null
+-- ----------------------------------------------------------------------------
+-- | 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
+
--- /dev/null
+-- ----------------------------------------------------------------------------
+-- | 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
+
--- /dev/null
+-- ----------------------------------------------------------------------------
+-- | 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
+
--- /dev/null
+-- ----------------------------------------------------------------------------
+-- | 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
+
--- /dev/null
+-- ----------------------------------------------------------------------------
+-- | 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
+
#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
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;
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
| 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
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
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
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
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"
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" ]
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
-- 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
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)
HscC -> HCc
HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
| otherwise -> As
+ HscLlvm -> LlvmAs
HscNothing -> StopLn
HscInterpreted -> StopLn
_other -> StopLn
| 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
| Opt_KeepRawSFiles
| Opt_KeepTmpFiles
| Opt_KeepRawTokenStream
+ | Opt_KeepLlvmFiles
deriving (Eq, Show)
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,
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,
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.
isObjectTarget :: HscTarget -> Bool
isObjectTarget HscC = True
isObjectTarget HscAsm = True
+isObjectTarget HscLlvm = True
isObjectTarget _ = False
-- | The 'GhcMode' tells us whether we're doing multi-module
opt_m = [],
opt_l = [],
opt_windres = [],
+ opt_la = [],
+ opt_lo = [],
+ opt_lc = [],
extraPkgConfs = [],
packageFlags = [],
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",
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
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}
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 }
, 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
, 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
, 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
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)
, 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))
--------------------------
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
("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),
runAs, runLink, -- [Option] -> IO ()
runMkDLL,
runWindres,
+ runLlvmAs,
+ runLlvmOpt,
+ runLlvmLlc,
touch, -- String -> String -> IO ()
copy,
; 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,
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
}
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
import BlockId
import Cmm
-import CgUtils ( get_GlobalReg_addr )
import CLabel ( CLabel, mkMainCapabilityLabel )
import Pretty
import Outputable ( Outputable(..), pprPanic, panic )
import NCGMonad
import BlockId
+import CgUtils ( fixStgRegisters )
import Cmm
import CmmOpt ( cmmMiniInline, cmmMachOpFold )
import PprCmm
= 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) =
-- 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" #-}
dumpIfSet_dyn dflags
Opt_D_dump_asm_liveness "Liveness annotations added"
(vcat $ map ppr withLiveness)
-
-- allocate registers
(alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
emptyUFM
$ allocatableRegs
-
-- do the graph coloring register allocation
let ((alloced, regAllocStats), usAlloc)
= {-# SCC "RegAlloc" #-}
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
(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
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}
= 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 ...
{-
-- horrow show
freeReg,
globalRegMaybe,
- get_GlobalReg_reg_or_addr,
allocatableRegs
)
import RegClass
import Size
-import CgUtils ( get_GlobalReg_addr )
import BlockId
import Cmm
import CLabel ( CLabel )
#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.
import SPARC.Cond
import SPARC.AddrMode
import SPARC.Regs
+import SPARC.RegPlate
import Size
import Reg
= 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
-- allocatable
allocatableRegs,
- get_GlobalReg_reg_or_addr,
-- args
argRegs,
import RegClass
import Size
-import Cmm
import PprCmm ()
-import CgUtils ( get_GlobalReg_addr )
import Unique
import Outputable
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.
--
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.
freeReg,
globalRegMaybe,
- get_GlobalReg_reg_or_addr,
allocatableRegs
)
import Reg
import RegClass
-import CgUtils ( get_GlobalReg_addr )
import BlockId
import Cmm
import CLabel ( CLabel )
#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.
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!
-- 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
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
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'.")
checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty
return idecl
| otherwise = do -- Normal foreign import
- checkCg (checkCOrAsmOrDotNetOrInterp)
+ checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp)
checkCConv cconv
checkSafety safety
checkCTarget target
-- 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"
\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
\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
# 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;
# 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) = '';
$(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
"$$(RM)" $$(RM_OPTS) $$@
echo '#!$$(PERL)' >> $$@
echo '$$$$TARGETPLATFORM = "$$(TARGETPLATFORM)";' >> $$@
+ echo '$$$$TABLES_NEXT_TO_CODE = "$(GhcEnableTablesNextToCode)";' >> $$@
cat $$< >> $$@
$$($1_$2_INPLACE): $1/$2/$$($1_$2_PROG) | $$$$(dir $$$$@)/.
projects / ghc-hetmet.git / commitdiff