Produce new-style Cmm from the Cmm parser
[ghc.git] / compiler / codeGen / CgUtils.hs
index fa5807a..9f9a2cf 100644 (file)
@@ -1,10 +1,3 @@
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 -----------------------------------------------------------------------------
 --
 -- Code generator utilities; mostly monadic
 -----------------------------------------------------------------------------
 
 module CgUtils (
-       addIdReps,
-       cgLit,
-       emitDataLits, mkDataLits,
+        addIdReps,
+        cgLit,
+        emitDataLits, mkDataLits,
         emitRODataLits, mkRODataLits,
         emitIf, emitIfThenElse,
-       emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
-       assignNonPtrTemp, newNonPtrTemp,
-       assignPtrTemp, newPtrTemp,
-       emitSimultaneously,
-       emitSwitch, emitLitSwitch,
-       tagToClosure,
-
-        callerSaveVolatileRegs, get_GlobalReg_addr,
-
-       cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
-        cmmUGtWord,
-       cmmOffsetExprW, cmmOffsetExprB,
-       cmmRegOffW, cmmRegOffB,
-       cmmLabelOffW, cmmLabelOffB,
-       cmmOffsetW, cmmOffsetB,
-       cmmOffsetLitW, cmmOffsetLitB,
-       cmmLoadIndexW,
+        emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
+        emitRtsCallGen,
+        assignTemp, assignTemp_, newTemp,
+        emitSimultaneously,
+        emitSwitch, emitLitSwitch,
+        tagToClosure,
+
+        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
+        activeStgRegs, fixStgRegisters,
+
+        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
+        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
+        cmmOffsetExprW, cmmOffsetExprB,
+        cmmRegOffW, cmmRegOffB,
+        cmmLabelOffW, cmmLabelOffB,
+        cmmOffsetW, cmmOffsetB,
+        cmmOffsetLitW, cmmOffsetLitB,
+        cmmLoadIndexW,
         cmmConstrTag, cmmConstrTag1,
 
         tagForCon, tagCons, isSmallFamily,
         cmmUntag, cmmIsTagged, cmmGetTag,
 
-       addToMem, addToMemE,
-       mkWordCLit,
-       mkStringCLit, mkByteStringCLit,
-       packHalfWordsCLit,
-       blankWord,
+        addToMem, addToMemE,
+        mkWordCLit,
+        newStringCLit, newByteStringCLit,
+        packHalfWordsCLit,
+        blankWord,
 
-       getSRTInfo
+        getSRTInfo
   ) where
 
 #include "HsVersions.h"
-#include "MachRegs.h"
 
+import BlockId
+import CodeGen.Platform
 import CgMonad
 import TyCon
 import DataCon
 import Id
-import Constants
+import IdInfo
 import SMRep
-import PprCmm          ( {- instances -} )
-import Cmm
+import OldCmm
+import OldCmmUtils
 import CLabel
-import CmmUtils
-import MachOp
 import ForeignCall
 import ClosureInfo
 import StgSyn (SRT(..))
+import Module
 import Literal
 import Digraph
 import ListSetOps
 import Util
 import DynFlags
 import FastString
-import PackageConfig
 import Outputable
 
 import Data.Char
-import Data.Bits
 import Data.Word
+import Data.List
 import Data.Maybe
+import Data.Ord
 
 -------------------------------------------------------------------------
 --
---     Random small functions
+--      Random small functions
 --
 -------------------------------------------------------------------------
 
@@ -92,123 +86,49 @@ addIdReps ids = [(idCgRep id, id) | id <- ids]
 
 -------------------------------------------------------------------------
 --
---     Literals
+--      Literals
 --
 -------------------------------------------------------------------------
 
 cgLit :: Literal -> FCode CmmLit
-cgLit (MachStr s) = mkByteStringCLit (bytesFS s)
- -- not unpackFS; we want the UTF-8 byte stream.
-cgLit other_lit   = return (mkSimpleLit other_lit)
-
-mkSimpleLit :: Literal -> CmmLit
-mkSimpleLit (MachChar  c)    = CmmInt (fromIntegral (ord c)) wordRep
-mkSimpleLit MachNullAddr      = zeroCLit
-mkSimpleLit (MachInt i)       = CmmInt i wordRep
-mkSimpleLit (MachInt64 i)     = CmmInt i I64
-mkSimpleLit (MachWord i)      = CmmInt i wordRep
-mkSimpleLit (MachWord64 i)    = CmmInt i I64
-mkSimpleLit (MachFloat r)     = CmmFloat r F32
-mkSimpleLit (MachDouble r)    = CmmFloat r F64
-mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn)
-                             where
-                               is_dyn = False  -- ToDo: fix me
-       
-mkLtOp :: Literal -> MachOp
+cgLit (MachStr s) = newByteStringCLit (bytesFB s)
+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"
+-- 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"
+
+mkLtOp :: DynFlags -> Literal -> MachOp
 -- On signed literals we must do a signed comparison
-mkLtOp (MachInt _)    = MO_S_Lt wordRep
-mkLtOp (MachFloat _)  = MO_S_Lt F32
-mkLtOp (MachDouble _) = MO_S_Lt F64
-mkLtOp lit           = MO_U_Lt (cmmLitRep (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)))
 
 
 ---------------------------------------------------
 --
---     Cmm data type functions
+--      Cmm data type functions
 --
 ---------------------------------------------------
 
