Produce new-style Cmm from the Cmm parser
[ghc.git] / compiler / codeGen / CgUtils.hs
index 08b6fb8..9f9a2cf 100644 (file)
@@ -45,15 +45,14 @@ module CgUtils (
   ) where
 
 #include "HsVersions.h"
-#include "../includes/stg/MachRegs.h"
 
 import BlockId
+import CodeGen.Platform
 import CgMonad
 import TyCon
 import DataCon
 import Id
 import IdInfo
-import Constants
 import SMRep
 import OldCmm
 import OldCmmUtils
@@ -93,33 +92,34 @@ addIdReps ids = [(idCgRep id, id) | id <- ids]
 
 cgLit :: Literal -> FCode CmmLit
 cgLit (MachStr s) = newByteStringCLit (bytesFB s)
-cgLit other_lit   = return (mkSimpleLit other_lit)
-
-mkSimpleLit :: Literal -> CmmLit
-mkSimpleLit (MachChar   c)    = CmmInt (fromIntegral (ord c)) wordWidth
-mkSimpleLit MachNullAddr      = zeroCLit
-mkSimpleLit (MachInt i)       = CmmInt i wordWidth
-mkSimpleLit (MachInt64 i)     = CmmInt i W64
-mkSimpleLit (MachWord i)      = CmmInt i wordWidth
-mkSimpleLit (MachWord64 i)    = CmmInt i W64
-mkSimpleLit (MachFloat r)     = CmmFloat r W32
-mkSimpleLit (MachDouble r)    = CmmFloat r W64
-mkSimpleLit (MachLabel fs ms fod)
+cgLit other_lit   = do dflags <- getDynFlags
+                       return (mkSimpleLit dflags other_lit)
+
+mkSimpleLit :: DynFlags -> Literal -> CmmLit
+mkSimpleLit dflags (MachChar   c)    = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
+mkSimpleLit dflags MachNullAddr      = zeroCLit dflags
+mkSimpleLit dflags (MachInt i)       = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (MachInt64 i)     = CmmInt i W64
+mkSimpleLit dflags (MachWord i)      = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (MachWord64 i)    = CmmInt i W64
+mkSimpleLit _      (MachFloat r)     = CmmFloat r W32
+mkSimpleLit _      (MachDouble r)    = CmmFloat r W64
+mkSimpleLit _      (MachLabel fs ms fod)
         = CmmLabel (mkForeignLabel fs ms labelSrc fod)
         where
                 -- TODO: Literal labels might not actually be in the current package...
                 labelSrc = ForeignLabelInThisPackage
-mkSimpleLit (MachStr _) = panic "mkSimpleLit: MachStr"
+mkSimpleLit (MachStr _) = panic "mkSimpleLit: MachStr"
 -- No LitInteger's should be left by the time this is called. CorePrep
 -- should have converted them all to a real core representation.
-mkSimpleLit (LitInteger {}) = panic "mkSimpleLit: LitInteger"
+mkSimpleLit (LitInteger {}) = panic "mkSimpleLit: LitInteger"
 
-mkLtOp :: Literal -> MachOp
+mkLtOp :: DynFlags -> Literal -> MachOp
 -- On signed literals we must do a signed comparison
-mkLtOp (MachInt _)    = MO_S_Lt wordWidth
-mkLtOp (MachFloat _)  = MO_F_Lt W32
-mkLtOp (MachDouble _) = MO_F_Lt W64
-mkLtOp lit            = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
+mkLtOp dflags (MachInt _)    = MO_S_Lt (wordWidth dflags)
+mkLtOp _      (MachFloat _)  = MO_F_Lt W32
+mkLtOp _      (MachDouble _) = MO_F_Lt W64
+mkLtOp dflags lit            = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit)))
 
 
 ---------------------------------------------------
@@ -141,20 +141,20 @@ mkLtOp lit            = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
    Big families only use the tag value 1 to represent
    evaluatedness.
 -}
-isSmallFamily :: Int -> Bool
-isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
+isSmallFamily :: DynFlags -> Int -> Bool
+isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
 
