Add new LLVM code generator to GHC. (Version 2)

This was done as part of an honours thesis at UNSW, the paper describing the
work and results can be found at:

http://www.cse.unsw.edu.au/~pls/thesis/davidt-thesis.pdf

A Homepage for the backend can be found at:

http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/Backends/LLVM

Quick summary of performance is that for the 'nofib' benchmark suite, runtimes
are within 5% slower than the NCG and generally better than the C code
generator.  For some code though, such as the DPH projects benchmark, the LLVM
code generator outperforms the NCG and C code generator by about a 25%
reduction in run times.

1 files changed, 179 insertions, 27 deletions

diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index f8b41a087a..d22fee1e75 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -26,6 +26,7 @@ module CgUtils (
 	tagToClosure,
 
         callerSaveVolatileRegs, get_GlobalReg_addr,
+	activeStgRegs, fixStgRegisters,
 
 	cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
         cmmUGtWord,
@@ -423,33 +424,6 @@ callerSaveVolatileRegs vols = (caller_save, caller_load)
 			: next
 	| otherwise = next
 
--- -----------------------------------------------------------------------------
--- Global registers
-
--- We map STG registers onto appropriate CmmExprs.  Either they map
--- to real machine registers or stored as offsets from BaseReg.  Given
--- a GlobalReg, get_GlobalReg_addr always produces the 
--- register table address for it.
--- (See also get_GlobalReg_reg_or_addr in MachRegs)
-
-get_GlobalReg_addr              :: GlobalReg -> CmmExpr
-get_GlobalReg_addr BaseReg = regTableOffset 0
-get_GlobalReg_addr mid     = get_Regtable_addr_from_offset 
-				(globalRegType mid) (baseRegOffset mid)
-
--- Calculate a literal representing an offset into the register table.
--- Used when we don't have an actual BaseReg to offset from.
-regTableOffset n = 
-  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
-
-get_Regtable_addr_from_offset   :: CmmType -> Int -> CmmExpr
-get_Regtable_addr_from_offset rep offset =
-#ifdef REG_Base
-  CmmRegOff (CmmGlobal BaseReg) offset
-#else
-  regTableOffset offset
-#endif
-
 
 -- | Returns @True@ if this global register is stored in a caller-saves
 -- machine register.
@@ -1010,3 +984,181 @@ clHasCafRefs (ClosureInfo {closureSRT = srt}) =
   case srt of NoC_SRT -> NoCafRefs
               _       -> MayHaveCafRefs
 clHasCafRefs (ConInfo {}) = NoCafRefs
+
+-- -----------------------------------------------------------------------------
+--
+-- STG/Cmm GlobalReg
+--
+-- -----------------------------------------------------------------------------
+
+-- | Here is where the STG register map is defined for each target arch.
+-- The order matters (for the llvm backend anyway)! We must make sure to
+-- maintain the order here with the order used in the LLVM calling conventions.
+-- Note that also, this isn't all registers, just the ones that are currently
+-- possbily mapped to real registers.
+activeStgRegs :: [GlobalReg]
+activeStgRegs = [
+#ifdef REG_Base
+    BaseReg
+#endif
+#ifdef REG_Sp
+    ,Sp
+#endif
+#ifdef REG_Hp
+    ,Hp
+#endif
+#ifdef REG_R1
+    ,VanillaReg 1 VGcPtr
+#endif
+#ifdef REG_R2
+    ,VanillaReg 2 VGcPtr
+#endif
+#ifdef REG_R3
+    ,VanillaReg 3 VGcPtr
+#endif
+#ifdef REG_R4
+    ,VanillaReg 4 VGcPtr
+#endif
+#ifdef REG_R5
+    ,VanillaReg 5 VGcPtr
+#endif
+#ifdef REG_R6
+    ,VanillaReg 6 VGcPtr
+#endif
+#ifdef REG_R7
+    ,VanillaReg 7 VGcPtr
+#endif
+#ifdef REG_R8
+    ,VanillaReg 8 VGcPtr
+#endif
+#ifdef REG_SpLim
+    ,SpLim
+#endif
+#ifdef REG_F1
+    ,FloatReg 1
+#endif
+#ifdef REG_F2
+    ,FloatReg 2
+#endif
+#ifdef REG_F3
+    ,FloatReg 3
+#endif
+#ifdef REG_F4
+    ,FloatReg 4
+#endif
+#ifdef REG_D1
+    ,DoubleReg 1
+#endif
+#ifdef REG_D2
+    ,DoubleReg 2
+#endif
+    ]
+  
+-- | We map STG registers onto appropriate CmmExprs.  Either they map
+-- to real machine registers or stored as offsets from BaseReg.  Given
+-- a GlobalReg, get_GlobalReg_addr always produces the 
+-- register table address for it.
+get_GlobalReg_addr :: GlobalReg -> CmmExpr
+get_GlobalReg_addr BaseReg = regTableOffset 0
+get_GlobalReg_addr mid     = get_Regtable_addr_from_offset 
+				(globalRegType mid) (baseRegOffset mid)
+
+-- Calculate a literal representing an offset into the register table.
+-- Used when we don't have an actual BaseReg to offset from.
+regTableOffset n = 
+  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
+
+get_Regtable_addr_from_offset   :: CmmType -> Int -> CmmExpr
+get_Regtable_addr_from_offset rep offset =
+#ifdef REG_Base
+  CmmRegOff (CmmGlobal BaseReg) offset
+#else
+  regTableOffset offset
+#endif
+
+-- | Fixup global registers so that they assign to locations within the
+-- RegTable if they aren't pinned for the current target.
+fixStgRegisters :: RawCmmTop -> RawCmmTop
+fixStgRegisters top@(CmmData _ _) = top
+
+fixStgRegisters (CmmProc info lbl params (ListGraph blocks)) =
+  let blocks' = map fixStgRegBlock blocks
+  in CmmProc info lbl params $ ListGraph blocks'
+
+fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock
+fixStgRegBlock (BasicBlock id stmts) =
+  let stmts' = map fixStgRegStmt stmts
+  in BasicBlock id stmts'
+
+fixStgRegStmt :: CmmStmt -> CmmStmt
+fixStgRegStmt stmt
+  = case stmt of
+        CmmAssign (CmmGlobal reg) src ->
+            let src' = fixStgRegExpr src
+                baseAddr = get_GlobalReg_addr reg
+            in case reg `elem` activeStgRegs of
+                True  -> CmmAssign (CmmGlobal reg) src'
+                False -> CmmStore baseAddr src'   
+        
+        CmmAssign reg src ->
+            let src' = fixStgRegExpr src
+            in CmmAssign reg src'
+
+        CmmStore addr src -> CmmStore (fixStgRegExpr addr) (fixStgRegExpr src)
+
+        CmmCall target regs args srt returns ->
+            let target' = case target of
+                    CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv
+                    other            -> other
+                args' = map (\(CmmHinted arg hint) ->
+                                (CmmHinted (fixStgRegExpr arg) hint)) args
+            in CmmCall target' regs args' srt returns
+
+        CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr test) dest
+
+        CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids
+
+        CmmJump addr regs -> CmmJump (fixStgRegExpr addr) regs
+
+        -- CmmNop, CmmComment, CmmBranch, CmmReturn
+        _other -> stmt
+
+
+fixStgRegExpr :: CmmExpr ->  CmmExpr
+fixStgRegExpr expr
+  = case expr of
+        CmmLoad addr ty -> CmmLoad (fixStgRegExpr addr) ty
+
+        CmmMachOp mop args -> CmmMachOp mop args'
+            where args' = map fixStgRegExpr args
+
+        CmmReg (CmmGlobal reg) ->
+            -- Replace register leaves with appropriate StixTrees for
+            -- the given target.  MagicIds which map to a reg on this
+            -- arch are left unchanged.  For the rest, BaseReg is taken
+            -- to mean the address of the reg table in MainCapability,
+            -- and for all others we generate an indirection to its
+            -- location in the register table.
+            case reg `elem` activeStgRegs of
+                True  -> expr
+                False ->
+                    let baseAddr = get_GlobalReg_addr reg
+                    in case reg of
+                        BaseReg -> fixStgRegExpr baseAddr
+                        _other  -> fixStgRegExpr
+                                    (CmmLoad baseAddr (globalRegType reg))
+
+        CmmRegOff (CmmGlobal reg) offset ->
+            -- RegOf leaves are just a shorthand form. If the reg maps
+            -- to a real reg, we keep the shorthand, otherwise, we just
+            -- expand it and defer to the above code.
+            case reg `elem` activeStgRegs of
+                True  -> expr
+                False -> fixStgRegExpr (CmmMachOp (MO_Add wordWidth) [
+                                    CmmReg (CmmGlobal reg),
+                                    CmmLit (CmmInt (fromIntegral offset)
+                                                wordWidth)])
+
+        -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
+        _other -> expr
+