------------------------
--- The "B" variants take byte offsets
-cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
-cmmRegOffB = cmmRegOff
-
-cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
-cmmOffsetB = cmmOffset
-
-cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
-cmmOffsetExprB = cmmOffsetExpr
-
-cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
-cmmLabelOffB = cmmLabelOff
-
-cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
-cmmOffsetLitB = cmmOffsetLit
-
------------------------
--- The "W" variants take word offsets
-cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
--- The second arg is a *word* offset; need to change it to bytes
-cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
-cmmOffsetExprW e wd_off = cmmIndexExpr wordRep e wd_off
-
-cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
-cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
-
-cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
-cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
-
-cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
-cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
-
-cmmLabelOffW :: CLabel -> WordOff -> CmmLit
-cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
-
-cmmLoadIndexW :: CmmExpr -> Int -> CmmExpr
-cmmLoadIndexW base off
-  = CmmLoad (cmmOffsetW base off) wordRep
-
------------------------
-cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr
-cmmOrWord  e1 e2 = CmmMachOp mo_wordOr  [e1, e2]
-cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
-cmmNeWord  e1 e2 = CmmMachOp mo_wordNe  [e1, e2]
-cmmEqWord  e1 e2 = CmmMachOp mo_wordEq  [e1, e2]
-cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
-cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
-cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
---cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
---cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
-cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
-
-cmmNegate :: CmmExpr -> CmmExpr
-cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
-cmmNegate e                      = CmmMachOp (MO_S_Neg (cmmExprRep e)) [e]
-
-blankWord :: CmmStatic
-blankWord = CmmUninitialised wORD_SIZE
-
--- Tagging --
--- Tag bits mask
---cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
-cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
-cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
-
--- Used to untag a possibly tagged pointer
--- A static label need not be untagged
-cmmUntag e@(CmmLit (CmmLabel _)) = e
--- Default case
-cmmUntag e = (e `cmmAndWord` cmmPointerMask)
 
-cmmGetTag e = (e `cmmAndWord` cmmTagMask)
-
--- Test if a closure pointer is untagged
-cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
-                 `cmmNeWord` CmmLit zeroCLit
-
-cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
--- Get constructor tag, but one based.
-cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
 
 {-
    The family size of a data type (the number of constructors)
@@ -221,44 +141,20 @@ cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
    Big families only use the tag value 1 to represent
    evaluatedness.
 -}
-isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
+isSmallFamily :: DynFlags -> Int -> Bool
+isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
 
-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 con expr = cmmOffsetB expr (tagForCon con)
-
--- Copied from CgInfoTbls.hs
--- We keep the *zero-indexed* tag in the srt_len field of the info
--- table of a data constructor.
-dataConTagZ :: DataCon -> ConTagZ
-dataConTagZ con = dataConTag con - fIRST_TAG
-
------------------------
---     Making literals
-
-mkWordCLit :: StgWord -> CmmLit
-mkWordCLit wd = CmmInt (fromIntegral wd) wordRep
-
-packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
--- Make a single word literal in which the lower_half_word is
--- at the lower address, and the upper_half_word is at the 
--- higher address
--- ToDo: consider using half-word lits instead
---      but be careful: that's vulnerable when reversed
-packHalfWordsCLit lower_half_word upper_half_word
-#ifdef WORDS_BIGENDIAN
-   = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
-                .|. fromIntegral upper_half_word)
-#else 
-   = mkWordCLit ((fromIntegral lower_half_word) 
-                .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
-#endif
+tagCons :: DynFlags -> DataCon -> CmmExpr -> CmmExpr
+tagCons dflags con expr = cmmOffsetB dflags expr (tagForCon dflags con)
 
 --------------------------------------------------------------------------
 --
@@ -266,41 +162,41 @@ packHalfWordsCLit lower_half_word upper_half_word
 --
 --------------------------------------------------------------------------
 
-addToMem :: MachRep    -- rep of the counter
-        -> CmmExpr     -- Address
-        -> Int         -- What to add (a word)
-        -> CmmStmt
-addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) rep))
+addToMem :: Width       -- rep of the counter
+         -> CmmExpr     -- Address
+         -> Int         -- What to add (a word)
+         -> CmmStmt
+addToMem width ptr n = addToMemE width ptr (CmmLit (CmmInt (toInteger n) width))
 
-addToMemE :: MachRep   -- rep of the counter
-         -> CmmExpr    -- Address
-         -> CmmExpr    -- What to add (a word-typed expression)
-         -> CmmStmt
-addToMemE rep ptr n
-  = CmmStore ptr (CmmMachOp (MO_Add rep) [CmmLoad ptr rep, n])
+addToMemE :: Width      -- rep of the counter
+          -> CmmExpr    -- Address
+          -> CmmExpr    -- What to add (a word-typed expression)
+          -> CmmStmt
+addToMemE width ptr n
+  = CmmStore ptr (CmmMachOp (MO_Add width) [CmmLoad ptr (cmmBits width), n])
 
 -------------------------------------------------------------------------
 --
---     Converting a closure tag to a closure for enumeration types
+--      Converting a closure tag to a closure for enumeration types
 --      (this is the implementation of tagToEnum#).
 --
 -------------------------------------------------------------------------
 
-tagToClosure :: TyCon -> CmmExpr -> CmmExpr
-tagToClosure tycon tag
-  = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep
+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)
+        lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
 
 -------------------------------------------------------------------------
 --
---     Conditionals and rts calls
+--      Conditionals and rts calls
 --
 -------------------------------------------------------------------------
 
-emitIf :: CmmExpr      -- Boolean
-       -> Code         -- Then part
-       -> Code         
+emitIf :: CmmExpr       -- Boolean
+       -> Code          -- Then part
+       -> Code
 -- Emit (if e then x)
 -- ToDo: reverse the condition to avoid the extra branch instruction if possible
 -- (some conditionals aren't reversible. eg. floating point comparisons cannot
@@ -316,14 +212,13 @@ emitIf cond then_part
        ; labelC join_id
        }
 
