Some alpha renaming
[ghc.git] / compiler / nativeGen / AsmCodeGen.lhs
index b818b01..a233a8f 100644 (file)
@@ -1,19 +1,12 @@
 -- -----------------------------------------------------------------------------
 --
 -- (c) The University of Glasgow 1993-2004
--- 
+--
 -- This is the top-level module in the native code generator.
 --
 -- -----------------------------------------------------------------------------
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module AsmCodeGen ( nativeCodeGen ) where
 
 #include "HsVersions.h"
@@ -40,12 +33,12 @@ import qualified PPC.Instr
 import qualified PPC.Ppr
 
 import RegAlloc.Liveness
-import qualified RegAlloc.Linear.Main          as Linear
+import qualified RegAlloc.Linear.Main           as Linear
 
-import qualified GraphColor                    as Color
-import qualified RegAlloc.Graph.Main           as Color
-import qualified RegAlloc.Graph.Stats          as Color
-import qualified RegAlloc.Graph.TrivColorable  as Color
+import qualified GraphColor                     as Color
+import qualified RegAlloc.Graph.Main            as Color
+import qualified RegAlloc.Graph.Stats           as Color
+import qualified RegAlloc.Graph.TrivColorable   as Color
 
 import TargetReg
 import Platform
@@ -56,22 +49,19 @@ import Reg
 import NCGMonad
 
 import BlockId
-import CgUtils         ( fixStgRegisters )
+import CgUtils          ( fixStgRegisters )
 import OldCmm
-import CmmOpt          ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
+import CmmOpt           ( cmmMachOpFold )
 import OldPprCmm
 import CLabel
 
 import UniqFM
-import Unique          ( Unique, getUnique )
 import UniqSupply
 import DynFlags
-import StaticFlags
 import Util
 
 import BasicTypes       ( Alignment )
 import Digraph
-import Pretty (Doc)
 import qualified Pretty
 import BufWrite
 import Outputable
@@ -123,7 +113,7 @@ The machine-dependent bits break down as follows:
     machine instructions.
 
   * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
-    a 'Doc').
+    a 'SDoc').
 
   * ["RegAllocInfo"] In the register allocator, we manipulate
     'MRegsState's, which are 'BitSet's, one bit per machine register.
@@ -148,11 +138,12 @@ data NcgImpl statics instr jumpDest = NcgImpl {
     canShortcut               :: instr -> Maybe jumpDest,
     shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
     shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
-    pprNatCmmDecl              :: Platform -> NatCmmDecl statics instr -> Doc,
+    pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,
     maxSpillSlots             :: Int,
     allocatableRegs           :: [RealReg],
     ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
     ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
+    ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr,
     ncgMakeFarBranches        :: [NatBasicBlock instr] -> [NatBasicBlock instr]
     }
 
@@ -160,19 +151,20 @@ data NcgImpl statics instr jumpDest = NcgImpl {
 nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
 nativeCodeGen dflags h us cmms
  = let platform = targetPlatform dflags
-       nCG' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
+       nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
        nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
        x86NcgImpl = NcgImpl {
                          cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
-                        ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
+                        ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
                         ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId
                         ,canShortcut               = X86.Instr.canShortcut
                         ,shortcutStatics           = X86.Instr.shortcutStatics
                         ,shortcutJump              = X86.Instr.shortcutJump
                         ,pprNatCmmDecl              = X86.Ppr.pprNatCmmDecl
-                        ,maxSpillSlots             = X86.Instr.maxSpillSlots (target32Bit platform)
-                        ,allocatableRegs           = X86.Regs.allocatableRegs
+                        ,maxSpillSlots             = X86.Instr.maxSpillSlots dflags
+                        ,allocatableRegs           = X86.Regs.allocatableRegs platform
                         ,ncg_x86fp_kludge          = id
+                        ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform
                         ,ncgExpandTop              = id
                         ,ncgMakeFarBranches        = id
                     }
@@ -182,47 +174,66 @@ nativeCodeGen dflags h us cmms
                  ArchPPC ->
                      nCG' $ NcgImpl {
                           cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen
-                         ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
+                         ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
                          ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId
                          ,canShortcut               = PPC.RegInfo.canShortcut
                          ,shortcutStatics           = PPC.RegInfo.shortcutStatics
                          ,shortcutJump              = PPC.RegInfo.shortcutJump
                          ,pprNatCmmDecl              = PPC.Ppr.pprNatCmmDecl
-                         ,maxSpillSlots             = PPC.Instr.maxSpillSlots
-                         ,allocatableRegs           = PPC.Regs.allocatableRegs
+                         ,maxSpillSlots             = PPC.Instr.maxSpillSlots dflags
+                         ,allocatableRegs           = PPC.Regs.allocatableRegs platform
                          ,ncg_x86fp_kludge          = id
+                         ,ncgAllocMoreStack         = noAllocMoreStack
                          ,ncgExpandTop              = id
                          ,ncgMakeFarBranches        = makeFarBranches
                      }
                  ArchSPARC ->
                      nCG' $ NcgImpl {
                           cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen
-                         ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
+                         ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
                          ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId
                          ,canShortcut               = SPARC.ShortcutJump.canShortcut
                          ,shortcutStatics           = SPARC.ShortcutJump.shortcutStatics
                          ,shortcutJump              = SPARC.ShortcutJump.shortcutJump
                          ,pprNatCmmDecl              = SPARC.Ppr.pprNatCmmDecl