-tagForCon :: DataCon -> ConTagZ
-tagForCon con = tag
+tagForCon :: DynFlags -> DataCon -> ConTagZ
+tagForCon dflags con = tag
     where
     con_tag           = dataConTagZ con
     fam_size   = tyConFamilySize (dataConTyCon con)
-    tag | isSmallFamily fam_size = con_tag + 1
-        | otherwise              = 1
+    tag | isSmallFamily dflags fam_size = con_tag + 1
+        | otherwise                     = 1
 
 --Tag an expression, to do: refactor, this appears in some other module.
-tagCons :: DataCon -> CmmExpr -> CmmExpr
-tagCons con expr = cmmOffsetB expr (tagForCon con)
+tagCons :: DynFlags -> DataCon -> CmmExpr -> CmmExpr
+tagCons dflags con expr = cmmOffsetB dflags expr (tagForCon dflags con)
 
 --------------------------------------------------------------------------
 --
@@ -182,9 +182,9 @@ addToMemE width ptr n
 --
 -------------------------------------------------------------------------
 
-tagToClosure :: TyCon -> CmmExpr -> CmmExpr
-tagToClosure tycon tag
-  = CmmLoad (cmmOffsetExprW closure_tbl tag) gcWord
+tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
+tagToClosure dflags tycon tag
+  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (gcWord dflags)
   where closure_tbl = CmmLit (CmmLabel lbl)
         lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
 
@@ -260,11 +260,12 @@ emitRtsCallGen
    -> Maybe [GlobalReg]
    -> Code
 emitRtsCallGen res pkg fun args vols = do
+  dflags <- getDynFlags
+  let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols
   stmtsC caller_save
   stmtC (CmmCall target res args CmmMayReturn)
   stmtsC caller_load
   where
-    (caller_save, caller_load) = callerSaveVolatileRegs vols
     target   = CmmCallee fun_expr CCallConv
     fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
 
@@ -281,9 +282,12 @@ emitRtsCallGen res pkg fun args vols = do
 --  * Regs.h claims that BaseReg should be saved last and loaded first
 --    * This might not have been tickled before since BaseReg is callee save
 --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
-callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
-callerSaveVolatileRegs vols = (caller_save, caller_load)
+callerSaveVolatileRegs :: DynFlags -> Maybe [GlobalReg]
+                       -> ([CmmStmt], [CmmStmt])
+callerSaveVolatileRegs dflags vols = (caller_save, caller_load)
   where
+    platform = targetPlatform dflags
+
     caller_save = foldr ($!) [] (map callerSaveGlobalReg    regs_to_save)
     caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
 
@@ -294,148 +298,66 @@ callerSaveVolatileRegs vols = (caller_save, caller_load)
 
     vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
 
-    all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
+    all_of_em = [ VanillaReg n VNonGcPtr | n <- [0 .. mAX_Vanilla_REG dflags] ]
                         -- The VNonGcPtr is a lie, but I don't think it matters
-             ++ [ FloatReg   n | n <- [0..mAX_Float_REG] ]
-             ++ [ DoubleReg  n | n <- [0..mAX_Double_REG] ]
-             ++ [ LongReg    n | n <- [0..mAX_Long_REG] ]
+             ++ [ FloatReg   n | n <- [0 .. mAX_Float_REG dflags] ]
+             ++ [ DoubleReg  n | n <- [0 .. mAX_Double_REG dflags] ]
+             ++ [ LongReg    n | n <- [0 .. mAX_Long_REG dflags] ]
 
     callerSaveGlobalReg reg next
-        | callerSaves reg =
-                CmmStore (get_GlobalReg_addr reg)
+        | callerSaves platform reg =
+                CmmStore (get_GlobalReg_addr dflags reg)
                          (CmmReg (CmmGlobal reg)) : next
         | otherwise = next
 
     callerRestoreGlobalReg reg next
-        | callerSaves reg =
+        | callerSaves platform reg =
                 CmmAssign (CmmGlobal reg)