-emitIfThenElse :: CmmExpr      -- Boolean
-                       -> Code         -- Then part
-                       -> Code         -- Else part
-                       -> Code         
+emitIfThenElse :: CmmExpr       -- Boolean
+                -> Code         -- Then part
+                -> Code         -- Else part
+                -> Code
 -- Emit (if e then x else y)
 emitIfThenElse cond then_part else_part
   = do { then_id <- newLabelC
-       ; else_id <- newLabelC
        ; join_id <- newLabelC
        ; stmtC (CmmCondBranch cond then_id)
        ; else_part
@@ -333,42 +228,50 @@ emitIfThenElse cond then_part else_part
        ; labelC join_id
        }
 
-emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code
-emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
+
+-- | Emit code to call a Cmm function.
+emitRtsCall
+   :: PackageId                 -- ^ package the function is in
+   -> FastString                -- ^ name of function
+   -> [CmmHinted CmmExpr]       -- ^ function args
+   -> Code                      -- ^ cmm code
+
+emitRtsCall pkg fun args = emitRtsCallGen [] pkg fun args Nothing
    -- The 'Nothing' says "save all global registers"
 
-emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code
-emitRtsCallWithVols fun args vols safe
-   = emitRtsCall' [] fun args (Just vols) safe
+emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Code
+emitRtsCallWithVols pkg fun args vols
+   = emitRtsCallGen [] pkg fun args (Just vols)
 
-emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
-       -> [(CmmExpr,MachHint)] -> Bool -> Code
-emitRtsCallWithResult res hint fun args safe
-   = emitRtsCall' [(res,hint)] fun args Nothing safe
+emitRtsCallWithResult
+   :: LocalReg -> ForeignHint
+   -> PackageId -> FastString
+   -> [CmmHinted CmmExpr] -> Code
+
+emitRtsCallWithResult res hint pkg fun args
+   = emitRtsCallGen [CmmHinted res hint] pkg fun args Nothing
 
 -- Make a call to an RTS C procedure
-emitRtsCall'
-   :: CmmFormals
-   -> LitString
-   -> [(CmmExpr,MachHint)]
+emitRtsCallGen
+   :: [CmmHinted LocalReg]
+   -> PackageId
+   -> FastString
+   -> [CmmHinted CmmExpr]
    -> Maybe [GlobalReg]
-   -> Bool -- True <=> CmmSafe call
    -> Code
-emitRtsCall' res fun args vols safe = do
-  safety <- if safe
-            then getSRTInfo >>= (return . CmmSafe)
-            else return CmmUnsafe
+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 safety CmmMayReturn)
+  stmtC (CmmCall target res args CmmMayReturn)
   stmtsC caller_load
   where
-    (caller_save, caller_load) = callerSaveVolatileRegs vols
     target   = CmmCallee fun_expr CCallConv
-    fun_expr = mkLblExpr (mkRtsCodeLabel fun)
+    fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
 
 -----------------------------------------------------------------------------
 --
---     Caller-Save Registers
+--      Caller-Save Registers
 --
 -----------------------------------------------------------------------------
 
@@ -379,318 +282,209 @@ emitRtsCall' res fun args vols safe = 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)
 