-                         ,maxSpillSlots             = SPARC.Instr.maxSpillSlots
+                         ,maxSpillSlots             = SPARC.Instr.maxSpillSlots dflags
                          ,allocatableRegs           = SPARC.Regs.allocatableRegs
                          ,ncg_x86fp_kludge          = id
+                         ,ncgAllocMoreStack         = noAllocMoreStack
                          ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
                          ,ncgMakeFarBranches        = id
                      }
-                 ArchARM _ _ ->
+                 ArchARM _ _ ->
                      panic "nativeCodeGen: No NCG for ARM"
                  ArchPPC_64 ->
                      panic "nativeCodeGen: No NCG for PPC 64"
                  ArchUnknown ->
                      panic "nativeCodeGen: No NCG for unknown arch"
 
-nativeCodeGen' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+
+--
+-- Allocating more stack space for spilling is currently only
+-- supported for the linear register allocator on x86/x86_64, the rest
+-- default to the panic below.  To support allocating extra stack on
+-- more platforms provide a definition of ncgAllocMoreStack.
+--
+noAllocMoreStack :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr
+noAllocMoreStack amount _
+  = panic $   "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"
+        ++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"
+        ++  "   is a known limitation in the linear allocator.\n"
+        ++  "\n"
+        ++  "   Try enabling the graph colouring allocator with -fregs-graph instead."
+        ++  "   You can still file a bug report if you like.\n"
+
+
+nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
                => DynFlags
                -> NcgImpl statics instr jumpDest
                -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
 nativeCodeGen' dflags ncgImpl h us cmms
  = do
-       let platform = targetPlatform dflags
+        let platform = targetPlatform dflags
             split_cmms  = Stream.map add_split cmms
         -- BufHandle is a performance hack.  We could hide it inside
         -- Pretty if it weren't for the fact that we do lots of little
@@ -231,57 +242,58 @@ nativeCodeGen' dflags ncgImpl h us cmms
         (imports, prof) <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms [] [] 0
         bFlush bufh
 
-       let (native, colorStats, linearStats)
-               = unzip3 prof
-
-       -- dump native code
-       dumpIfSet_dyn dflags
-               Opt_D_dump_asm "Asm code"
-               (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) $ concat native)
-
-       -- dump global NCG stats for graph coloring allocator
-       (case concat $ catMaybes colorStats of
-         []    -> return ()
-         stats -> do   
-               -- build the global register conflict graph
-               let graphGlobal 
-                       = foldl Color.union Color.initGraph
-                       $ [ Color.raGraph stat
-                               | stat@Color.RegAllocStatsStart{} <- stats]
-          
-               dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
-                       $ Color.pprStats stats graphGlobal
-
-               dumpIfSet_dyn dflags
-                       Opt_D_dump_asm_conflicts "Register conflict graph"
-                       $ Color.dotGraph 
-                               (targetRegDotColor platform)
-                               (Color.trivColorable platform
-                                       (targetVirtualRegSqueeze platform)
-                                       (targetRealRegSqueeze platform))
-                       $ graphGlobal)
-
-
-       -- dump global NCG stats for linear allocator
-       (case concat $ catMaybes linearStats of
-               []      -> return ()
-               stats   -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
-                               $ Linear.pprStats (concat native) stats)
-
-       -- write out the imports
-       Pretty.printDoc Pretty.LeftMode h
-               $ makeImportsDoc dflags (concat imports)
-
-       return  ()
+        let (native, colorStats, linearStats)
+                = unzip3 prof
+
+        -- dump native code
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm "Asm code"
+                (vcat $ map (pprNatCmmDecl ncgImpl) $ concat native)
+
+        -- dump global NCG stats for graph coloring allocator
+        (case concat $ catMaybes colorStats of
+          []    -> return ()
+          stats -> do
+                -- build the global register conflict graph
+                let graphGlobal
+                        = foldl Color.union Color.initGraph
+                        $ [ Color.raGraph stat
+                                | stat@Color.RegAllocStatsStart{} <- stats]
+
+                dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
+                        $ Color.pprStats stats graphGlobal
+
+                dumpIfSet_dyn dflags
+                        Opt_D_dump_asm_conflicts "Register conflict graph"
+                        $ Color.dotGraph
+                                (targetRegDotColor platform)
+                                (Color.trivColorable platform
+                                        (targetVirtualRegSqueeze platform)
+                                        (targetRealRegSqueeze platform))
+                        $ graphGlobal)
+
+
+        -- dump global NCG stats for linear allocator
+        (case concat $ catMaybes linearStats of
+                []      -> return ()
+                stats   -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
+                                $ Linear.pprStats (concat native) stats)
+
+        -- write out the imports
+        Pretty.printDoc Pretty.LeftMode (pprCols dflags) h
+                $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
+                $ makeImportsDoc dflags (concat imports)
+
+        return  ()
 
  where  add_split tops
-               | dopt Opt_SplitObjs dflags = split_marker : tops
-               | otherwise                 = tops
+                | gopt Opt_SplitObjs dflags = split_marker : tops
+                | otherwise                 = tops
 
-       split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
+        split_marker = CmmProc mapEmpty mkSplitMarkerLabel (ListGraph [])
 
 
-cmmNativeGenStream :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
               => DynFlags
               -> NcgImpl statics instr jumpDest
               -> BufHandle
@@ -311,7 +323,7 @@ cmmNativeGenStream dflags ncgImpl h us cmm_stream impAcc profAcc count
 
 -- | Do native code generation on all these cmms.
 --
-cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
               => DynFlags
               -> NcgImpl statics instr jumpDest
               -> BufHandle
