Some alpha renaming
[ghc.git] / compiler / nativeGen / AsmCodeGen.lhs
index e976e58..a233a8f 100644 (file)
@@ -51,20 +51,17 @@ import NCGMonad
 import BlockId
 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
@@ -72,6 +69,8 @@ import FastString
 import UniqSet
 import ErrUtils
 import Module
+import Stream (Stream)
+import qualified Stream
 
 -- DEBUGGING ONLY
 --import OrdList
@@ -114,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.
@@ -139,31 +138,33 @@ 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]
     }
 
 --------------------
-nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
+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
                     }
@@ -173,30 +174,32 @@ 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
                      }
@@ -207,19 +210,36 @@ nativeCodeGen dflags h us cmms
                  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 -> [RawCmmGroup] -> IO ()
+               -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
 nativeCodeGen' dflags ncgImpl h us cmms
  = do
         let platform = targetPlatform dflags
-            split_cmms  = concat $ map add_split cmms
+            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
         -- printDocs here (in order to do codegen in constant space).
         bufh <- newBufHandle h
-        (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
+        (imports, prof) <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms [] [] 0
         bFlush bufh
 
         let (native, colorStats, linearStats)
@@ -228,7 +248,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
         -- dump native code
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm "Asm code"
-                (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) $ concat native)
+                (vcat $ map (pprNatCmmDecl ncgImpl) $ concat native)
 
         -- dump global NCG stats for graph coloring allocator
         (case concat $ catMaybes colorStats of
@@ -260,21 +280,50 @@ nativeCodeGen' dflags ncgImpl h us cmms
                                 $ Linear.pprStats (concat native) stats)
 
         -- write out the imports
-        Pretty.printDoc Pretty.LeftMode h
+        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
+                | gopt Opt_SplitObjs dflags = split_marker : tops
                 | otherwise                 = tops
 
-        split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
+        split_marker = CmmProc mapEmpty mkSplitMarkerLabel (ListGraph [])
+
+
+cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
+              => DynFlags
+              -> NcgImpl statics instr jumpDest
+              -> BufHandle
+              -> UniqSupply
+              -> Stream IO RawCmmGroup ()
+              -> [[CLabel]]
+              -> [ ([NatCmmDecl statics instr],
+                   Maybe [Color.RegAllocStats statics instr],
+                   Maybe [Linear.RegAllocStats]) ]
+              -> Int
+              -> IO ( [[CLabel]],
+                      [([NatCmmDecl statics instr],
+                      Maybe [Color.RegAllocStats statics instr],
+                      Maybe [Linear.RegAllocStats])] )
+
+cmmNativeGenStream dflags ncgImpl h us cmm_stream impAcc profAcc count
+ = do
+        r <- Stream.runStream cmm_stream
+        case r of
+          Left () -> return (reverse impAcc, reverse profAcc)
+          Right (cmms, cmm_stream') -> do
+            (impAcc,profAcc,us') <- cmmNativeGens dflags ncgImpl h us cmms
+                                              impAcc profAcc count
+            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
@@ -287,35 +336,35 @@ cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruct
               -> Int
               -> IO ( [[CLabel]],
                       [([NatCmmDecl statics instr],
-                      Maybe [Color.RegAllocStats statics instr],
-                      Maybe [Linear.RegAllocStats])] )
+                       Maybe [Color.RegAllocStats statics instr],
+                       Maybe [Linear.RegAllocStats])],
+                      UniqSupply )
 
-cmmNativeGens _ _ _ _ [] impAcc profAcc _
-        = return (reverse impAcc, reverse profAcc)
+cmmNativeGens _ _ _ us [] impAcc profAcc _
+        = return (impAcc,profAcc,us)
 
 cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
  = do