-    system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
-                  {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
+    system_regs = [Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery,
+                   {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
 
     regs_to_save = system_regs ++ vol_list
 
     vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
 
-    all_of_em = [ VanillaReg n | n <- [0..mAX_Vanilla_REG] ]
-            ++ [ FloatReg   n | n <- [0..mAX_Float_REG] ]
-            ++ [ DoubleReg  n | n <- [0..mAX_Double_REG] ]
-            ++ [ LongReg    n | n <- [0..mAX_Long_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 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) 
-                        (CmmReg (CmmGlobal reg)) : next
-       | otherwise = next
+        | callerSaves platform reg =
+                CmmStore (get_GlobalReg_addr dflags reg)
+                         (CmmReg (CmmGlobal reg)) : next
+        | otherwise = next
 
     callerRestoreGlobalReg reg next
-       | callerSaves reg = 
-               CmmAssign (CmmGlobal reg)
-                         (CmmLoad (get_GlobalReg_addr reg) (globalRegRep reg))
-                       : 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 
-                               (globalRegRep 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   :: MachRep -> 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.
-
-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_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_CurrentTSO
-callerSaves CurrentTSO         = True
-#endif
-#ifdef CALLER_SAVES_CurrentNursery
-callerSaves CurrentNursery     = True
-#endif
-callerSaves _                  = False
+        | callerSaves platform reg =
+                CmmAssign (CmmGlobal reg)
+                          (CmmLoad (get_GlobalReg_addr dflags reg)
+                                   (globalRegType dflags reg))
+                        : next
+        | otherwise = next
 
 
 -- -----------------------------------------------------------------------------
 -- 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 (FloatReg  1)       = oFFSET_StgRegTable_rF1
-baseRegOffset (FloatReg  2)       = oFFSET_StgRegTable_rF2
-baseRegOffset (FloatReg  3)       = oFFSET_StgRegTable_rF3
-baseRegOffset (FloatReg  4)       = oFFSET_StgRegTable_rF4
-baseRegOffset (DoubleReg 1)       = oFFSET_StgRegTable_rD1
-baseRegOffset (DoubleReg 2)       = oFFSET_StgRegTable_rD2
-baseRegOffset Sp                 = oFFSET_StgRegTable_rSp
-baseRegOffset SpLim              = oFFSET_StgRegTable_rSpLim
-baseRegOffset (LongReg 1)         = oFFSET_StgRegTable_rL1
-baseRegOffset Hp                 = oFFSET_StgRegTable_rHp
-baseRegOffset HpLim              = oFFSET_StgRegTable_rHpLim
-baseRegOffset CurrentTSO         = oFFSET_StgRegTable_rCurrentTSO
-baseRegOffset CurrentNursery     = oFFSET_StgRegTable_rCurrentNursery
-baseRegOffset HpAlloc            = oFFSET_StgRegTable_rHpAlloc
-baseRegOffset GCEnter1           = oFFSET_stgGCEnter1
-baseRegOffset GCFun              = oFFSET_stgGCFun
-#ifdef DEBUG
-baseRegOffset BaseReg            = panic "baseRegOffset:BaseReg"
-baseRegOffset _                          = panic "baseRegOffset:other"
-#endif
+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"
 
 
 -------------------------------------------------------------------------
 --
---     Strings generate a top-level data block
+--      Strings generate a top-level data block
 --
 -------------------------------------------------------------------------
 
 emitDataLits :: CLabel -> [CmmLit] -> Code
 -- Emit a data-segment data block
-emitDataLits lbl lits
-  = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
-
-mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
--- Emit a data-segment data block
-mkDataLits lbl lits
-  = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+emitDataLits lbl lits = emitDecl (mkDataLits Data lbl lits)
 
-emitRODataLits :: CLabel -> [CmmLit] -> Code
+emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
 -- Emit a read-only data block
-emitRODataLits lbl lits
-  = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
-  where section | any needsRelocation lits = RelocatableReadOnlyData
-                | otherwise                = ReadOnlyData
-        needsRelocation (CmmLabel _)      = True
-        needsRelocation (CmmLabelOff _ _) = True
-        needsRelocation _                 = False
-
-mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
-mkRODataLits lbl lits
-  = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
-  where section | any needsRelocation lits = RelocatableReadOnlyData
-                | otherwise                = ReadOnlyData
-        needsRelocation (CmmLabel _)      = True
-        needsRelocation (CmmLabelOff _ _) = True
-        needsRelocation _                 = False
-
-mkStringCLit :: String -> FCode CmmLit
+emitRODataLits _caller lbl lits
+  = emitDecl (mkRODataLits lbl lits)
+
+newStringCLit :: String -> FCode CmmLit
 -- Make a global definition for the string,
 -- and return its label
-mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
+newStringCLit str = newByteStringCLit (map (fromIntegral.ord) str)
 
-mkByteStringCLit :: [Word8] -> FCode CmmLit
-mkByteStringCLit bytes
-  = do         { uniq <- newUnique
-       ; let lbl = mkStringLitLabel uniq
-       ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
-       ; return (CmmLabel lbl) }
+newByteStringCLit :: [Word8] -> FCode CmmLit
+newByteStringCLit bytes
+  = do  { uniq <- newUnique
+        ; let (lit, decl) = mkByteStringCLit uniq bytes
+        ; emitDecl decl
+        ; return lit }
 
 -------------------------------------------------------------------------
 --
---     Assigning expressions to temporaries
+--      Assigning expressions to temporaries
 --
 -------------------------------------------------------------------------
 
-assignNonPtrTemp :: CmmExpr -> FCode CmmExpr
--- For a non-trivial expression, e, create a local
--- variable and assign the expression to it
-assignNonPtrTemp e 
-  | isTrivialCmmExpr e = return e
-  | otherwise         = do { reg <- newNonPtrTemp (cmmExprRep e) 
-                           ; stmtC (CmmAssign (CmmLocal reg) e)
-                           ; return (CmmReg (CmmLocal reg)) }
-
-assignPtrTemp :: CmmExpr -> FCode CmmExpr
+-- | If the expression is trivial, return it.  Otherwise, assign the
+-- expression to a temporary register and return an expression
+-- referring to this register.
+assignTemp :: CmmExpr -> FCode CmmExpr
 -- For a non-trivial expression, e, create a local
 -- variable and assign the expression to it
-assignPtrTemp e 
+assignTemp e
   | isTrivialCmmExpr e = return e
-  | otherwise         = do { reg <- newPtrTemp (cmmExprRep e) 
-                           ; stmtC (CmmAssign (CmmLocal reg) e)
-                           ; return (CmmReg (CmmLocal reg)) }
-
-newNonPtrTemp :: MachRep -> FCode LocalReg
-newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep GCKindNonPtr) }
-
-newPtrTemp :: MachRep -> FCode LocalReg
-newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep GCKindPtr) }
-
+  | 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
+-- temporary register and return an expression referring to this
+-- register.
+assignTemp_ :: CmmExpr -> FCode CmmExpr
+assignTemp_ e
+    | isTrivialCmmExpr e && hasNoGlobalRegs e = return e
+    | otherwise = do
+        dflags <- getDynFlags
+        reg <- newTemp (cmmExprType dflags e)
+        stmtC (CmmAssign (CmmLocal reg) e)
+        return (CmmReg (CmmLocal reg))
+
+newTemp :: CmmType -> FCode LocalReg
+newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
 
 -------------------------------------------------------------------------
 --
---     Building case analysis
+--      Building case analysis
 --
 -------------------------------------------------------------------------
 
 emitSwitch
-       :: CmmExpr                -- Tag to switch on
-       -> [(ConTagZ, CgStmts)]   -- Tagged branches
-       -> Maybe CgStmts          -- Default branch (if any)
-       -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
-                                 --    outside this range is undefined
-       -> Code
+        :: CmmExpr                -- Tag to switch on
+        -> [(ConTagZ, CgStmts)]   -- Tagged branches
+        -> Maybe CgStmts          -- Default branch (if any)
+        -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
+                                  --    outside this range is undefined
+        -> Code
 
 -- ONLY A DEFAULT BRANCH: no case analysis to do
-emitSwitch tag_expr [] (Just stmts) _ _
+emitSwitch _ [] (Just stmts) _ _
   = emitCgStmts stmts
 
 -- Right, off we go
 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
-  =    -- Just sort the branches before calling mk_sritch
-    do { mb_deflt_id <-
-               case mb_deflt of
-                 Nothing    -> return Nothing
-                 Just stmts -> do id <- forkCgStmts stmts; return (Just id)
-
-       ; dflags <- getDynFlags
-       ; let via_C | HscC <- hscTarget dflags = True
-                   | otherwise                = False
-
-       ; stmts <- mk_switch tag_expr (sortLe le branches) 
-                       mb_deflt_id lo_tag hi_tag via_C
-       ; emitCgStmts stmts
-       }
-  where
-    (t1,_) `le` (t2,_) = t1 <= t2
+  =     -- Just sort the branches before calling mk_sritch
+    do  { mb_deflt_id <-
+                case mb_deflt of
+                  Nothing    -> return Nothing
+                  Just stmts -> do id <- forkCgStmts stmts; return (Just id)
+
+        ; dflags <- getDynFlags
+        ; let via_C | HscC <- hscTarget dflags = True
+                    | otherwise                = False
+
+        ; stmts <- mk_switch tag_expr (sortBy (comparing fst) branches)
+                        mb_deflt_id lo_tag hi_tag via_C
+        ; emitCgStmts stmts
+        }
 
 
 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
-         -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
-         -> FCode CgStmts
+          -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
+          -> FCode CgStmts
 
 -- SINGLETON TAG RANGE: no case analysis to do
-mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
+mk_switch _tag_expr [(tag,stmts)] _ lo_tag hi_tag _via_C
   | lo_tag == hi_tag
   = ASSERT( tag == lo_tag )
     return stmts
 
--- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
-mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
+-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
+mk_switch _tag_expr [(_tag,stmts)] Nothing _lo_tag _hi_tag _via_C
   = return stmts
-       -- The simplifier might have eliminated a case
-       --       so we may have e.g. case xs of 
-       --                               [] -> e
-       -- In that situation we can be sure the (:) case 
-       -- can't happen, so no need to test
+        -- The simplifier might have eliminated a case
+        --       so we may have e.g. case xs of
+        --                               [] -> e
+        -- In that situation we can be sure the (:) case
+        -- 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))
-       -- We have lo_tag < hi_tag, but there's only one branch, 
-       -- so there must be a default
+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
@@ -706,166 +500,170 @@ mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
 -- time works around that problem.
 --
 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)