@@ -333,160 +345,168 @@ cmmNativeGens _ _ _ us [] impAcc profAcc _
 
 cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
  = do
-        let platform = targetPlatform dflags
-
-       (us', native, imports, colorStats, linearStats)
+        (us', native, imports, colorStats, linearStats)
                 <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
 
         {-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h
-                $ Pretty.vcat $ map (pprNatCmmDecl ncgImpl platform) native
+                $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
+                $ vcat $ map (pprNatCmmDecl ncgImpl) native
 
            -- carefully evaluate this strictly.  Binding it with 'let'
            -- and then using 'seq' doesn't work, because the let
            -- apparently gets inlined first.
-       lsPprNative <- return $!
-               if  dopt Opt_D_dump_asm       dflags
-                || dopt Opt_D_dump_asm_stats dflags
-                       then native
-                       else []
+        lsPprNative <- return $!
+                if  gopt Opt_D_dump_asm       dflags
+                 || gopt Opt_D_dump_asm_stats dflags
+                        then native
+                        else []
 
-       count' <- return $! count + 1;
+        count' <- return $! count + 1;
 
-       -- force evaulation all this stuff to avoid space leaks
-        {-# SCC "seqString" #-} seqString (showSDoc $ vcat $ map (pprPlatform platform) imports) `seq` return ()
+        -- force evaulation all this stuff to avoid space leaks
+        {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map ppr imports) `seq` return ()
 
-       cmmNativeGens dflags ncgImpl
+        cmmNativeGens dflags ncgImpl
             h us' cmms
-                       (imports : impAcc)
-                       ((lsPprNative, colorStats, linearStats) : profAcc)
-                       count'
+                        (imports : impAcc)
+                        ((lsPprNative, colorStats, linearStats) : profAcc)
+                        count'
 
- where seqString []            = ()
-       seqString (x:xs)        = x `seq` seqString xs `seq` ()
+ where  seqString []            = ()
+        seqString (x:xs)        = x `seq` seqString xs `seq` ()
 
 
 -- | Complete native code generation phase for a single top-level chunk of Cmm.
---     Dumping the output of each stage along the way.
---     Global conflict graph and NGC stats
+--      Dumping the output of each stage along the way.
+--      Global conflict graph and NGC stats
 cmmNativeGen
-       :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+        :: (Outputable statics, Outputable instr, Instruction instr)
     => DynFlags
     -> NcgImpl statics instr jumpDest
-       -> UniqSupply
-       -> RawCmmDecl                                   -- ^ the cmm to generate code for
-       -> Int                                          -- ^ sequence number of this top thing
-       -> IO   ( UniqSupply
-               , [NatCmmDecl statics instr]                -- native code
-               , [CLabel]                                  -- things imported by this cmm
-               , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
-               , Maybe [Linear.RegAllocStats])             -- stats for the linear register allocators
+        -> UniqSupply
+        -> RawCmmDecl                                   -- ^ the cmm to generate code for
+        -> Int                                          -- ^ sequence number of this top thing
+        -> IO   ( UniqSupply
+                , [NatCmmDecl statics instr]                -- native code
+                , [CLabel]                                  -- things imported by this cmm
+                , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
+                , Maybe [Linear.RegAllocStats])             -- stats for the linear register allocators
 
 cmmNativeGen dflags ncgImpl us cmm count
  = do
         let platform = targetPlatform dflags
 
-       -- rewrite assignments to global regs
-       let fixed_cmm =
-               {-# SCC "fixStgRegisters" #-}
-               fixStgRegisters cmm
-
-       -- cmm to cmm optimisations
-       let (opt_cmm, imports) =
-               {-# SCC "cmmToCmm" #-}
-               cmmToCmm dflags fixed_cmm
-
-       dumpIfSet_dyn dflags
-               Opt_D_dump_opt_cmm "Optimised Cmm"
-                (pprCmmGroup platform [opt_cmm])
-
-       -- generate native code from cmm
-       let ((native, lastMinuteImports), usGen) =
-               {-# SCC "genMachCode" #-}
-               initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
-
-       dumpIfSet_dyn dflags
-               Opt_D_dump_asm_native "Native code"
-               (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) native)
-
-       -- tag instructions with register liveness information
-       let (withLiveness, usLive) =
-               {-# SCC "regLiveness" #-}
-               initUs usGen 
-                       $ mapUs (regLiveness platform)
-                       $ map natCmmTopToLive native
-
-       dumpIfSet_dyn dflags
-               Opt_D_dump_asm_liveness "Liveness annotations added"
-               (vcat $ map (pprPlatform platform) withLiveness)
-               
-       -- allocate registers
-       (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
-        if ( dopt Opt_RegsGraph dflags
-          || dopt Opt_RegsIterative dflags)
-         then do
-               -- the regs usable for allocation
-               let (alloc_regs :: UniqFM (UniqSet RealReg))
-                       = foldr (\r -> plusUFM_C unionUniqSets
-                                       $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
-                               emptyUFM
-                       $ allocatableRegs ncgImpl
-
-               -- do the graph coloring register allocation
-               let ((alloced, regAllocStats), usAlloc)
-                       = {-# SCC "RegAlloc" #-}
-                         initUs usLive
-                         $ Color.regAlloc
-                               dflags
-                               alloc_regs
-                               (mkUniqSet [0 .. maxSpillSlots ncgImpl])
-                               withLiveness
-
-               -- dump out what happened during register allocation
-               dumpIfSet_dyn dflags
-                       Opt_D_dump_asm_regalloc "Registers allocated"
-                       (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced)
-
-               dumpIfSet_dyn dflags
-                       Opt_D_dump_asm_regalloc_stages "Build/spill stages"
-                       (vcat   $ map (\(stage, stats)
-                                       -> text "# --------------------------"
-                                       $$ text "#  cmm " <> int count <> text " Stage " <> int stage
-                                       $$ pprPlatform platform stats)
-                               $ zip [0..] regAllocStats)
-
-               let mPprStats =
-                       if dopt Opt_D_dump_asm_stats dflags
-                        then Just regAllocStats else Nothing
-
-               -- force evaluation of the Maybe to avoid space leak
-               mPprStats `seq` return ()
-
-               return  ( alloced, usAlloc
-                       , mPprStats
-                       , Nothing)
-
-         else do
-               -- do linear register allocation
-               let ((alloced, regAllocStats), usAlloc) 
-                       = {-# SCC "RegAlloc" #-}
-                         initUs usLive
-                         $ liftM unzip
-                         $ mapUs (Linear.regAlloc dflags) withLiveness
-
-               dumpIfSet_dyn dflags
-                       Opt_D_dump_asm_regalloc "Registers allocated"
-                       (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced)
-
-               let mPprStats =
-                       if dopt Opt_D_dump_asm_stats dflags
-                        then Just (catMaybes regAllocStats) else Nothing
-
-               -- force evaluation of the Maybe to avoid space leak
-               mPprStats `seq` return ()
-
-               return  ( alloced, usAlloc
-                       , Nothing
-                       , mPprStats)
+        -- rewrite assignments to global regs
+        let fixed_cmm =
+                {-# SCC "fixStgRegisters" #-}
+                fixStgRegisters dflags cmm
+
+        -- cmm to cmm optimisations
+        let (opt_cmm, imports) =
+                {-# SCC "cmmToCmm" #-}
+                cmmToCmm dflags fixed_cmm
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_opt_cmm "Optimised Cmm"
+                (pprCmmGroup [opt_cmm])
+
+        -- generate native code from cmm
+        let ((native, lastMinuteImports), usGen) =
+                {-# SCC "genMachCode" #-}
+                initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm_native "Native code"
+                (vcat $ map (pprNatCmmDecl ncgImpl) native)
+
+        -- tag instructions with register liveness information
+        let (withLiveness, usLive) =
+                {-# SCC "regLiveness" #-}
+                initUs usGen
+                        $ mapM (regLiveness platform)
+                        $ map natCmmTopToLive native
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm_liveness "Liveness annotations added"
+                (vcat $ map ppr withLiveness)
+
+        -- allocate registers
+        (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
+         if ( gopt Opt_RegsGraph dflags
+           || gopt Opt_RegsIterative dflags)
+          then do
+                -- the regs usable for allocation
+                let (alloc_regs :: UniqFM (UniqSet RealReg))
+                        = foldr (\r -> plusUFM_C unionUniqSets
+                                        $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
+                                emptyUFM
+                        $ allocatableRegs ncgImpl
+
+                -- do the graph coloring register allocation
+                let ((alloced, regAllocStats), usAlloc)
+                        = {-# SCC "RegAlloc" #-}
+                          initUs usLive
+                          $ Color.regAlloc
+                                dflags
+                                alloc_regs
+                                (mkUniqSet [0 .. maxSpillSlots ncgImpl])
+                                withLiveness
+
+                -- dump out what happened during register allocation
+                dumpIfSet_dyn dflags
+                        Opt_D_dump_asm_regalloc "Registers allocated"
+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
+
+                dumpIfSet_dyn dflags
+                        Opt_D_dump_asm_regalloc_stages "Build/spill stages"
+                        (vcat   $ map (\(stage, stats)
+                                        -> text "# --------------------------"
+                                        $$ text "#  cmm " <> int count <> text " Stage " <> int stage
+                                        $$ ppr stats)
+                                $ zip [0..] regAllocStats)
+
+                let mPprStats =
+                        if gopt Opt_D_dump_asm_stats dflags
+                         then Just regAllocStats else Nothing
+
+                -- force evaluation of the Maybe to avoid space leak
+                mPprStats `seq` return ()
+
+                return  ( alloced, usAlloc
+                        , mPprStats
+                        , Nothing)
+
+          else do
+                -- do linear register allocation
+                let reg_alloc proc = do
+                       (alloced, maybe_more_stack, ra_stats) <-
+                               Linear.regAlloc dflags proc
+                       case maybe_more_stack of
+                         Nothing -> return ( alloced, ra_stats )
+                         Just amount ->
+                           return ( ncgAllocMoreStack ncgImpl amount alloced
+                                  , ra_stats )
+
+                let ((alloced, regAllocStats), usAlloc)
+                        = {-# SCC "RegAlloc" #-}
+                          initUs usLive
+                          $ liftM unzip
+                          $ mapM reg_alloc withLiveness
+
+                dumpIfSet_dyn dflags
+                        Opt_D_dump_asm_regalloc "Registers allocated"
+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
+
+                let mPprStats =
+                        if gopt Opt_D_dump_asm_stats dflags
+                         then Just (catMaybes regAllocStats) else Nothing
+
+                -- force evaluation of the Maybe to avoid space leak
+                mPprStats `seq` return ()
+
+                return  ( alloced, usAlloc
+                        , Nothing
+                        , mPprStats)
 
         ---- x86fp_kludge.  This pass inserts ffree instructions to clear
         ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack
@@ -498,55 +518,55 @@ cmmNativeGen dflags ncgImpl us cmm count
         let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
 
         ---- generate jump tables
-       let tabled      =
-               {-# SCC "generateJumpTables" #-}
+        let tabled      =
+                {-# SCC "generateJumpTables" #-}
                 generateJumpTables ncgImpl kludged
 
-       ---- shortcut branches
-       let shorted     =
-               {-# SCC "shortcutBranches" #-}
-               shortcutBranches dflags ncgImpl tabled
+        ---- shortcut branches
+        let shorted     =
+                {-# SCC "shortcutBranches" #-}
+                shortcutBranches dflags ncgImpl tabled
 
-       ---- sequence blocks
-       let sequenced   =
-               {-# SCC "sequenceBlocks" #-}
-               map (sequenceTop ncgImpl) shorted
+        ---- sequence blocks
+        let sequenced   =
+                {-# SCC "sequenceBlocks" #-}
+                map (sequenceTop ncgImpl) shorted
 
         ---- expansion of SPARC synthetic instrs
-       let expanded = 
-               {-# SCC "sparc_expand" #-}
+        let expanded =
+                {-# SCC "sparc_expand" #-}
                 ncgExpandTop ncgImpl sequenced
 
-       dumpIfSet_dyn dflags
-               Opt_D_dump_asm_expanded "Synthetic instructions expanded"
-               (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) expanded)
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm_expanded "Synthetic instructions expanded"
+                (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
 
-       return  ( usAlloc
-               , expanded
-               , lastMinuteImports ++ imports
-               , ppr_raStatsColor
-               , ppr_raStatsLinear)
+        return  ( usAlloc
+                , expanded
+                , lastMinuteImports ++ imports
+                , ppr_raStatsColor
+                , ppr_raStatsLinear)
 
 
 x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
 x86fp_kludge top@(CmmData _ _) = top
-x86fp_kludge (CmmProc info lbl (ListGraph code)) = 
-       CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
+x86fp_kludge (CmmProc info lbl (ListGraph code)) =
+        CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
 
 
 -- | Build a doc for all the imports.
 --
-makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc
+makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
 makeImportsDoc dflags imports
  = dyld_stubs imports
-            Pretty.$$
+            $$
             -- On recent versions of Darwin, the linker supports
             -- dead-stripping of code and data on a per-symbol basis.
             -- There's a hack to make this work in PprMach.pprNatCmmDecl.
             (if platformHasSubsectionsViaSymbols (targetPlatform dflags)
-             then Pretty.text ".subsections_via_symbols"
-             else Pretty.empty)
-            Pretty.$$ 
+             then text ".subsections_via_symbols"
+             else empty)
+            $$
                 -- On recent GNU ELF systems one can mark an object file
                 -- as not requiring an executable stack. If all objects
                 -- linked into a program have this note then the program
@@ -554,45 +574,43 @@ makeImportsDoc dflags imports
                 -- security. GHC generated code does not need an executable
                 -- stack so add the note in:
             (if platformHasGnuNonexecStack (targetPlatform dflags)
-             then Pretty.text ".section .note.GNU-stack,\"\",@progbits"
-             else Pretty.empty)
-            Pretty.$$
+             then text ".section .note.GNU-stack,\"\",@progbits"
+             else empty)
+            $$
                 -- And just because every other compiler does, lets stick in
                 -- an identifier directive: .ident "GHC x.y.z"
             (if platformHasIdentDirective (targetPlatform dflags)
-             then let compilerIdent = Pretty.text "GHC" Pretty.<+>
-                                     Pretty.text cProjectVersion
-                   in Pretty.text ".ident" Pretty.<+>
-                      Pretty.doubleQuotes compilerIdent
-             else Pretty.empty)
+             then let compilerIdent = text "GHC" <+> text cProjectVersion
+                   in text ".ident" <+> doubleQuotes compilerIdent
+             else empty)
 
  where
-       -- Generate "symbol stubs" for all external symbols that might
-       -- come from a dynamic library.
-       dyld_stubs :: [CLabel] -> Pretty.Doc
-{-      dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
-                                   map head $ group $ sort imps-}
-
-       platform = targetPlatform dflags
-       arch = platformArch platform
-       os   = platformOS   platform
-       
-       -- (Hack) sometimes two Labels pretty-print the same, but have
-       -- different uniques; so we compare their text versions...
-       dyld_stubs imps
-               | needImportedSymbols arch os
-               = Pretty.vcat $
-                       (pprGotDeclaration arch os :) $
-                       map ( pprImportedSymbol platform . fst . head) $
-                       groupBy (\(_,a) (_,b) -> a == b) $
-                       sortBy (\(_,a) (_,b) -> compare a b) $
-                       map doPpr $
-                       imps
-               | otherwise
-               = Pretty.empty
-
-       doPpr lbl = (lbl, renderWithStyle (pprCLabel platform lbl) astyle)
-       astyle = mkCodeStyle AsmStyle
+        -- Generate "symbol stubs" for all external symbols that might
+        -- come from a dynamic library.
+        dyld_stubs :: [CLabel] -> SDoc
+{-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $
+                                    map head $ group $ sort imps-}
+
+        platform = targetPlatform dflags
+        arch = platformArch platform
+        os   = platformOS   platform
+
+        -- (Hack) sometimes two Labels pretty-print the same, but have
+        -- different uniques; so we compare their text versions...
+        dyld_stubs imps
+                | needImportedSymbols dflags arch os
+                = vcat $
+                        (pprGotDeclaration dflags arch os :) $
+                        map ( pprImportedSymbol dflags platform . fst . head) $
+                        groupBy (\(_,a) (_,b) -> a == b) $
+                        sortBy (\(_,a) (_,b) -> compare a b) $
+                        map doPpr $
+                        imps
+                | otherwise
+                = empty
+
+        doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)
+        astyle = mkCodeStyle AsmStyle
 
 
 -- -----------------------------------------------------------------------------
@@ -604,13 +622,13 @@ makeImportsDoc dflags imports
 -- such that as many of the local jumps as possible turn into
 -- fallthroughs.
 
-sequenceTop 
-       :: Instruction instr
+sequenceTop
+        :: Instruction instr
     => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr
 
 sequenceTop _       top@(CmmData _ _) = top
-sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = 
-  CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
+sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
+  CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info blocks)
 
 -- The algorithm is very simple (and stupid): we make a graph out of
 -- the blocks where there is an edge from one block to another iff the
@@ -622,54 +640,57 @@ sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
 -- FYI, the classic layout for basic blocks uses postorder DFS; this
 -- algorithm is implemented in Hoopl.
 
-sequenceBlocks 
-       :: Instruction instr
-       => [NatBasicBlock instr] 
-       -> [NatBasicBlock instr]
+sequenceBlocks
+        :: Instruction instr
+        => BlockEnv i
+        -> [NatBasicBlock instr]
+        -> [NatBasicBlock instr]
 
-sequenceBlocks [] = []
-sequenceBlocks (entry:blocks) = 
-  seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
+sequenceBlocks [] = []
+sequenceBlocks infos (entry:blocks) =
+  seqBlocks infos (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
   -- the first block is the entry point ==> it must remain at the start.
 
 
-sccBlocks 
-       :: Instruction instr
-       => [NatBasicBlock instr] 
-       -> [SCC ( NatBasicBlock instr
-               , Unique
-               , [Unique])]
+sccBlocks
+        :: Instruction instr
+        => [NatBasicBlock instr]
+        -> [SCC ( NatBasicBlock instr
+                , BlockId
+                , [BlockId])]
 
 sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
 
 -- we're only interested in the last instruction of
 -- the block, and only if it has a single destination.
-getOutEdges 
-       :: Instruction instr
-       => [instr] -> [Unique]
+getOutEdges
+        :: Instruction instr
+        => [instr] -> [BlockId]
 
-getOutEdges instrs 
-       = case jumpDestsOfInstr (last instrs) of
-               [one] -> [getUnique one]
-               _many -> []
+getOutEdges instrs
+        = case jumpDestsOfInstr (last instrs) of
+                [one] -> [one]
+                _many -> []
 
 mkNode :: (Instruction t)
        => GenBasicBlock t
-       -> (GenBasicBlock t, Unique, [Unique])
-mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
-
-seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
-seqBlocks [] = []
-seqBlocks ((block,_,[]) : rest)
-  = block : seqBlocks rest
-seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
-  | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
-  | otherwise       = block : seqBlocks rest'
+       -> (GenBasicBlock t, BlockId, [BlockId])
+mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs)
+
+seqBlocks :: BlockEnv i -> [(GenBasicBlock t1, BlockId, [BlockId])]
+                        -> [GenBasicBlock t1]
+seqBlocks _ [] = []
+seqBlocks infos ((block,_,[]) : rest)
+  = block : seqBlocks infos rest
+seqBlocks infos ((block@(BasicBlock id instrs),_,[next]) : rest)
+  | can_fallthrough = BasicBlock id (init instrs) : seqBlocks infos rest'
+  | otherwise       = block : seqBlocks infos rest'
   where
-       (can_fallthrough, rest') = reorder next [] rest
-         -- TODO: we should do a better job for cycles; try to maximise the
-         -- fallthroughs within a loop.
-seqBlocks _ = panic "AsmCodegen:seqBlocks"
+        can_fallthrough = not (mapMember next infos) && can_reorder
+        (can_reorder, rest') = reorder next [] rest
+          -- TODO: we should do a better job for cycles; try to maximise the
+          -- fallthroughs within a loop.
+seqBlocks _ _ = panic "AsmCodegen:seqBlocks"
 
 reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
 reorder  _ accum [] = (False, reverse accum)
@@ -685,18 +706,18 @@ reorder id accum (b@(block,id',out) : rest)
 -- big, we have to work around this limitation.
 
 makeFarBranches
-       :: [NatBasicBlock PPC.Instr.Instr] 
-       -> [NatBasicBlock PPC.Instr.Instr]
+        :: [NatBasicBlock PPC.Instr.Instr]
+        -> [NatBasicBlock PPC.Instr.Instr]
 makeFarBranches blocks
     | last blockAddresses < nearLimit = blocks
     | otherwise = zipWith handleBlock blockAddresses blocks
     where
         blockAddresses = scanl (+) 0 $ map blockLen blocks
         blockLen (BasicBlock _ instrs) = length instrs
-        
+
         handleBlock addr (BasicBlock id instrs)
                 = BasicBlock id (zipWith makeFar [addr..] instrs)
-        
+
         makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
         makeFar addr (PPC.Instr.BCC cond tgt)
             | abs (addr - targetAddr) >= nearLimit
@@ -705,13 +726,13 @@ makeFarBranches blocks
             = PPC.Instr.BCC cond tgt
             where Just targetAddr = lookupUFM blockAddressMap tgt
         makeFar _ other            = other
-        
+
         nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
                          -- distance, as we have a few pseudo-insns that are
                          -- pretty-printed as multiple instructions,
                          -- and it's just not worth the effort to calculate
                          -- things exactly
-        
+
         blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
 
 -- -----------------------------------------------------------------------------
@@ -720,8 +741,8 @@ makeFarBranches blocks
 -- Analyzes all native code and generates data sections for all jump
 -- table instructions.
 generateJumpTables
-       :: NcgImpl statics instr jumpDest
-    -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
+        :: NcgImpl statics instr jumpDest
+        -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
 generateJumpTables ncgImpl xs = concatMap f xs
     where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
           f p = [p]
@@ -731,10 +752,10 @@ generateJumpTables ncgImpl xs = concatMap f xs
 -- Shortcut branches
 
 shortcutBranches
-       :: DynFlags
+        :: DynFlags
     -> NcgImpl statics instr jumpDest
-       -> [NatCmmDecl statics instr] 
-       -> [NatCmmDecl statics instr]
+        -> [NatCmmDecl statics instr]
+        -> [NatCmmDecl statics instr]
 
 shortcutBranches dflags ncgImpl tops
   | optLevel dflags < 1 = tops    -- only with -O or higher
@@ -744,8 +765,8 @@ shortcutBranches dflags ncgImpl tops
     mapping = foldr plusUFM emptyUFM mappings
 
 build_mapping :: NcgImpl statics instr jumpDest
-              -> GenCmmDecl d t (ListGraph instr)
-              -> (GenCmmDecl d t (ListGraph instr), UniqFM jumpDest)
+              -> GenCmmDecl d (BlockEnv t) (ListGraph instr)
+              -> (GenCmmDecl d (BlockEnv t) (ListGraph instr), UniqFM jumpDest)
 build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
 build_mapping _ (CmmProc info lbl (ListGraph []))
   = (CmmProc info lbl (ListGraph []), emptyUFM)
@@ -761,18 +782,22 @@ build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
     split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
         | Just jd <- canShortcut ncgImpl insn,
           Just dest <- getJumpDestBlockId ncgImpl jd,
+          not (has_info id),
           (setMember dest s) || dest == id -- loop checks
         = (s, shortcut_blocks, b : others)
     split (s, shortcut_blocks, others) (BasicBlock id [insn])
-        | Just dest <- canShortcut ncgImpl insn
+        | Just dest <- canShortcut ncgImpl insn,
+          not (has_info id)
         = (setInsert id s, (id,dest) : shortcut_blocks, others)
     split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
 
+    -- do not eliminate blocks that have an info table
+    has_info l = mapMember l info
 
     -- build a mapping from BlockId to JumpDest for shorting branches
     mapping = foldl add emptyUFM shortcut_blocks
     add ufm (id,dest) = addToUFM ufm id dest
-    
+
 apply_mapping :: NcgImpl statics instr jumpDest
               -> UniqFM jumpDest
               -> GenCmmDecl statics h (ListGraph instr)
@@ -807,21 +832,21 @@ apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
 -- Switching between the two monads whilst carrying along the same
 -- Unique supply breaks abstraction.  Is that bad?
 
-genMachCode 
-       :: DynFlags 
+genMachCode
+        :: DynFlags
         -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-       -> RawCmmDecl 
-       -> UniqSM 
-               ( [NatCmmDecl statics instr]
-               , [CLabel])
+        -> RawCmmDecl
+        -> UniqSM
+                ( [NatCmmDecl statics instr]
+                , [CLabel])
 
 genMachCode dflags cmmTopCodeGen cmm_top
-  = do { initial_us <- getUs
-       ; let initial_st           = mkNatM_State initial_us 0 dflags
-             (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
-             final_delta          = natm_delta final_st
-             final_imports        = natm_imports final_st
-       ; if   final_delta == 0
+  = do  { initial_us <- getUs
+        ; let initial_st           = mkNatM_State initial_us 0 dflags
+              (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
+              final_delta          = natm_delta final_st
+              final_imports        = natm_imports final_st
+        ; if   final_delta == 0
           then return (new_tops, final_imports)
           else pprPanic "genMachCode: nonzero final delta" (int final_delta)
     }
@@ -833,15 +858,13 @@ genMachCode dflags cmmTopCodeGen cmm_top
 Here we do:
 
   (a) Constant folding
-  (b) Simple inlining: a temporary which is assigned to and then
-      used, once, can be shorted.
   (c) Position independent code and dynamic linking
         (i)  introduce the appropriate indirections
              and position independent refs
         (ii) compile a list of imported symbols
   (d) Some arch-specific optimizations
 
-(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and
+(a) will be moving to the new Hoopl pipeline, however, (c) and
 (d) are only needed by the native backend and will continue to live
 here.
 
@@ -856,8 +879,7 @@ Ideas for other things we could do (put these in Hoopl please!):
 cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
 cmmToCmm _ top@(CmmData _ _) = (top, [])
 cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
-  let platform = targetPlatform dflags
-  blocks' <- mapM cmmBlockConFold (cmmMiniInline platform (cmmEliminateDeadBlocks blocks))
+  blocks' <- mapM cmmBlockConFold blocks
   return $ CmmProc info lbl (ListGraph blocks')
 
 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
@@ -892,7 +914,7 @@ cmmBlockConFold (BasicBlock id stmts) = do
 --  * reg = reg      --> nop
 --  * if 0 then jump --> nop
 --  * if 1 then jump --> jump
--- We might be tempted to skip this step entirely of not opt_PIC, but
+-- We might be tempted to skip this step entirely of not Opt_PIC, but
 -- there is some PowerPC code for the non-PIC case, which would also
 -- have to be separated.
 cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
@@ -901,8 +923,8 @@ cmmStmtConFold stmt
         CmmAssign reg src
            -> do src' <- cmmExprConFold DataReference src
                  return $ case src' of
-                  CmmReg reg' | reg == reg' -> CmmNop
-                  new_src -> CmmAssign reg new_src
+                   CmmReg reg' | reg == reg' -> CmmNop
+                   new_src -> CmmAssign reg new_src
 
         CmmStore addr src
            -> do addr' <- cmmExprConFold DataReference addr
@@ -914,11 +936,15 @@ cmmStmtConFold stmt
                  return $ CmmJump addr' live
 
         CmmCall target regs args returns
-          -> do target' <- case target of
-                             CmmCallee e conv -> do
-                               e' <- cmmExprConFold CallReference e
-                               return $ CmmCallee e' conv
-                             other -> return other
+           -> do target' <- case target of
+                              CmmCallee e conv -> do
+                                e' <- cmmExprConFold CallReference e
+                                return $ CmmCallee e' conv
+                              op@(CmmPrim _ Nothing) ->
+                                return op
+                              CmmPrim op (Just stmts) ->
+                                do stmts' <- mapM cmmStmtConFold stmts
+                                   return $ CmmPrim op (Just stmts')
                  args' <- mapM (\(CmmHinted arg hint) -> do
                                   arg' <- cmmExprConFold DataReference arg
                                   return (CmmHinted arg' hint)) args
@@ -927,18 +953,17 @@ cmmStmtConFold stmt
         CmmCondBranch test dest
            -> do test' <- cmmExprConFold DataReference test
                  dflags <- getDynFlags
-                 let platform = targetPlatform dflags
-                return $ case test' of
-                  CmmLit (CmmInt 0 _) -> 
-                    CmmComment (mkFastString ("deleted: " ++ 
-                                       showSDoc (pprStmt platform stmt)))
+                 return $ case test' of
+                   CmmLit (CmmInt 0 _) ->
+                     CmmComment (mkFastString ("deleted: " ++
+                                        showSDoc dflags (pprStmt stmt)))
 
-                  CmmLit (CmmInt _ _) -> CmmBranch dest
-                  _other -> CmmCondBranch test' dest
+                   CmmLit (CmmInt _ _) -> CmmBranch dest
+                   _other -> CmmCondBranch test' dest
 
-       CmmSwitch expr ids
-          -> do expr' <- cmmExprConFold DataReference expr
-                return $ CmmSwitch expr' ids
+        CmmSwitch expr ids
+           -> do expr' <- cmmExprConFold DataReference expr
+                 return $ CmmSwitch expr' ids
 
         other
            -> return other
@@ -946,17 +971,19 @@ cmmStmtConFold stmt
 cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
 cmmExprConFold referenceKind expr = do
     dflags <- getDynFlags
-    -- Skip constant folding if new code generator is running
-    -- (this optimization is done in Hoopl)
-    let expr' = if dopt Opt_TryNewCodeGen dflags
+
+    -- With -O1 and greater, the cmmSink pass does constant-folding, so
+    -- we don't need to do it again here.
+    let expr' = if optLevel dflags >= 1
                     then expr
-                    else cmmExprCon (targetPlatform dflags) expr
+                    else cmmExprCon dflags expr
+
     cmmExprNative referenceKind expr'
 
-cmmExprCon :: Platform -> CmmExpr -> CmmExpr
-cmmExprCon platform (CmmLoad addr rep) = CmmLoad (cmmExprCon platform addr) rep
-cmmExprCon platform (CmmMachOp mop args)
-    = cmmMachOpFold platform mop (map (cmmExprCon platform) args)
+cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
+cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep
+cmmExprCon dflags (CmmMachOp mop args)
+    = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args)
 cmmExprCon _ other = other
 
 -- handles both PIC and non-PIC cases... a very strange mixture
@@ -975,6 +1002,12 @@ cmmExprNative referenceKind expr = do
            -> do args' <- mapM (cmmExprNative DataReference) args
                  return $ CmmMachOp mop args'
 
+        CmmLit (CmmBlock id)
+           -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))
+           -- we must convert block Ids to CLabels here, because we
+           -- might have to do the PIC transformation.  Hence we must
+           -- not modify BlockIds beyond this point.
+
         CmmLit (CmmLabel lbl)
            -> do
                 cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
@@ -982,24 +1015,24 @@ cmmExprNative referenceKind expr = do
            -> do
                  dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
                  -- need to optimize here, since it's late
-                 return $ cmmMachOpFold platform (MO_Add wordWidth) [
+                 return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [
                      dynRef,
-                     (CmmLit $ CmmInt (fromIntegral off) wordWidth)
+                     (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags))
                    ]
 
         -- On powerpc (non-PIC), it's easier to jump directly to a label than
         -- to use the register table, so we replace these registers
         -- with the corresponding labels:
         CmmReg (CmmGlobal EagerBlackholeInfo)
-          | arch == ArchPPC && not opt_PIC
+          | arch == ArchPPC && not (gopt Opt_PIC dflags)
           -> cmmExprNative referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
         CmmReg (CmmGlobal GCEnter1)
-          | arch == ArchPPC && not opt_PIC
+          | arch == ArchPPC && not (gopt Opt_PIC dflags)
           -> cmmExprNative referenceKind $
-             CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) 
+             CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
         CmmReg (CmmGlobal GCFun)
-          | arch == ArchPPC && not opt_PIC
+          | arch == ArchPPC && not (gopt Opt_PIC dflags)
           -> cmmExprNative referenceKind $
              CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))