-                          (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
+                          (CmmLoad (get_GlobalReg_addr dflags reg)
+                                   (globalRegType dflags reg))
                         : next
         | otherwise = next
 
 
--- | Returns @True@ if this global register is stored in a caller-saves
--- machine register.
-
-callerSaves :: GlobalReg -> Bool
-
-#ifdef CALLER_SAVES_Base
-callerSaves BaseReg             = True
-#endif
-#ifdef CALLER_SAVES_R1
-callerSaves (VanillaReg 1 _)    = True
-#endif
-#ifdef CALLER_SAVES_R2
-callerSaves (VanillaReg 2 _)    = True
-#endif
-#ifdef CALLER_SAVES_R3
-callerSaves (VanillaReg 3 _)    = True
-#endif
-#ifdef CALLER_SAVES_R4
-callerSaves (VanillaReg 4 _)    = True
-#endif
-#ifdef CALLER_SAVES_R5
-callerSaves (VanillaReg 5 _)    = True
-#endif
-#ifdef CALLER_SAVES_R6
-callerSaves (VanillaReg 6 _)    = True
-#endif
-#ifdef CALLER_SAVES_R7
-callerSaves (VanillaReg 7 _)    = True
-#endif
-#ifdef CALLER_SAVES_R8
-callerSaves (VanillaReg 8 _)    = True
-#endif
-#ifdef CALLER_SAVES_R9
-callerSaves (VanillaReg 9 _)    = True
-#endif
-#ifdef CALLER_SAVES_R10
-callerSaves (VanillaReg 10 _)   = True
-#endif
-#ifdef CALLER_SAVES_F1
-callerSaves (FloatReg 1)        = True
-#endif
-#ifdef CALLER_SAVES_F2
-callerSaves (FloatReg 2)        = True
-#endif
-#ifdef CALLER_SAVES_F3
-callerSaves (FloatReg 3)        = True
-#endif
-#ifdef CALLER_SAVES_F4
-callerSaves (FloatReg 4)        = True
-#endif
-#ifdef CALLER_SAVES_D1
-callerSaves (DoubleReg 1)       = True
-#endif
-#ifdef CALLER_SAVES_D2
-callerSaves (DoubleReg 2)       = True
-#endif
-#ifdef CALLER_SAVES_L1
-callerSaves (LongReg 1)         = True
-#endif
-#ifdef CALLER_SAVES_Sp
-callerSaves Sp                  = True
-#endif
-#ifdef CALLER_SAVES_SpLim
-callerSaves SpLim               = True
-#endif
-#ifdef CALLER_SAVES_Hp
-callerSaves Hp                  = True
-#endif
-#ifdef CALLER_SAVES_HpLim
-callerSaves HpLim               = True
-#endif
-#ifdef CALLER_SAVES_CCCS
-callerSaves CCCS                = True
-#endif
-#ifdef CALLER_SAVES_CurrentTSO
-callerSaves CurrentTSO          = True
-#endif
-#ifdef CALLER_SAVES_CurrentNursery
-callerSaves CurrentNursery      = True
-#endif
-callerSaves _                   = False
-
-
 -- -----------------------------------------------------------------------------
 -- Information about global registers
 
-baseRegOffset :: GlobalReg -> Int
-
-baseRegOffset (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1
-baseRegOffset (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2
-baseRegOffset (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3
-baseRegOffset (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4
-baseRegOffset (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5
-baseRegOffset (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6
-baseRegOffset (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7
-baseRegOffset (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8
-baseRegOffset (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9
-baseRegOffset (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10
-baseRegOffset (VanillaReg n _)    = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")
-baseRegOffset (FloatReg  1)       = oFFSET_StgRegTable_rF1
-baseRegOffset (FloatReg  2)       = oFFSET_StgRegTable_rF2
-baseRegOffset (FloatReg  3)       = oFFSET_StgRegTable_rF3
-baseRegOffset (FloatReg  4)       = oFFSET_StgRegTable_rF4
-baseRegOffset (FloatReg  n)       = panic ("Registers above F4 are not supported (tried to use F" ++ show n ++ ")")
-baseRegOffset (DoubleReg 1)       = oFFSET_StgRegTable_rD1
-baseRegOffset (DoubleReg 2)       = oFFSET_StgRegTable_rD2
-baseRegOffset (DoubleReg n)       = panic ("Registers above D2 are not supported (tried to use D" ++ show n ++ ")")
-baseRegOffset Sp                  = oFFSET_StgRegTable_rSp
-baseRegOffset SpLim               = oFFSET_StgRegTable_rSpLim
-baseRegOffset (LongReg 1)         = oFFSET_StgRegTable_rL1
-baseRegOffset (LongReg n)         = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")
-baseRegOffset Hp                  = oFFSET_StgRegTable_rHp
-baseRegOffset HpLim               = oFFSET_StgRegTable_rHpLim
-baseRegOffset CCCS                = oFFSET_StgRegTable_rCCCS
-baseRegOffset CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO
-baseRegOffset CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery
-baseRegOffset HpAlloc             = oFFSET_StgRegTable_rHpAlloc
-baseRegOffset EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo
-baseRegOffset GCEnter1            = oFFSET_stgGCEnter1
-baseRegOffset GCFun               = oFFSET_stgGCFun
-baseRegOffset BaseReg             = panic "baseRegOffset:BaseReg"
-baseRegOffset PicBaseReg          = panic "baseRegOffset:PicBaseReg"
+baseRegOffset :: DynFlags -> GlobalReg -> Int
+
+baseRegOffset dflags (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1 dflags
+baseRegOffset dflags (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2 dflags
+baseRegOffset dflags (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3 dflags
+baseRegOffset dflags (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4 dflags
+baseRegOffset dflags (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5 dflags
+baseRegOffset dflags (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6 dflags
+baseRegOffset dflags (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7 dflags
+baseRegOffset dflags (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8 dflags
+baseRegOffset dflags (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9 dflags
+baseRegOffset dflags (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10 dflags
+baseRegOffset _      (VanillaReg n _)    = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")
+baseRegOffset dflags (FloatReg  1)       = oFFSET_StgRegTable_rF1 dflags
+baseRegOffset dflags (FloatReg  2)       = oFFSET_StgRegTable_rF2 dflags
+baseRegOffset dflags (FloatReg  3)       = oFFSET_StgRegTable_rF3 dflags
+baseRegOffset dflags (FloatReg  4)       = oFFSET_StgRegTable_rF4 dflags
+baseRegOffset _      (FloatReg  n)       = panic ("Registers above F4 are not supported (tried to use F" ++ show n ++ ")")
+baseRegOffset dflags (DoubleReg 1)       = oFFSET_StgRegTable_rD1 dflags
+baseRegOffset dflags (DoubleReg 2)       = oFFSET_StgRegTable_rD2 dflags
+baseRegOffset _      (DoubleReg n)       = panic ("Registers above D2 are not supported (tried to use D" ++ show n ++ ")")
+baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags
+baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags
+baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags
+baseRegOffset _      (LongReg n)         = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")
+baseRegOffset dflags Hp                  = oFFSET_StgRegTable_rHp dflags
+baseRegOffset dflags HpLim               = oFFSET_StgRegTable_rHpLim dflags
+baseRegOffset dflags CCCS                = oFFSET_StgRegTable_rCCCS dflags
+baseRegOffset dflags CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO dflags
+baseRegOffset dflags CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery dflags
+baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags
+baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags
+baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags
+baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags
+baseRegOffset _      BaseReg             = panic "baseRegOffset:BaseReg"
+baseRegOffset _      PicBaseReg          = panic "baseRegOffset:PicBaseReg"
 
 
 -------------------------------------------------------------------------
@@ -479,9 +401,10 @@ assignTemp :: CmmExpr -> FCode CmmExpr
 -- variable and assign the expression to it
 assignTemp e
   | isTrivialCmmExpr e = return e
-  | otherwise          = do { reg <- newTemp (cmmExprType e)
-                            ; stmtC (CmmAssign (CmmLocal reg) e)
-                            ; return (CmmReg (CmmLocal reg)) }
+  | otherwise          = do dflags <- getDynFlags
+                            reg <- newTemp (cmmExprType dflags e)
+                            stmtC (CmmAssign (CmmLocal reg) e)
+                            return (CmmReg (CmmLocal reg))
 
 -- | If the expression is trivial and doesn't refer to a global
 -- register, return it.  Otherwise, assign the expression to a
@@ -491,7 +414,8 @@ assignTemp_ :: CmmExpr -> FCode CmmExpr
 assignTemp_ e
     | isTrivialCmmExpr e && hasNoGlobalRegs e = return e
     | otherwise = do
-        reg <- newTemp (cmmExprType e)
+        dflags <- getDynFlags
+        reg <- newTemp (cmmExprType dflags e)
         stmtC (CmmAssign (CmmLocal reg) e)
         return (CmmReg (CmmLocal reg))
 
@@ -554,12 +478,13 @@ mk_switch _tag_expr [(_tag,stmts)] Nothing _lo_tag _hi_tag _via_C
         -- can't happen, so no need to test
 
 -- SINGLETON BRANCH: one equality check to do
-mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C
-  = return (CmmCondBranch cond deflt `consCgStmt` stmts)
-  where
-    cond  =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
+mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C = do
+  dflags <- getDynFlags
+  let
+    cond  =  cmmNeWord dflags tag_expr (CmmLit (mkIntCLit dflags tag))
         -- We have lo_tag < hi_tag, but there's only one branch,
         -- so there must be a default
+  return (CmmCondBranch cond deflt `consCgStmt` stmts)
 
 -- ToDo: we might want to check for the two branch case, where one of
 -- the branches is the tag 0, because comparing '== 0' is likely to be
@@ -576,7 +501,8 @@ mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C
 --
 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
   | use_switch  -- Use a switch
-  = do  { branch_ids <- mapM forkCgStmts (map snd branches)
+  = do  { dflags <- getDynFlags
+        ; branch_ids <- mapM forkCgStmts (map snd branches)
         ; let
                 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 
@@ -588,7 +514,7 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
                 -- tag of a real branch is real_lo_tag (not lo_tag).
                 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 
-                switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
+                switch_stmt = CmmSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms
 
         ; ASSERT(not (all isNothing arms))
           return (oneCgStmt switch_stmt)
@@ -596,8 +522,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 
   -- if we can knock off a bunch of default cases with one if, then do so
   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
-  = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
-       ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
+  = do { dflags <- getDynFlags
+       ; (assign_tag, tag_expr') <- assignTemp' tag_expr
+       ; let cond = cmmULtWord dflags tag_expr' (CmmLit (mkIntCLit dflags lowest_branch))
              branch = CmmCondBranch cond deflt
        ; stmts <- mk_switch tag_expr' branches mb_deflt
                         lowest_branch hi_tag via_C
@@ -605,8 +532,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
        }
 
   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
-  = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
-       ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
+  = do { dflags <- getDynFlags
+       ; (assign_tag, tag_expr') <- assignTemp' tag_expr
+       ; let cond = cmmUGtWord dflags tag_expr' (CmmLit (mkIntCLit dflags highest_branch))
              branch = CmmCondBranch cond deflt
        ; stmts <- mk_switch tag_expr' branches mb_deflt
                         lo_tag highest_branch via_C
@@ -614,14 +542,15 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
        }
 
   | otherwise   -- Use an if-tree
-  = do  { (assign_tag, tag_expr') <- assignTemp' tag_expr
+  = do  { dflags <- getDynFlags
+        ; (assign_tag, tag_expr') <- assignTemp' tag_expr
                 -- To avoid duplication
         ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
                                 lo_tag (mid_tag-1) via_C
         ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
                                 mid_tag hi_tag via_C
         ; hi_id <- forkCgStmts hi_stmts
-        ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
+        ; let cond = cmmUGeWord dflags tag_expr' (CmmLit (mkIntCLit dflags mid_tag))
               branch_stmt = CmmCondBranch cond hi_id
         ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
         }
@@ -681,8 +610,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 assignTemp' :: CmmExpr -> FCode (CmmStmt, CmmExpr)
 assignTemp' e
   | isTrivialCmmExpr e = return (CmmNop, e)
-  | otherwise          = do { reg <- newTemp (cmmExprType e)
-                            ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
+  | otherwise          = do dflags <- getDynFlags
+                            reg <- newTemp (cmmExprType dflags e)
+                            return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg))
 
 emitLitSwitch :: CmmExpr                        -- Tag to switch on
               -> [(Literal, CgStmts)]           -- Tagged branches
@@ -705,19 +635,20 @@ mk_lit_switch :: CmmExpr -> BlockId
               -> [(Literal,CgStmts)]
               -> FCode CgStmts
 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
-  = return (consCgStmt if_stmt blk)
-  where
-    cmm_lit = mkSimpleLit lit
-    rep     = cmmLitType cmm_lit
-    ne      = if isFloatType rep then MO_F_Ne else MO_Ne
-    cond    = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
-    if_stmt = CmmCondBranch cond deflt_blk_id
+  = do dflags <- getDynFlags
+       let cmm_lit = mkSimpleLit dflags lit
+           rep     = cmmLitType dflags cmm_lit
+           ne      = if isFloatType rep then MO_F_Ne else MO_Ne
+           cond    = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
+           if_stmt = CmmCondBranch cond deflt_blk_id
+       return (consCgStmt if_stmt blk)
 
 mk_lit_switch scrut deflt_blk_id branches
-  = do  { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
+  = do  { dflags <- getDynFlags
+        ; hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
         ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
         ; lo_blk_id <- forkCgStmts lo_blk
-        ; let if_stmt = CmmCondBranch cond lo_blk_id
+        ; let if_stmt = CmmCondBranch (cond dflags) lo_blk_id
         ; return (if_stmt `consCgStmt` hi_blk) }
   where
     n_branches = length branches
@@ -727,8 +658,8 @@ mk_lit_switch scrut deflt_blk_id branches
     (lo_branches, hi_branches) = span is_lo branches
     is_lo (t,_) = t < mid_lit
 
-    cond    = CmmMachOp (mkLtOp mid_lit)
-                        [scrut, CmmLit (mkSimpleLit mid_lit)]
+    cond dflags = CmmMachOp (mkLtOp dflags mid_lit)
+                            [scrut, CmmLit (mkSimpleLit dflags mid_lit)]
 
 -------------------------------------------------------------------------
 --
@@ -764,13 +695,14 @@ emitSimultaneously stmts
       stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
 
 doSimultaneously1 :: [CVertex] -> Code
-doSimultaneously1 vertices
-  = let
+doSimultaneously1 vertices = do
+    dflags <- getDynFlags
+    let
         edges = [ (vertex, key1, edges_from stmt1)
                 | vertex@(key1, stmt1) <- vertices
                 ]
         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
-                                    stmt1 `mustFollow` stmt2
+                                    mustFollow dflags stmt1 stmt2
                            ]
         components = stronglyConnCompFromEdgedVertices edges
 
@@ -789,23 +721,24 @@ doSimultaneously1 vertices
                 ; stmtC from_temp }
 
         go_via_temp (CmmAssign dest src)
-          = do  { tmp <- newTemp (cmmRegType dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
+          = do  { dflags <- getDynFlags
+                ; tmp <- newTemp (cmmRegType dflags dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
                 ; stmtC (CmmAssign (CmmLocal tmp) src)
                 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
         go_via_temp (CmmStore dest src)
-          = do  { tmp <- newTemp (cmmExprType src) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
+          = do  { tmp <- newTemp (cmmExprType dflags src) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
                 ; stmtC (CmmAssign (CmmLocal tmp) src)
                 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
         go_via_temp _ = panic "doSimultaneously1: go_via_temp"
-    in
     mapCs do_component components
 
-mustFollow :: CmmStmt -> CmmStmt -> Bool
-CmmAssign reg _  `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
-CmmStore loc e   `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt
-CmmNop           `mustFollow` _    = False
-CmmComment _     `mustFollow` _    = False
-_                `mustFollow` _    = panic "mustFollow"
+mustFollow :: DynFlags -> CmmStmt -> CmmStmt -> Bool
+mustFollow dflags x y = x `mustFollow'` y
+    where CmmAssign reg _  `mustFollow'` stmt = anySrc (reg `regUsedIn`) stmt
+          CmmStore loc e   `mustFollow'` stmt = anySrc (locUsedIn loc (cmmExprType dflags e)) stmt
+          CmmNop           `mustFollow'` _    = False
+          CmmComment _     `mustFollow'` _    = False
+          _                `mustFollow'` _    = panic "mustFollow"
 
 
 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
@@ -853,6 +786,7 @@ possiblySameLoc _  _    _          _    = True  -- Conservative
 
 getSRTInfo :: FCode C_SRT
 getSRTInfo = do
+  dflags <- getDynFlags
   srt_lbl <- getSRTLabel
   srt <- getSRT
   case srt of
@@ -861,21 +795,21 @@ getSRTInfo = do
     NoSRT -> return NoC_SRT
     SRTEntries {} -> panic "getSRTInfo: SRTEntries.  Perhaps you forgot to run SimplStg?"
     SRT off len bmp
-      | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
+      | len > hALF_WORD_SIZE_IN_BITS dflags || bmp == [toStgWord dflags (fromStgHalfWord (srt_escape dflags))]
       -> do id <- newUnique
             let srt_desc_lbl = mkLargeSRTLabel id
             emitRODataLits "getSRTInfo" srt_desc_lbl
-             ( cmmLabelOffW srt_lbl off
-               : mkWordCLit (fromIntegral len)
-               : map mkWordCLit bmp)
-            return (C_SRT srt_desc_lbl 0 srt_escape)
+             ( cmmLabelOffW dflags srt_lbl off
+               : mkWordCLit dflags (toInteger len)
+               : map (mkWordCLit dflags . fromStgWord) bmp)
+            return (C_SRT srt_desc_lbl 0 (srt_escape dflags))
 
       | otherwise
-      -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
+      -> return (C_SRT srt_lbl off (toStgHalfWord dflags (fromStgWord (head bmp))))
                 -- The fromIntegral converts to StgHalfWord
 
-srt_escape :: StgHalfWord
-srt_escape = -1
+srt_escape :: DynFlags -> StgHalfWord
+srt_escape dflags = toStgHalfWord dflags (-1)
 
 -- -----------------------------------------------------------------------------
 --
@@ -883,154 +817,85 @@ srt_escape = -1
 --
 -- -----------------------------------------------------------------------------
 
--- | 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_R9
-    ,VanillaReg 9 VGcPtr
-#endif
-#ifdef REG_R10
-    ,VanillaReg 10 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)
+get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
+get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
+get_GlobalReg_addr dflags mid
+    = get_Regtable_addr_from_offset dflags
+                                    (globalRegType dflags mid) (baseRegOffset dflags mid)
 
 -- Calculate a literal representing an offset into the register table.
 -- Used when we don't have an actual BaseReg to offset from.
-regTableOffset :: Int -> CmmExpr
-regTableOffset n =
-  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
-
-get_Regtable_addr_from_offset   :: CmmType -> Int -> CmmExpr
-get_Regtable_addr_from_offset _ offset =
-#ifdef REG_Base
-  CmmRegOff (CmmGlobal BaseReg) offset
-#else
-  regTableOffset offset
-#endif
+regTableOffset :: DynFlags -> Int -> CmmExpr
+regTableOffset dflags n =
+  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
+
+get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
+get_Regtable_addr_from_offset dflags _ offset =
+    if haveRegBase (targetPlatform dflags)
+    then CmmRegOff (CmmGlobal BaseReg) offset
+    else regTableOffset dflags offset
 
 -- | Fixup global registers so that they assign to locations within the
 -- RegTable if they aren't pinned for the current target.
-fixStgRegisters :: RawCmmDecl -> RawCmmDecl
-fixStgRegisters top@(CmmData _ _) = top
+fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
+fixStgRegisters top@(CmmData _ _) = top
 
-fixStgRegisters (CmmProc info lbl (ListGraph blocks)) =
-  let blocks' = map fixStgRegBlock blocks
+fixStgRegisters dflags (CmmProc info lbl (ListGraph blocks)) =
+  let blocks' = map (fixStgRegBlock dflags) blocks
   in CmmProc info lbl $ ListGraph blocks'
 
-fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock
-fixStgRegBlock (BasicBlock id stmts) =
-  let stmts' = map fixStgRegStmt stmts
+fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock
+fixStgRegBlock dflags (BasicBlock id stmts) =
+  let stmts' = map (fixStgRegStmt dflags) stmts
   in BasicBlock id stmts'
 
-fixStgRegStmt :: CmmStmt -> CmmStmt
-fixStgRegStmt stmt
+fixStgRegStmt :: DynFlags -> CmmStmt -> CmmStmt
+fixStgRegStmt dflags stmt
   = case stmt of
         CmmAssign (CmmGlobal reg) src ->
-            let src' = fixStgRegExpr src
-                baseAddr = get_GlobalReg_addr reg
-            in case reg `elem` activeStgRegs of
+            let src' = fixStgRegExpr dflags src
+                baseAddr = get_GlobalReg_addr dflags reg
+            in case reg `elem` activeStgRegs platform of
                 True  -> CmmAssign (CmmGlobal reg) src'
                 False -> CmmStore baseAddr src'
 
         CmmAssign reg src ->
-            let src' = fixStgRegExpr src
+            let src' = fixStgRegExpr dflags src
             in CmmAssign reg src'
 
-        CmmStore addr src -> CmmStore (fixStgRegExpr addr) (fixStgRegExpr src)
+        CmmStore addr src -> CmmStore (fixStgRegExpr dflags addr) (fixStgRegExpr dflags src)
 
         CmmCall target regs args returns ->
             let target' = case target of
-                    CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv
+                    CmmCallee e conv -> CmmCallee (fixStgRegExpr dflags e) conv
                     CmmPrim op mStmts ->
-                        CmmPrim op (fmap (map fixStgRegStmt) mStmts)
+                        CmmPrim op (fmap (map (fixStgRegStmt dflags)) mStmts)
                 args' = map (\(CmmHinted arg hint) ->
-                                (CmmHinted (fixStgRegExpr arg) hint)) args
+                                (CmmHinted (fixStgRegExpr dflags arg) hint)) args
             in CmmCall target' regs args' returns
 
-        CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr test) dest
+        CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr dflags test) dest
 
-        CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids
+        CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr dflags expr) ids
 
-        CmmJump addr live -> CmmJump (fixStgRegExpr addr) live
+        CmmJump addr live -> CmmJump (fixStgRegExpr dflags addr) live
 
         -- CmmNop, CmmComment, CmmBranch, CmmReturn
         _other -> stmt
+    where platform = targetPlatform dflags
 
 
-fixStgRegExpr :: CmmExpr ->  CmmExpr
-fixStgRegExpr expr
+fixStgRegExpr :: DynFlags -> CmmExpr -> CmmExpr
+fixStgRegExpr dflags expr
   = case expr of
-        CmmLoad addr ty -> CmmLoad (fixStgRegExpr addr) ty
+        CmmLoad addr ty -> CmmLoad (fixStgRegExpr dflags addr) ty
 
         CmmMachOp mop args -> CmmMachOp mop args'
-            where args' = map fixStgRegExpr args
+            where args' = map (fixStgRegExpr dflags) args
 
         CmmReg (CmmGlobal reg) ->
             -- Replace register leaves with appropriate StixTrees for
@@ -1039,26 +904,27 @@ fixStgRegExpr expr
             -- 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
+            case reg `elem` activeStgRegs platform of
                 True  -> expr
                 False ->
-                    let baseAddr = get_GlobalReg_addr reg
+                    let baseAddr = get_GlobalReg_addr dflags reg
                     in case reg of
-                        BaseReg -> fixStgRegExpr baseAddr
-                        _other  -> fixStgRegExpr
-                                    (CmmLoad baseAddr (globalRegType reg))
+                        BaseReg -> fixStgRegExpr dflags baseAddr
+                        _other  -> fixStgRegExpr dflags
+                                    (CmmLoad baseAddr (globalRegType dflags 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
+            case reg `elem` activeStgRegs platform of
                 True  -> expr
-                False -> fixStgRegExpr (CmmMachOp (MO_Add wordWidth) [
+                False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [
                                     CmmReg (CmmGlobal reg),
                                     CmmLit (CmmInt (fromIntegral offset)
-                                                wordWidth)])
+                                                (wordWidth dflags))])
 
         -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
         _other -> expr
+    where platform = targetPlatform dflags