-       ; let 
-               tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
+  | use_switch  -- Use a switch
+  = do  { dflags <- getDynFlags
+        ; branch_ids <- mapM forkCgStmts (map snd branches)
+        ; let
+                tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 
-               find_branch :: ConTagZ -> Maybe BlockId
-               find_branch i = assocDefault mb_deflt tagged_blk_ids i
+                find_branch :: ConTagZ -> Maybe BlockId
+                find_branch i = assocDefault mb_deflt tagged_blk_ids i
 
-               -- NB. we have eliminated impossible branches at
-               -- either end of the range (see below), so the first
-               -- tag of a real branch is real_lo_tag (not lo_tag).
-               arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
+                -- NB. we have eliminated impossible branches at
+                -- either end of the range (see below), so the first
+                -- 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)
-       }
+        ; ASSERT(not (all isNothing arms))
+          return (oneCgStmt switch_stmt)
+        }
 
   -- 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') <- assignNonPtrTemp' tag_expr
-       ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
-            branch = CmmCondBranch cond deflt
-       ; stmts <- mk_switch tag_expr' branches mb_deflt 
-                       lowest_branch hi_tag via_C
+  = 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
        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
        }
 
   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
-  = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
-       ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
-            branch = CmmCondBranch cond deflt
-       ; stmts <- mk_switch tag_expr' branches mb_deflt 
-                       lo_tag highest_branch via_C
+  = 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
        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
        }
 
-  | otherwise  -- Use an if-tree
-  = do { (assign_tag, tag_expr') <- assignNonPtrTemp' 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))
-             branch_stmt = CmmCondBranch cond hi_id
-       ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts)) 
-       }
-       -- we test (e >= mid_tag) rather than (e < mid_tag), because
-       -- the former works better when e is a comparison, and there
-       -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
-       -- generator can reduce the condition to e itself without
-       -- having to reverse the sense of the comparison: comparisons
-       -- can't always be easily reversed (eg. floating
-       -- pt. comparisons).
+  | otherwise   -- Use an if-tree
+  = 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 dflags tag_expr' (CmmLit (mkIntCLit dflags mid_tag))
+              branch_stmt = CmmCondBranch cond hi_id
+        ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
+        }
+        -- we test (e >= mid_tag) rather than (e < mid_tag), because
+        -- the former works better when e is a comparison, and there
+        -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
+        -- generator can reduce the condition to e itself without
+        -- having to reverse the sense of the comparison: comparisons
+        -- can't always be easily reversed (eg. floating
+        -- pt. comparisons).
   where