-        let platform = targetPlatform dflags
-
         (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
+                if  gopt Opt_D_dump_asm       dflags
+                 || gopt Opt_D_dump_asm_stats dflags
                         then native
                         else []
 
         count' <- return $! count + 1;
 
         -- force evaulation all this stuff to avoid space leaks
-        {-# SCC "seqString" #-} seqString (showSDoc $ vcat $ map (pprPlatform platform) imports) `seq` return ()
+        {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map ppr imports) `seq` return ()
 
         cmmNativeGens dflags ncgImpl
             h us' cmms
@@ -331,7 +380,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
 --      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
@@ -350,7 +399,7 @@ cmmNativeGen dflags ncgImpl us cmm count
         -- rewrite assignments to global regs
         let fixed_cmm =
                 {-# SCC "fixStgRegisters" #-}
-                fixStgRegisters cmm
+                fixStgRegisters dflags cmm
 
         -- cmm to cmm optimisations
         let (opt_cmm, imports) =
@@ -359,7 +408,7 @@ cmmNativeGen dflags ncgImpl us cmm count
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_opt_cmm "Optimised Cmm"
-                (pprCmmGroup platform [opt_cmm])
+                (pprCmmGroup [opt_cmm])
 
         -- generate native code from cmm
         let ((native, lastMinuteImports), usGen) =
@@ -368,23 +417,23 @@ cmmNativeGen dflags ncgImpl us cmm count
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm_native "Native code"
-                (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) native)
+                (vcat $ map (pprNatCmmDecl ncgImpl) native)
 
         -- tag instructions with register liveness information
         let (withLiveness, usLive) =
                 {-# SCC "regLiveness" #-}
                 initUs usGen
-                        $ mapUs (regLiveness platform)
+                        $ mapM (regLiveness platform)
                         $ map natCmmTopToLive native
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm_liveness "Liveness annotations added"
-                (vcat $ map (pprPlatform platform) withLiveness)
+                (vcat $ map ppr withLiveness)
 
         -- allocate registers
         (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
-         if ( dopt Opt_RegsGraph dflags
-           || dopt Opt_RegsIterative dflags)
+         if ( gopt Opt_RegsGraph dflags
+           || gopt Opt_RegsIterative dflags)
           then do
                 -- the regs usable for allocation
                 let (alloc_regs :: UniqFM (UniqSet RealReg))
@@ -406,18 +455,18 @@ cmmNativeGen dflags ncgImpl us cmm count
                 -- dump out what happened during register allocation
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc "Registers allocated"
-                        (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced)
+                        (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
-                                        $$ pprPlatform platform stats)
+                                        $$ ppr stats)
                                 $ zip [0..] regAllocStats)
 
                 let mPprStats =
-                        if dopt Opt_D_dump_asm_stats dflags
+                        if gopt Opt_D_dump_asm_stats dflags
                          then Just regAllocStats else Nothing
 
                 -- force evaluation of the Maybe to avoid space leak
@@ -429,18 +478,27 @@ cmmNativeGen dflags ncgImpl us cmm count
 
           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
-                          $ mapUs (Linear.regAlloc dflags) withLiveness
+                          $ mapM reg_alloc withLiveness
 
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc "Registers allocated"
-                        (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced)
+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
 
                 let mPprStats =
-                        if dopt Opt_D_dump_asm_stats dflags
+                        if gopt Opt_D_dump_asm_stats dflags
                          then Just (catMaybes regAllocStats) else Nothing
 
                 -- force evaluation of the Maybe to avoid space leak
@@ -481,7 +539,7 @@ cmmNativeGen dflags ncgImpl us cmm count
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm_expanded "Synthetic instructions expanded"
-                (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) expanded)
+                (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
 
         return  ( usAlloc
                 , expanded
@@ -498,17 +556,17 @@ x86fp_kludge (CmmProc info lbl (ListGraph 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
@@ -516,23 +574,21 @@ 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 $
+        dyld_stubs :: [CLabel] -> SDoc
+{-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $
                                     map head $ group $ sort imps-}
 
         platform = targetPlatform dflags
@@ -542,18 +598,18 @@ makeImportsDoc dflags imports
         -- (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) $
+                | 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
-                = Pretty.empty
+                = empty
 
-        doPpr lbl = (lbl, renderWithStyle (pprCLabel platform lbl) astyle)
+        doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)
         astyle = mkCodeStyle AsmStyle
 
 
@@ -572,7 +628,7 @@ sequenceTop
 
 sequenceTop _       top@(CmmData _ _) = top
 sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
-  CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks 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
@@ -586,12 +642,13 @@ sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
 
 sequenceBlocks
         :: Instruction instr
-        => [NatBasicBlock 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.
 
 
@@ -599,8 +656,8 @@ sccBlocks
         :: Instruction instr
         => [NatBasicBlock instr]
         -> [SCC ( NatBasicBlock instr
-                , Unique
-                , [Unique])]
+                , BlockId
+                , [BlockId])]
 
 sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
 
@@ -608,30 +665,32 @@ sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
 -- the block, and only if it has a single destination.
 getOutEdges
         :: Instruction instr
-        => [instr] -> [Unique]
+        => [instr] -> [BlockId]
 
 getOutEdges instrs
         = case jumpDestsOfInstr (last instrs) of
-                [one] -> [getUnique one]
+                [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
+        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"
+seqBlocks _ = panic "AsmCodegen:seqBlocks"
 
 reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
 reorder  _ accum [] = (False, reverse accum)
@@ -683,7 +742,7 @@ makeFarBranches blocks
 -- table instructions.
 generateJumpTables
         :: NcgImpl statics instr jumpDest
-    -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
+        -> [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]
@@ -706,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)
@@ -723,13 +782,17 @@ 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
@@ -795,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.
 
@@ -818,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] #))
@@ -854,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
@@ -893,11 +953,10 @@ 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)))
+                                        showSDoc dflags (pprStmt stmt)))
 
                    CmmLit (CmmInt _ _) -> CmmBranch dest
                    _other -> CmmCondBranch test' dest
@@ -912,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
@@ -941,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
@@ -948,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")))
         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")))