-    use_switch          = {- pprTrace "mk_switch" (
-                       ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
+    use_switch   = {- pprTrace "mk_switch" (
+                        ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
                         text "branches:" <+> ppr (map fst branches) <+>
-                       text "n_branches:" <+> int n_branches <+>
-                       text "lo_tag:" <+> int lo_tag <+>
-                       text "hi_tag:" <+> int hi_tag <+>
-                       text "real_lo_tag:" <+> int real_lo_tag <+>
-                       text "real_hi_tag:" <+> int real_hi_tag) $ -}
-                  ASSERT( n_branches > 1 && n_tags > 1 ) 
-                  n_tags > 2 && (via_C || (dense && big_enough))
-                -- up to 4 branches we use a decision tree, otherwise
+                        text "n_branches:" <+> int n_branches <+>
+                        text "lo_tag:" <+> int lo_tag <+>
+                        text "hi_tag:" <+> int hi_tag <+>
+                        text "real_lo_tag:" <+> int real_lo_tag <+>
+                        text "real_hi_tag:" <+> int real_hi_tag) $ -}
+                   ASSERT( n_branches > 1 && n_tags > 1 )
+                   n_tags > 2 && (via_C || (dense && big_enough))
+                 -- up to 4 branches we use a decision tree, otherwise
                  -- a switch (== jump table in the NCG).  This seems to be
                  -- optimal, and corresponds with what gcc does.
-    big_enough          = n_branches > 4
-    dense               = n_branches > (n_tags `div` 2)
+    big_enough   = n_branches > 4
+    dense        = n_branches > (n_tags `div` 2)
     n_branches   = length branches
-    
-    -- ignore default slots at each end of the range if there's 
+
+    -- ignore default slots at each end of the range if there's
     -- no default branch defined.
     lowest_branch  = fst (head branches)
     highest_branch = fst (last branches)
 
     real_lo_tag
-       | isNothing mb_deflt = lowest_branch
-       | otherwise          = lo_tag
+        | isNothing mb_deflt = lowest_branch
+        | otherwise          = lo_tag
 
     real_hi_tag
-       | isNothing mb_deflt = highest_branch
-       | otherwise          = hi_tag
+        | isNothing mb_deflt = highest_branch
+        | otherwise          = hi_tag
 
     n_tags = real_hi_tag - real_lo_tag + 1
 
-       -- INVARIANT: Provided hi_tag > lo_tag (which is true)
-       --      lo_tag <= mid_tag < hi_tag
-       --      lo_branches have tags <  mid_tag
-       --      hi_branches have tags >= mid_tag
+        -- INVARIANT: Provided hi_tag > lo_tag (which is true)
+        --      lo_tag <= mid_tag < hi_tag
+        --      lo_branches have tags <  mid_tag
+        --      hi_branches have tags >= mid_tag
 
     (mid_tag,_) = branches !! (n_branches `div` 2)
-       -- 2 branches => n_branches `div` 2 = 1
-       --            => branches !! 1 give the *second* tag
-       -- There are always at least 2 branches here
+        -- 2 branches => n_branches `div` 2 = 1
+        --            => branches !! 1 give the *second* tag
+        -- There are always at least 2 branches here
 
     (lo_branches, hi_branches) = span is_lo branches
     is_lo (t,_) = t < mid_tag
 
-
-assignNonPtrTemp' e
+assignTemp' :: CmmExpr -> FCode (CmmStmt, CmmExpr)
+assignTemp' e
   | isTrivialCmmExpr e = return (CmmNop, e)
-  | otherwise          = do { reg <- newNonPtrTemp (cmmExprRep e)
-                            ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
-
-emitLitSwitch :: CmmExpr                       -- Tag to switch on
-             -> [(Literal, CgStmts)]           -- Tagged branches
-             -> CgStmts                        -- Default branch (always)
-             -> Code                           -- Emit the code
--- Used for general literals, whose size might not be a word, 
+  | 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
+              -> CgStmts                        -- Default branch (always)
+              -> Code                           -- Emit the code
+-- Used for general literals, whose size might not be a word,
 -- where there is always a default case, and where we don't know
 -- the range of values for certain.  For simplicity we always generate a tree.
 --
 -- ToDo: for integers we could do better here, perhaps by generalising
 -- mk_switch and using that.  --SDM 15/09/2004
-emitLitSwitch scrut [] deflt 
-  = emitCgStmts deflt
+emitLitSwitch _     []       deflt = emitCgStmts deflt
 emitLitSwitch scrut branches deflt_blk
-  = do { scrut' <- assignNonPtrTemp scrut
-       ; deflt_blk_id <- forkCgStmts deflt_blk
-       ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
-       ; emitCgStmts blk }
-  where
-    le (t1,_) (t2,_) = t1 <= t2
-
-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     = cmmLitRep cmm_lit
-    cond    = CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]
-    if_stmt = CmmCondBranch cond deflt_blk_id
+  = do  { scrut' <- assignTemp scrut
+        ; deflt_blk_id <- forkCgStmts deflt_blk
+        ; blk <- mk_lit_switch scrut' deflt_blk_id (sortBy (comparing fst) branches)
+        ; emitCgStmts blk }
+
+mk_lit_switch :: CmmExpr -> BlockId
+              -> [(Literal,CgStmts)]
+              -> FCode CgStmts
+mk_lit_switch scrut deflt_blk_id [(lit,blk)]
+  = 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
-       ; 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
-       ; return (if_stmt `consCgStmt` hi_blk) }
+  = 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 dflags) lo_blk_id
+        ; return (if_stmt `consCgStmt` hi_blk) }
   where
     n_branches = length branches
     (mid_lit,_) = branches !! (n_branches `div` 2)
-       -- See notes above re mid_tag
+        -- See notes above re mid_tag
 
     (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)]
 
 -------------------------------------------------------------------------
 --
---     Simultaneous assignment
+--      Simultaneous assignment
 --
 -------------------------------------------------------------------------
 
@@ -875,110 +673,110 @@ emitSimultaneously :: CmmStmts -> Code
 -- input simultaneously, using temporary variables when necessary.
 --
 -- The Stmts must be:
---     CmmNop, CmmComment, CmmAssign, CmmStore
+--      CmmNop, CmmComment, CmmAssign, CmmStore
 -- and nothing else
 
 
 -- We use the strongly-connected component algorithm, in which
---     * the vertices are the statements
---     * an edge goes from s1 to s2 iff
---             s1 assigns to something s2 uses
---       that is, if s1 should *follow* s2 in the final order
+--      * the vertices are the statements
+--      * an edge goes from s1 to s2 iff
+--              s1 assigns to something s2 uses
+--        that is, if s1 should *follow* s2 in the final order
 
-type CVertex = (Int, CmmStmt)  -- Give each vertex a unique number,
-                               -- for fast comparison
+type CVertex = (Int, CmmStmt)   -- Give each vertex a unique number,
+                                -- for fast comparison
 
 emitSimultaneously stmts
   = codeOnly $
-    case filterOut isNopStmt (stmtList stmts) of 
-       -- Remove no-ops
-      []       -> nopC
-      [stmt]   -> stmtC stmt   -- It's often just one stmt
+    case filterOut isNopStmt (stmtList stmts) of
+        -- Remove no-ops
+      []        -> nopC
+      [stmt]    -> stmtC stmt   -- It's often just one stmt
       stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
 
 doSimultaneously1 :: [CVertex] -> Code
-doSimultaneously1 vertices
-  = let
-       edges = [ (vertex, key1, edges_from stmt1)
-               | vertex@(key1, stmt1) <- vertices
-               ]
-       edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, 
-                                   stmt1 `mustFollow` stmt2
-                          ]
-       components = stronglyConnComp edges
-
-       -- do_components deal with one strongly-connected component
-       -- Not cyclic, or singleton?  Just do it
-       do_component (AcyclicSCC (n,stmt))  = stmtC stmt
-       do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
-
-               -- Cyclic?  Then go via temporaries.  Pick one to
-               -- break the loop and try again with the rest.
-       do_component (CyclicSCC ((n,first_stmt) : rest))
-         = do  { from_temp <- go_via_temp first_stmt
-               ; doSimultaneously1 rest
-               ; stmtC from_temp }
-
-       go_via_temp (CmmAssign dest src)
-         = do  { tmp <- newNonPtrTemp (cmmRegRep 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 <- newNonPtrTemp (cmmExprRep src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
-               ; stmtC (CmmAssign (CmmLocal tmp) src)
-               ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
-    in
+doSimultaneously1 vertices = do
+    dflags <- getDynFlags
+    let
+        edges = [ (vertex, key1, edges_from stmt1)
+                | vertex@(key1, stmt1) <- vertices
+                ]
+        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
+                                    mustFollow dflags stmt1 stmt2
+                           ]
+        components = stronglyConnCompFromEdgedVertices edges
+
+        -- do_components deal with one strongly-connected component
+        -- Not cyclic, or singleton?  Just do it
+        do_component (AcyclicSCC (_n, stmt))  = stmtC stmt
+        do_component (CyclicSCC [])
+            = panic "doSimultaneously1: do_component (CyclicSCC [])"
+        do_component (CyclicSCC [(_n, stmt)]) = stmtC stmt
+
+                -- Cyclic?  Then go via temporaries.  Pick one to
+                -- break the loop and try again with the rest.
+        do_component (CyclicSCC ((_n, first_stmt) : rest))
+          = do  { from_temp <- go_via_temp first_stmt
+                ; doSimultaneously1 rest
+                ; stmtC from_temp }
+
+        go_via_temp (CmmAssign dest src)
+          = 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 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"
     mapCs do_component components
 
-mustFollow :: CmmStmt -> CmmStmt -> Bool
-CmmAssign reg _  `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
-CmmStore loc e   `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprRep e)) stmt
-CmmNop           `mustFollow` stmt = False
-CmmComment _     `mustFollow` stmt = False
+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
 -- True if the fn is true of any input of the stmt
 anySrc p (CmmAssign _ e)    = p e
-anySrc p (CmmStore e1 e2)   = p e1 || p e2     -- Might be used in either side
-anySrc p (CmmComment _)            = False
-anySrc p CmmNop                    = False
-anySrc p other             = True              -- Conservative
-
-regUsedIn :: CmmReg -> CmmExpr -> Bool
-reg `regUsedIn` CmmLit _        = False
-reg `regUsedIn` CmmLoad e  _    = reg `regUsedIn` e
-reg `regUsedIn` CmmReg reg'     = reg == reg'
-reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
-reg `regUsedIn` CmmMachOp _ es   = any (reg `regUsedIn`) es
-
-locUsedIn :: CmmExpr -> MachRep -> CmmExpr -> Bool
+anySrc p (CmmStore e1 e2)   = p e1 || p e2      -- Might be used in either side
+anySrc _ (CmmComment _)     = False
+anySrc _ CmmNop             = False
+anySrc _ _                  = True              -- Conservative
+
+locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool
 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
 -- 'e'.  Returns True if it's not sure.
-locUsedIn loc rep (CmmLit _)        = False
+locUsedIn _   _   (CmmLit _)         = False
 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
-locUsedIn loc rep (CmmReg reg')      = False
-locUsedIn loc rep (CmmRegOff reg' _) = False
+locUsedIn _   _   (CmmReg _)         = False
+locUsedIn _   _   (CmmRegOff _ _)    = False
 locUsedIn loc rep (CmmMachOp _ es)   = any (locUsedIn loc rep) es
+locUsedIn _   _   (CmmStackSlot _ _) = panic "locUsedIn: CmmStackSlot"
 
-possiblySameLoc :: CmmExpr -> MachRep -> CmmExpr -> MachRep -> Bool
--- Assumes that distinct registers (eg Hp, Sp) do not 
+possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
+-- Assumes that distinct registers (eg Hp, Sp) do not
 -- point to the same location, nor any offset thereof.
-possiblySameLoc (CmmReg r1)       rep1 (CmmReg r2)      rep2  = r1==r2
-possiblySameLoc (CmmReg r1)       rep1 (CmmRegOff r2 0) rep2  = r1==r2
-possiblySameLoc (CmmRegOff r1 0)  rep1 (CmmReg r2)      rep2  = r1==r2
-possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2 
+possiblySameLoc (CmmReg r1)           _    (CmmReg r2)           _ = r1 == r2
+possiblySameLoc (CmmReg r1)           _    (CmmRegOff r2 0)      _ = r1 == r2
+possiblySameLoc (CmmRegOff r1 0)      _    (CmmReg r2)           _ = r1 == r2
+possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
   = r1==r2 && end1 > start2 && end2 > start1
   where
-    end1 = start1 + machRepByteWidth rep1
-    end2 = start2 + machRepByteWidth rep2
+    end1 = start1 + widthInBytes (typeWidth rep1)
+    end2 = start2 + widthInBytes (typeWidth rep2)
 
-possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
-possiblySameLoc l1 rep1 l2        rep2 = True  -- Conservative
+possiblySameLoc _  _    (CmmLit _) _    = False
+possiblySameLoc _  _    _          _    = True  -- Conservative
 
 -------------------------------------------------------------------------
 --
---     Static Reference Tables
+--      Static Reference Tables
 --
 -------------------------------------------------------------------------
 
@@ -988,25 +786,145 @@ possiblySameLoc l1 rep1 l2          rep2 = True  -- Conservative
 
 getSRTInfo :: FCode C_SRT
 getSRTInfo = do
+  dflags <- getDynFlags
   srt_lbl <- getSRTLabel
   srt <- getSRT
   case srt of
     -- TODO: Should we panic in this case?
     -- Someone obviously thinks there should be an SRT
     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 srt_desc_lbl
-             ( cmmLabelOffW srt_lbl off
-              : mkWordCLit (fromIntegral len)
-              : map mkWordCLit bmp)
-           return (C_SRT srt_desc_lbl 0 srt_escape)
+            emitRODataLits "getSRTInfo" srt_desc_lbl
+             ( cmmLabelOffW dflags srt_lbl off
+               : mkWordCLit dflags (toInteger len)
+               : map (mkWordCLit dflags . fromStgWord) bmp)
+            return (C_SRT srt_desc_lbl 0 (srt_escape dflags))
 
-    SRT off len bmp
-      | otherwise 
-      -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
-               -- The fromIntegral converts to StgHalfWord
+      | otherwise
+      -> return (C_SRT srt_lbl off (toStgHalfWord dflags (fromStgWord (head bmp))))
+                -- The fromIntegral converts to StgHalfWord
+
+srt_escape :: DynFlags -> StgHalfWord
+srt_escape dflags = toStgHalfWord dflags (-1)
+
+-- -----------------------------------------------------------------------------
+--
+-- STG/Cmm GlobalReg
+--
+-- -----------------------------------------------------------------------------
+
+-- | 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 :: 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 :: 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 :: DynFlags -> RawCmmDecl -> RawCmmDecl
+fixStgRegisters _ top@(CmmData _ _) = top
+
+fixStgRegisters dflags (CmmProc info lbl (ListGraph blocks)) =
+  let blocks' = map (fixStgRegBlock dflags) blocks
+  in CmmProc info lbl $ ListGraph blocks'
+
+fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock
+fixStgRegBlock dflags (BasicBlock id stmts) =
+  let stmts' = map (fixStgRegStmt dflags) stmts
+  in BasicBlock id stmts'
+
+fixStgRegStmt :: DynFlags -> CmmStmt -> CmmStmt
+fixStgRegStmt dflags stmt
+  = case stmt of
+        CmmAssign (CmmGlobal reg) src ->
+            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 dflags src
+            in CmmAssign reg 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 dflags e) conv
+                    CmmPrim op mStmts ->
+                        CmmPrim op (fmap (map (fixStgRegStmt dflags)) mStmts)
+                args' = map (\(CmmHinted arg hint) ->
+                                (CmmHinted (fixStgRegExpr dflags arg) hint)) args
+            in CmmCall target' regs args' returns
+
+        CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr dflags test) dest
+
+        CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr dflags expr) ids
+
+        CmmJump addr live -> CmmJump (fixStgRegExpr dflags addr) live
+
+        -- CmmNop, CmmComment, CmmBranch, CmmReturn
+        _other -> stmt
+    where platform = targetPlatform dflags
+
+
+fixStgRegExpr :: DynFlags -> CmmExpr -> CmmExpr
+fixStgRegExpr dflags expr
+  = case expr of
+        CmmLoad addr ty -> CmmLoad (fixStgRegExpr dflags addr) ty
+
+        CmmMachOp mop args -> CmmMachOp mop args'
+            where args' = map (fixStgRegExpr dflags) 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 platform of
+                True  -> expr
+                False ->
+                    let baseAddr = get_GlobalReg_addr dflags reg
+                    in case reg of
+                        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 platform of
+                True  -> expr
+                False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [
+                                    CmmReg (CmmGlobal reg),
+                                    CmmLit (CmmInt (fromIntegral offset)
+                                                (wordWidth dflags))])
+
+        -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
+        _other -> expr
+    where platform = targetPlatform dflags
 
-srt_escape = (-1) :: StgHalfWord