Merge in new code generator branch.

This changes the new code generator to make use of the Hoopl package
for dataflow analysis.  Hoopl is a new boot package, and is maintained
in a separate upstream git repository (as usual, GHC has its own
lagging darcs mirror in http://darcs.haskell.org/packages/hoopl).

During this merge I squashed recent history into one patch.  I tried
to rebase, but the history had some internal conflicts of its own
which made rebase extremely confusing, so I gave up. The history I
squashed was:

  - Update new codegen to work with latest Hoopl
  - Add some notes on new code gen to cmm-notes
  - Enable Hoopl lag package.
  - Add SPJ note to cmm-notes
  - Improve GC calls on new code generator.

Work in this branch was done by:
   - Milan Straka <fox@ucw.cz>
   - John Dias <dias@cs.tufts.edu>
   - David Terei <davidterei@gmail.com>

Edward Z. Yang <ezyang@mit.edu> merged in further changes from GHC HEAD
and fixed a few bugs.

38 files changed, 541 insertions, 492 deletions

diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs
index 9a043f1efd..d8675c53df 100644
--- a/compiler/codeGen/CgBindery.lhs
+++ b/compiler/codeGen/CgBindery.lhs
@@ -39,7 +39,7 @@ import CLabel
 import ClosureInfo
 import Constants
 
-import Cmm
+import OldCmm
 import PprCmm		( {- instance Outputable -} )
 import SMRep
 import Id
diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs
index f16a9b5e18..f3013cd5a6 100644
--- a/compiler/codeGen/CgCallConv.hs
+++ b/compiler/codeGen/CgCallConv.hs
@@ -32,13 +32,13 @@ import CgUtils
 import CgMonad
 import SMRep
 
-import Cmm
+import OldCmm
 import CLabel
 
 import Constants
 import ClosureInfo
 import CgStackery
-import CmmUtils
+import OldCmmUtils
 import Maybes
 import Id
 import Name
diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs
index 9f24fba379..1eea96c1b0 100644
--- a/compiler/codeGen/CgCase.lhs
+++ b/compiler/codeGen/CgCase.lhs
@@ -27,8 +27,8 @@ import CgInfoTbls
 
 import ClosureInfo
 import SMRep
-import CmmUtils
-import Cmm
+import OldCmmUtils
+import OldCmm
 
 import StgSyn
 import StaticFlags
diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index 60ba7f8652..da44122a4d 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -31,8 +31,8 @@ import CgCallConv
 import CgUtils
 import ClosureInfo
 import SMRep
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
 import CLabel
 import StgSyn
 import CostCentre	
diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index 0981811ee7..8768008776 100644
--- a/compiler/codeGen/CgCon.lhs
+++ b/compiler/codeGen/CgCon.lhs
@@ -32,8 +32,8 @@ import CgTicky
 import CgInfoTbls
 import CLabel
 import ClosureInfo
-import CmmUtils
-import Cmm
+import OldCmmUtils
+import OldCmm
 import SMRep
 import CostCentre
 import Constants
diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs
index 71087ca7c5..1f11495b60 100644
--- a/compiler/codeGen/CgExpr.lhs
+++ b/compiler/codeGen/CgExpr.lhs
@@ -29,8 +29,8 @@ import CgPrimOp
 import CgHpc
 import CgUtils
 import ClosureInfo
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
 import VarSet
 import Literal
 import PrimOp
diff --git a/compiler/codeGen/CgExtCode.hs b/compiler/codeGen/CgExtCode.hs
index 0e0a802445..12efa03da0 100644
--- a/compiler/codeGen/CgExtCode.hs
+++ b/compiler/codeGen/CgExtCode.hs
@@ -39,7 +39,7 @@ where
 import CgMonad
 
 import CLabel
-import Cmm
+import OldCmm
 
 -- import BasicTypes
 import BlockId
@@ -128,8 +128,8 @@ newLocal ty name = do
 newLabel :: FastString -> ExtFCode BlockId
 newLabel name = do
    u <- code newUnique
-   addLabel name (BlockId u)
-   return (BlockId u)
+   addLabel name (mkBlockId u)
+   return (mkBlockId u)
 
 
 -- | Add add a local function to the environment.
@@ -162,7 +162,7 @@ lookupLabel name = do
   return $ 
      case lookupUFM env name of
 	Just (Label l) 	-> l
-	_other 		-> BlockId (newTagUnique (getUnique name) 'L')
+	_other 		-> mkBlockId (newTagUnique (getUnique name) 'L')
 
 
 -- | Lookup the location of a named variable.
diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index cdaccc98a8..ec16946318 100644
--- a/compiler/codeGen/CgForeignCall.hs
+++ b/compiler/codeGen/CgForeignCall.hs
@@ -25,8 +25,8 @@ import CgUtils
 import Type
 import TysPrim
 import CLabel
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
 import SMRep
 import ForeignCall
 import ClosureInfo
diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs
index 174e510cb5..3ff646ca07 100644
--- a/compiler/codeGen/CgHeapery.lhs
+++ b/compiler/codeGen/CgHeapery.lhs
@@ -34,8 +34,8 @@ import CgCallConv
 import ClosureInfo
 import SMRep
 
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
 import Id
 import DataCon
 import TyCon
diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs
index d02c949b5e..8da2715ac2 100644
--- a/compiler/codeGen/CgHpc.hs
+++ b/compiler/codeGen/CgHpc.hs
@@ -8,10 +8,10 @@
 
 module CgHpc (cgTickBox, initHpc, hpcTable) where
 
-import Cmm
+import OldCmm
 import CLabel
 import Module
-import CmmUtils
+import OldCmmUtils
 import CgUtils
 import CgMonad
 import CgForeignCall
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index f704a69c18..e04079d666 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -31,8 +31,8 @@ import CgCallConv
 import CgUtils
 import CgMonad
 
-import CmmUtils
-import Cmm
+import OldCmmUtils
+import OldCmm
 import CLabel
 import Name
 import DataCon
diff --git a/compiler/codeGen/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs
index 5870cece99..ed21833f8c 100644
--- a/compiler/codeGen/CgLetNoEscape.lhs
+++ b/compiler/codeGen/CgLetNoEscape.lhs
@@ -24,8 +24,8 @@ import CgCon
 import CgHeapery
 import CgInfoTbls
 import CgStackery
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
 import CLabel
 import ClosureInfo
 import CostCentre
diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index 44c1cc4416..8a3b664fc1 100644
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -63,8 +63,8 @@ import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
 
 import DynFlags
 import BlockId
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
 import CLabel
 import StgSyn (SRT)
 import SMRep
@@ -709,7 +709,7 @@ labelC id = emitCgStmt (CgLabel id)
 
 newLabelC :: FCode BlockId
 newLabelC = do { u <- newUnique
-               ; return $ BlockId u }
+               ; return $ mkBlockId u }
 
 checkedAbsC :: CmmStmt -> Code
 -- Emit code, eliminating no-ops
@@ -742,10 +742,11 @@ emitData sect lits
     data_block = CmmData sect lits
 
 emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
-emitProc info lbl args blocks
-  = do  { let proc_block = CmmProc info lbl args (ListGraph blocks)
+emitProc info lbl [] blocks
+  = do  { let proc_block = CmmProc info lbl (ListGraph blocks)
 	; state <- getState
 	; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
 
 emitSimpleProc :: CLabel -> Code -> Code
 -- Emit a procedure whose body is the specified code; no info table
diff --git a/compiler/codeGen/CgParallel.hs b/compiler/codeGen/CgParallel.hs
index cfef25c161..682f28aad4 100644
--- a/compiler/codeGen/CgParallel.hs
+++ b/compiler/codeGen/CgParallel.hs
@@ -17,7 +17,7 @@ module CgParallel(
 import CgMonad
 import CgCallConv
 import Id
-import Cmm
+import OldCmm
 import StaticFlags
 import Outputable
 import SMRep
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index d0da575cf6..8ca42250a9 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -18,9 +18,9 @@ import CgBindery
 import CgMonad
 import CgInfoTbls
 import CgUtils
-import Cmm
+import OldCmm
 import CLabel
-import CmmUtils
+import OldCmmUtils
 import PrimOp
 import SMRep
 import Module
diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index 7491334c21..0cf209e89c 100644
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -37,8 +37,8 @@ import CgUtils
 import CgMonad
 import SMRep
 
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
 import CLabel
 
 import Id
diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs
index 532127a147..0d45b6eb90 100644
--- a/compiler/codeGen/CgStackery.lhs
+++ b/compiler/codeGen/CgStackery.lhs
@@ -26,8 +26,8 @@ import CgMonad
 import CgUtils
 import CgProf
 import SMRep
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
 import CLabel
 import Constants
 import Util
diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs
index 89c050406f..a3dbe6a1a8 100644
--- a/compiler/codeGen/CgTailCall.lhs
+++ b/compiler/codeGen/CgTailCall.lhs
@@ -28,8 +28,8 @@ import CgUtils
 import CgTicky
 import ClosureInfo
 import SMRep
-import Cmm	
-import CmmUtils
+import OldCmm	
+import OldCmmUtils
 import CLabel
 import Type
 import Id
diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs
index 7e8c5ca964..45cede5ca9 100644
--- a/compiler/codeGen/CgTicky.hs
+++ b/compiler/codeGen/CgTicky.hs
@@ -44,8 +44,8 @@ import CgUtils
 import CgMonad
 import SMRep
 
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
 import CLabel
 
 import Name
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 9d111ca9d8..922d330b26 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -61,10 +61,9 @@ import Id
 import IdInfo
 import Constants
 import SMRep
-import PprCmm		( {- instances -} )
-import Cmm
+import OldCmm
+import OldCmmUtils
 import CLabel
-import CmmUtils
 import ForeignCall
 import ClosureInfo
 import StgSyn (SRT(..))
@@ -1081,9 +1080,9 @@ get_Regtable_addr_from_offset rep offset =
 fixStgRegisters :: RawCmmTop -> RawCmmTop
 fixStgRegisters top@(CmmData _ _) = top
 
-fixStgRegisters (CmmProc info lbl params (ListGraph blocks)) =
+fixStgRegisters (CmmProc info lbl (ListGraph blocks)) =
   let blocks' = map fixStgRegBlock blocks
-  in CmmProc info lbl params $ ListGraph blocks'
+  in CmmProc info lbl $ ListGraph blocks'
 
 fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock
 fixStgRegBlock (BasicBlock id stmts) =
diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs
index 81267f21f9..6ce8fca55b 100644
--- a/compiler/codeGen/CodeGen.lhs
+++ b/compiler/codeGen/CodeGen.lhs
@@ -28,9 +28,9 @@ import CgUtils
 import CgHpc
 
 import CLabel
-import Cmm
-import CmmUtils
-import PprCmm
+import OldCmm
+import OldCmmUtils
+import OldPprCmm
 
 import StgSyn
 import PrelNames
diff --git a/compiler/codeGen/SMRep.lhs b/compiler/codeGen/SMRep.lhs
index 1667af8637..f35118d1c9 100644
--- a/compiler/codeGen/SMRep.lhs
+++ b/compiler/codeGen/SMRep.lhs
@@ -39,7 +39,7 @@ module SMRep (
 
 #include "../includes/MachDeps.h"
 
-import CmmExpr	-- CmmType and friends
+import CmmType
 import Id
 import Type
 import TyCon
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 52809da502..26ace0780f 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -23,8 +23,9 @@ import StgCmmClosure
 import StgCmmHpc
 import StgCmmTicky
 
-import MkZipCfgCmm
-import Cmm
+import MkGraph
+import CmmDecl
+import CmmExpr
 import CmmUtils
 import CLabel
 import PprCmm
@@ -53,7 +54,7 @@ codeGen :: DynFlags
 	 -> CollectedCCs		-- (Local/global) cost-centres needing declaring/registering.
 	 -> [(StgBinding,[(Id,[Id])])]	-- Bindings to convert, with SRTs
 	 -> HpcInfo
-	 -> IO [CmmZ]		-- Output
+	 -> IO [Cmm]		-- Output
 
 codeGen dflags this_mod data_tycons imported_mods 
         cost_centre_info stg_binds hpc_info
@@ -287,7 +288,7 @@ For charlike and intlike closures there is a fixed array of static
 closures predeclared.
 -}
 
-cgTyCon :: TyCon -> FCode [CmmZ]  -- All constructors merged together
+cgTyCon :: TyCon -> FCode [Cmm]  -- All constructors merged together
 cgTyCon tycon
   = do	{ constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
 
@@ -304,7 +305,7 @@ cgTyCon tycon
         ; return (extra ++ constrs)
         }
 
-cgEnumerationTyCon :: TyCon -> FCode [CmmZ]
+cgEnumerationTyCon :: TyCon -> FCode [Cmm]
 cgEnumerationTyCon tycon
   | isEnumerationTyCon tycon
   = do	{ tbl <- getCmm $ 
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 6451840f04..bfb749cb69 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -6,8 +6,8 @@
 --
 -----------------------------------------------------------------------------
 
-module StgCmmBind ( 
-	cgTopRhsClosure, 
+module StgCmmBind (
+	cgTopRhsClosure,
 	cgBind,
 	emitBlackHoleCode,
         pushUpdateFrame
@@ -26,15 +26,17 @@ import StgCmmGran
 import StgCmmLayout
 import StgCmmUtils
 import StgCmmClosure
+import StgCmmForeign    (emitPrimCall)
 
-import MkZipCfgCmm
+import MkGraph
 import CoreSyn		( AltCon(..) )
 import SMRep
-import Cmm
+import CmmDecl
+import CmmExpr
 import CmmUtils
 import CLabel
 import StgSyn
-import CostCentre	
+import CostCentre
 import Id
 import Control.Monad
 import Name
@@ -78,7 +80,7 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do
   	 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
   ; emitDataLits closure_label closure_rep
   ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
-	(_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) 
+	(_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
 				               (addIdReps [])
   -- Don't drop the non-void args until the closure info has been made
   ; forkClosureBody (closureCodeBody True id closure_info ccs
@@ -97,7 +99,7 @@ cgBind (StgNonRec name rhs)
         ; emit (init <*> body) }
 
 cgBind (StgRec pairs)
-  = do	{ ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits -> 
+  = do	{ ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
                do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
                   ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
        ; addBindsC new_binds
@@ -125,7 +127,7 @@ cgBind (StgRec pairs)
      m[hp-40] = y_info;
      // allocate and initialize z
      ...
-     
+
    For each closure, we must generate not only the code to allocate and
    initialize the closure itself, but also some Initialization Code that
    sets a variable holding the closure pointer.
@@ -239,9 +241,9 @@ mkRhsClosure    bndr cc bi
 		body@(StgApp fun_id args)
 
   | args `lengthIs` (arity-1)
- 	&& all isFollowableArg (map (idCgRep . stripNV) fvs) 
+ 	&& all isFollowableArg (map (idCgRep . stripNV) fvs)
  	&& isUpdatable upd_flag
- 	&& arity <= mAX_SPEC_AP_SIZE 
+ 	&& arity <= mAX_SPEC_AP_SIZE
 
  		   -- Ha! an Ap thunk
   = cgStdThunk bndr cc bi body lf_info payload
@@ -268,7 +270,7 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body
 		reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
 			    | otherwise	   = fvs
 
-		
+
 	-- MAKE CLOSURE INFO FOR THIS CLOSURE
 	; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
 	; mod_name <- getModuleName
@@ -276,8 +278,8 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body
 	; let	name  = idName bndr
 		descr = closureDescription mod_name name
 		fv_details :: [(NonVoid Id, VirtualHpOffset)]
-		(tot_wds, ptr_wds, fv_details) 
-		   = mkVirtHeapOffsets (isLFThunk lf_info) 
+		(tot_wds, ptr_wds, fv_details)
+		   = mkVirtHeapOffsets (isLFThunk lf_info)
 				       (addIdReps (map stripNV reduced_fvs))
 		closure_info = mkClosureInfo False	-- Not static
 					     bndr lf_info tot_wds ptr_wds
@@ -295,9 +297,9 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body
 	; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
         ; emit (mkComment $ mkFastString "calling allocDynClosure")
         ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
-	; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc 
+	; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc
 				         (map toVarArg fv_details)
-	
+
 	-- RETURN
 	; return $ (regIdInfo bndr lf_info tmp, init) }
 
@@ -319,12 +321,12 @@ cgStdThunk bndr cc _bndr_info body lf_info payload
   = do	-- AHA!  A STANDARD-FORM THUNK
   {	-- LAY OUT THE OBJECT
     mod_name <- getModuleName
-  ; let (tot_wds, ptr_wds, payload_w_offsets) 
+  ; let (tot_wds, ptr_wds, payload_w_offsets)
 	    = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
 
 	descr = closureDescription mod_name (idName bndr)
 	closure_info = mkClosureInfo False 	-- Not static
-				     bndr lf_info tot_wds ptr_wds 
+				     bndr lf_info tot_wds ptr_wds
 				     NoC_SRT	-- No SRT for a std-form closure
 				     descr
 
@@ -359,10 +361,10 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
 	 	-> [NonVoid Id]    -- incoming args to the closure
 	 	-> Int             -- arity, including void args
 		-> StgExpr
-		-> [(NonVoid Id, VirtualHpOffset)] -- the closure's free variables
+		-> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars
 		-> FCode ()
 
-{- There are two main cases for the code for closures.  
+{- There are two main cases for the code for closures.
 
 * If there are *no arguments*, then the closure is a thunk, and not in
   normal form. So it should set up an update frame (if it is
@@ -372,42 +374,46 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
   normal form, so there is no need to set up an update frame.
 
   The Macros for GrAnSim are produced at the beginning of the
-  argSatisfactionCheck (by calling fetchAndReschedule).  
+  argSatisfactionCheck (by calling fetchAndReschedule).
   There info if Node points to closure is available. -- HWL -}
 
 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
   | length args == 0 -- No args i.e. thunk
   = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
-      (\ (node, _) -> thunkCode cl_info fv_details cc node arity body)
+      \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
 
 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
   = ASSERT( length args > 0 )
-    do	{ 	-- Allocate the global ticky counter,
-	   	-- and establish the ticky-counter 
-		-- label for this block
-	  let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info
-	; emitTickyCounter cl_info (map stripNV args)
-	; setTickyCtrLabel ticky_ctr_lbl $ do
-
-	-- Emit the main entry code
-        ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do
-                    -- Emit the slow-entry code (for entering a closure through a PAP)
+    do  { -- Allocate the global ticky counter,
+          -- and establish the ticky-counter
+          -- label for this block
+          let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $
+                                  clHasCafRefs cl_info
+        ; emitTickyCounter cl_info (map stripNV args)
+        ; setTickyCtrLabel ticky_ctr_lbl $ do
+
+        -- Emit the main entry code
+        ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $
+            \(offset, node, arg_regs) -> do
+                -- Emit slow-entry code (for entering a closure through a PAP)
                 { mkSlowEntryCode cl_info arg_regs
 
                 ; let lf_info = closureLFInfo cl_info
                       node_points = nodeMustPointToIt lf_info
+                      node' = if node_points then Just node else Nothing
                 ; tickyEnterFun cl_info
                 ; whenC node_points (ldvEnterClosure cl_info)
                 ; granYield arg_regs node_points
 
-                        -- Main payload
-                ; entryHeapCheck (if node_points then Just node else Nothing) arity arg_regs $ do
+                -- Main payload
+                ; entryHeapCheck cl_info offset node' arity arg_regs $ do
                 { enterCostCentre cl_info cc body
                 ; fv_bindings <- mapM bind_fv fv_details
                 -- Load free vars out of closure *after*
-                ; if node_points then load_fvs node lf_info fv_bindings else return ()
-                ; cgExpr body }}	    -- heap check, to reduce live vars over check
-
+                -- heap check, to reduce live vars over check
+                ; if node_points then load_fvs node lf_info fv_bindings
+                                 else return ()
+                ; cgExpr body }}
   }
 
 -- A function closure pointer may be tagged, so we
@@ -426,55 +432,56 @@ load_fvs node lf_info = mapCs (\ (reg, off) ->
 -- according to the calling convention, and jumps to the function's
 -- normal entry point.  The function's closure is assumed to be in
 -- R1/node.
--- 
--- The slow entry point is used for unknown calls: eg. stg_PAP_entry 
+--
+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry
 
 mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
 -- If this function doesn't have a specialised ArgDescr, we need
 -- to generate the function's arg bitmap and slow-entry code.
 -- Here, we emit the slow-entry code.
-mkSlowEntryCode cl_info (_ : arg_regs) -- first arg should already be in `Node'
+mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
+mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
   | Just (_, ArgGen _) <- closureFunInfo cl_info
-  = emitProcWithConvention Slow (CmmInfo Nothing Nothing CmmNonInfoTable) slow_lbl
-                           arg_regs jump
+  = emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump
   | otherwise = return ()
   where
      caf_refs = clHasCafRefs cl_info
      name     = closureName cl_info
      slow_lbl = mkSlowEntryLabel  name caf_refs
      fast_lbl = enterLocalIdLabel name caf_refs
-     jump = mkJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
-                   initUpdFrameOff
-mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
+     -- mkDirectJump does not clobber `Node' containing function closure
+     jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
+                         initUpdFrameOff
 
 -----------------------------------------
-thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack ->
-             LocalReg -> Int -> StgExpr -> FCode ()
-thunkCode cl_info fv_details cc node arity body 
-  = do	{ let node_points = nodeMustPointToIt (closureLFInfo cl_info)
-   	; tickyEnterThunk cl_info
-	; ldvEnterClosure cl_info  -- NB: Node always points when profiling
-	; granThunk node_points
+thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack
+          -> LocalReg -> Int -> StgExpr -> FCode ()
+thunkCode cl_info fv_details cc node arity body
+  = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
+             node'       = if node_points then Just node else Nothing
+        ; tickyEnterThunk cl_info
+        ; ldvEnterClosure cl_info -- NB: Node always points when profiling
+        ; granThunk node_points
 
         -- Heap overflow check
-	; entryHeapCheck (if node_points then Just node else Nothing) arity [] $ do
-      	{	-- Overwrite with black hole if necessary
-		-- but *after* the heap-overflow check
-	  dflags <- getDynFlags
-	; whenC (blackHoleOnEntry dflags cl_info && node_points)
- 	        (blackHoleIt cl_info)
-
-		-- Push update frame
-	; setupUpdate cl_info node $
-	    	-- We only enter cc after setting up update so
-	    	-- that cc of enclosing scope will be recorded
-	    	-- in update frame CAF/DICT functions will be
-	    	-- subsumed by this enclosing cc
+        ; entryHeapCheck cl_info 0 node' arity [] $ do
+        { -- Overwrite with black hole if necessary
+          -- but *after* the heap-overflow check
+          dflags <- getDynFlags
+        ; whenC (blackHoleOnEntry dflags cl_info && node_points)
+                (blackHoleIt cl_info)
+
+          -- Push update frame
+        ; setupUpdate cl_info node $
+            -- We only enter cc after setting up update so
+            -- that cc of enclosing scope will be recorded
+            -- in update frame CAF/DICT functions will be
+            -- subsumed by this enclosing cc
             do { enterCostCentre cl_info cc body
                ; let lf_info = closureLFInfo cl_info
                ; fv_bindings <- mapM bind_fv fv_details
                ; load_fvs node lf_info fv_bindings
-	       ; cgExpr body }}}
+               ; cgExpr body }}}
 
 
 ------------------------------------------------------------------------
@@ -487,11 +494,13 @@ blackHoleIt :: ClosureInfo -> FCode ()
 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
 
 emitBlackHoleCode :: Bool -> FCode ()
-emitBlackHoleCode is_single_entry 
-  | eager_blackholing = do 
+emitBlackHoleCode is_single_entry
+  | eager_blackholing = do
 	tickyBlackHole (not is_single_entry)
+        emit (mkStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO)))
+        emitPrimCall [] MO_WriteBarrier []
 	emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
-  | otherwise = 
+  | otherwise =
 	nopC
   where
     bh_lbl | is_single_entry = mkCmmDataLabel rtsPackageId (fsLit "stg_SE_BLACKHOLE_info")
@@ -507,11 +516,11 @@ emitBlackHoleCode is_single_entry
 	-- currently eager blackholing doesn't work with profiling.
 	--
         -- Previously, eager blackholing was enabled when ticky-ticky
-        -- was on. But it didn't work, and it wasn't strictly necessary 
-        -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING 
+        -- was on. But it didn't work, and it wasn't strictly necessary
+        -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
         -- is unconditionally disabled. -- krc 1/2007
 
-    eager_blackholing = False 
+    eager_blackholing = False
 
 setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
 	-- Nota Bene: this function does not change Node (even if it's a CAF),
@@ -522,12 +531,17 @@ setupUpdate closure_info node body
   = body
 
   | not (isStaticClosure closure_info)
-  = if closureUpdReqd closure_info
-    then do { tickyPushUpdateFrame;
-	    ; pushUpdateFrame [CmmReg (CmmLocal node),
-                               mkLblExpr mkUpdInfoLabel] body }
-    else do { tickyUpdateFrameOmitted; body}
- 
+  = if not (closureUpdReqd closure_info)
+      then do tickyUpdateFrameOmitted; body
+      else do
+          tickyPushUpdateFrame
+          --dflags <- getDynFlags
+          let es = [CmmReg (CmmLocal node), mkLblExpr mkUpdInfoLabel]
+          --if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
+          --  then pushUpdateFrame es body -- XXX black hole
+          --  else pushUpdateFrame es body
+          pushUpdateFrame es body
+
   | otherwise	-- A static closure
   = do 	{ tickyUpdateBhCaf closure_info
 
@@ -535,16 +549,20 @@ setupUpdate closure_info node body
 	  then do	-- Blackhole the (updatable) CAF:
 		{ upd_closure <- link_caf closure_info True
 		; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
-                                   mkLblExpr mkUpdInfoLabel] body }
+                                     mkLblExpr mkUpdInfoLabel] body } -- XXX black hole
 	  else do {tickyUpdateFrameOmitted; body}
     }
 
+-----------------------------------------------------------------------------
+-- Setting up update frames
+
 -- Push the update frame on the stack in the Entry area,
 -- leaving room for the return address that is already
 -- at the old end of the area.
 pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
 pushUpdateFrame es body
-  = do updfr  <- getUpdFrameOff
+  = do -- [EZY] I'm not sure if we need to special-case for BH too
+       updfr  <- getUpdFrameOff
        offset <- foldM push updfr es
        withUpdFrameOff offset body
      where push off e =
@@ -563,7 +581,7 @@ pushUpdateFrame es body
 -- allocated black hole to be empty.
 --
 -- Why do we make a black hole in the heap when we enter a CAF?
---    
+--
 --     - for a  generational garbage collector, which needs a fast
 --       test for whether an updatee is in an old generation or not
 --
@@ -581,7 +599,7 @@ pushUpdateFrame es body
 -- ToDo [Feb 04]  This entire link_caf nonsense could all be moved
 -- into the "newCAF" RTS procedure, which we call anyway, including
 -- the allocation of the black-hole indirection closure.
--- That way, code size would fall, the CAF-handling code would 
+-- That way, code size would fall, the CAF-handling code would
 -- be closer together, and the compiler wouldn't need to know
 -- about off_indirectee etc.
 
@@ -598,12 +616,14 @@ link_caf cl_info _is_upd = do
   { 	-- Alloc black hole specifying CC_HDR(Node) as the cost centre
   ; let	use_cc   = costCentreFrom (CmmReg nodeReg)
         blame_cc = use_cc
-  ; (hp_rel, init) <- allocDynClosure bh_cl_info use_cc blame_cc []
+        tso      = CmmReg (CmmGlobal CurrentTSO)
+    -- XXX ezyang: FIXME
+  ; (hp_rel, init) <- allocDynClosureCmm bh_cl_info use_cc blame_cc [(tso,fixedHdrSize)]
   ; emit init
 
 	-- Call the RTS function newCAF to add the CAF to the CafList
 	-- so that the garbage collector can find them
-	-- This must be done *before* the info table pointer is overwritten, 
+	-- This must be done *before* the info table pointer is overwritten,
 	-- because the old info table ptr is needed for reversion
   ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
       [ (CmmReg (CmmGlobal BaseReg),  AddrHint),
@@ -611,7 +631,7 @@ link_caf cl_info _is_upd = do
       [node] False
 	-- node is live, so save it.
 
-	-- Overwrite the closure with a (static) indirection 
+	-- Overwrite the closure with a (static) indirection
 	-- to the newly-allocated black hole
   ; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*>
 	  mkStore (CmmReg nodeReg) ind_static_info)
@@ -629,7 +649,7 @@ link_caf cl_info _is_upd = do
 
 
 ------------------------------------------------------------------------
---		Profiling 
+--		Profiling
 ------------------------------------------------------------------------
 
 -- For "global" data constructors the description is simply occurrence
@@ -648,4 +668,4 @@ closureDescription mod_name name
 		      else pprModule mod_name <> char '.' <> ppr name) <>
 		    char '>')
    -- showSDocDump, because we want to see the unique on the Name.
-  
+
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index d66dda5021..fe09f6851b 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -11,7 +11,6 @@
 --
 -----------------------------------------------------------------------------
 
-
 module StgCmmClosure (
         SMRep, 
 	DynTag,  tagForCon, isSmallFamily,
@@ -73,7 +72,7 @@ import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..))
 
 import StgSyn
 import SMRep
-import Cmm	( ClosureTypeInfo(..), ConstrDescription )
+import CmmDecl ( ClosureTypeInfo(..), ConstrDescription )
 import CmmExpr
 
 import CLabel
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index cebd743e94..633d577c73 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -25,9 +25,9 @@ import StgCmmUtils
 import StgCmmClosure
 import StgCmmProf
 
-import Cmm
+import CmmExpr
 import CLabel
-import MkZipCfgCmm (CmmAGraph, mkNop)
+import MkGraph
 import SMRep
 import CostCentre
 import Module
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index cd94c58daa..469f58d7df 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -35,10 +35,9 @@ import StgCmmClosure
 import CLabel
 
 import BlockId
-import Cmm
+import CmmExpr
 import CmmUtils
 import FastString
-import PprCmm		( {- instance Outputable -} )
 import Id
 import VarEnv
 import Control.Monad
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 94afb80f5b..eee4a08bc7 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -27,7 +27,7 @@ import StgCmmClosure
 
 import StgSyn
 
-import MkZipCfgCmm
+import MkGraph
 import BlockId
 import CmmExpr
 import CoreSyn
@@ -455,10 +455,8 @@ cgAltRhss gc_plan bndr alts
 	   ; return con }
 
 maybeAltHeapCheck :: GcPlan -> FCode a -> FCode a
-maybeAltHeapCheck NoGcInAlts code
-  = code
-maybeAltHeapCheck (GcInAlts regs _) code
-  = altHeapCheck regs code
+maybeAltHeapCheck NoGcInAlts        code = code
+maybeAltHeapCheck (GcInAlts regs _) code = altHeapCheck regs code
 
 -----------------------------------------------------------------------------
 -- 	Tail calls
@@ -610,3 +608,4 @@ we should still generate the same code:
    L2:
       <default-case code>
 -}
+
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index 7ddf597f40..9a15cf0d06 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -24,9 +24,11 @@ import StgCmmUtils
 import StgCmmClosure
 
 import BlockId
-import Cmm
+import CmmDecl
+import CmmExpr
 import CmmUtils
-import MkZipCfgCmm hiding (CmmAGraph)
+import OldCmm ( CmmReturnInfo(..) )
+import MkGraph
 import Type
 import TysPrim
 import CLabel
@@ -36,7 +38,6 @@ import Constants
 import StaticFlags
 import Maybes
 import Outputable
-import ZipCfgCmmRep
 import BasicTypes
 
 import Control.Monad
@@ -111,7 +112,7 @@ emitPrimCall res op args
 emitForeignCall
 	:: Safety
 	-> CmmFormals		-- where to put the results
-	-> MidCallTarget	-- the op
+	-> ForeignTarget	-- the op
 	-> CmmActuals		-- arguments
         -> C_SRT                -- the SRT of the calls continuation
         -> CmmReturnInfo	-- This can say "never returns"
@@ -145,7 +146,7 @@ load_args_into_temps = mapM arg_assign_temp
 	   return (tmp,hint)
 -}
 	
-load_target_into_temp :: MidCallTarget -> FCode MidCallTarget
+load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
 load_target_into_temp (ForeignTarget expr conv) = do 
   tmp <- maybe_assign_temp expr
   return (ForeignTarget tmp conv)
@@ -171,8 +172,8 @@ maybe_assign_temp e
 
 saveThreadState :: CmmAGraph
 saveThreadState =
-  -- CurrentTSO->sp = Sp;
-  mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
+  -- CurrentTSO->stackobj->sp = Sp;
+  mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP) stgSp
   <*> closeNursery
   -- and save the current cost centre stack in the TSO when profiling:
   <*> if opt_SccProfilingOn then
@@ -181,8 +182,8 @@ saveThreadState =
 
 emitSaveThreadState :: BlockId -> FCode ()
 emitSaveThreadState bid = do
-  -- CurrentTSO->sp = Sp;
-  emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
+  -- CurrentTSO->stackobj->sp = Sp;
+  emit $ mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP)
                  (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
   emit closeNursery
   -- and save the current cost centre stack in the TSO when profiling:
@@ -193,17 +194,19 @@ emitSaveThreadState bid = do
 closeNursery :: CmmAGraph
 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 
-loadThreadState :: LocalReg -> CmmAGraph
-loadThreadState tso = do
+loadThreadState :: LocalReg -> LocalReg -> CmmAGraph
+loadThreadState tso stack = do
   -- tso <- newTemp gcWord -- TODO FIXME NOW
+  -- stack <- newTemp gcWord -- TODO FIXME NOW
   catAGraphs [
 	-- tso = CurrentTSO;
   	mkAssign (CmmLocal tso) stgCurrentTSO,
-	-- Sp = tso->sp;
-	mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
-	                      bWord),
-	-- SpLim = tso->stack + RESERVED_STACK_WORDS;
-	mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
+	-- stack = tso->stackobj;
+	mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
+	-- Sp = stack->sp;
+	mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) bWord),
+	-- SpLim = stack->stack + RESERVED_STACK_WORDS;
+	mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
 			            rESERVED_STACK_WORDS),
         openNursery,
         -- and load the current cost centre stack from the TSO when profiling:
@@ -211,8 +214,8 @@ loadThreadState tso = do
 	  mkStore curCCSAddr
                   (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
         else mkNop]
-emitLoadThreadState :: LocalReg -> FCode ()
-emitLoadThreadState tso = emit $ loadThreadState tso
+emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
+emitLoadThreadState tso stack = emit $ loadThreadState tso stack
 
 openNursery :: CmmAGraph
 openNursery = catAGraphs [
@@ -242,22 +245,15 @@ nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 
-tso_SP, tso_STACK, tso_CCCS :: ByteOff
-tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
+tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
+tso_stackobj = closureField oFFSET_StgTSO_stackobj
+tso_CCCS     = closureField oFFSET_StgTSO_CCCS
+stack_STACK  = closureField oFFSET_StgStack_stack
+stack_SP     = closureField oFFSET_StgStack_sp
 
- --ToDo: needs merging with changes to CgForeign
-tso_STACK = tsoFieldB     undefined
-tso_SP    = tsoFieldB     undefined
 
--- The TSO struct has a variable header, and an optional StgTSOProfInfo in
--- the middle.  The fields we're interested in are after the StgTSOProfInfo.
-tsoFieldB :: ByteOff -> ByteOff
-tsoFieldB off
-  | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
-  | otherwise          = off + fixedHdrSize * wORD_SIZE
-
-tsoProfFieldB :: ByteOff -> ByteOff
-tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
+closureField :: ByteOff -> ByteOff
+closureField off = off + fixedHdrSize * wORD_SIZE
 
 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
 stgSp		  = CmmReg sp
diff --git a/compiler/codeGen/StgCmmGran.hs b/compiler/codeGen/StgCmmGran.hs
index 27e6114356..b6a1ae66bb 100644
--- a/compiler/codeGen/StgCmmGran.hs
+++ b/compiler/codeGen/StgCmmGran.hs
@@ -19,7 +19,7 @@ module StgCmmGran (
 -- I've left the calls, though, in case anyone wants to resurrect it
 
 import StgCmmMonad
-import Cmm
+import CmmExpr
 
 staticGranHdr :: [CmmLit]
 staticGranHdr = []
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 4163723947..0015da1cac 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -7,19 +7,20 @@
 -----------------------------------------------------------------------------
 
 module StgCmmHeap (
-	getVirtHp, setVirtHp, setRealHp, 
-	getHpRelOffset,	hpRel,
+        getVirtHp, setVirtHp, setRealHp,
+        getHpRelOffset, hpRel,
 
-	entryHeapCheck,	altHeapCheck,
+        entryHeapCheck, altHeapCheck,
 
-	layOutDynConstr, layOutStaticConstr,
-	mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
+        layOutDynConstr, layOutStaticConstr,
+        mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
 
-	allocDynClosure, emitSetDynHdr
+        allocDynClosure, allocDynClosureCmm, emitSetDynHdr
     ) where
 
 #include "HsVersions.h"
 
+import CmmType
 import StgSyn
 import CLabel
 import StgCmmLayout
@@ -31,7 +32,7 @@ import StgCmmGran
 import StgCmmClosure
 import StgCmmEnv
 
-import MkZipCfgCmm
+import MkGraph
 
 import SMRep
 import CmmExpr
@@ -41,49 +42,53 @@ import TyCon
 import CostCentre
 import Outputable
 import Module
-import FastString( mkFastString, FastString, fsLit )
+import FastString( mkFastString, fsLit )
 import Constants
 
-
 -----------------------------------------------------------
---		Layout of heap objects
+--              Layout of heap objects
 -----------------------------------------------------------
 
 layOutDynConstr, layOutStaticConstr
-	:: DataCon -> [(PrimRep, a)]
-	-> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
--- No Void arguments in result
+        :: DataCon -> [(PrimRep, a)]
+        -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
+        -- No Void arguments in result
 
 layOutDynConstr    = layOutConstr False
 layOutStaticConstr = layOutConstr True
 
 layOutConstr :: Bool -> DataCon -> [(PrimRep, a)]
-	     -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
+             -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
 layOutConstr is_static data_con args
    = (mkConInfo is_static data_con tot_wds ptr_wds,
       things_w_offsets)
   where
-    (tot_wds,		 --  #ptr_wds + #nonptr_wds
-     ptr_wds,		 --  #ptr_wds
+    (tot_wds, --  #ptr_wds + #nonptr_wds
+     ptr_wds, --  #ptr_wds
      things_w_offsets) = mkVirtHeapOffsets False{-not a thunk-} args
 
 
 -----------------------------------------------------------
---		Initialise dynamic heap objects
+--              Initialise dynamic heap objects
 -----------------------------------------------------------
 
 allocDynClosure
-	:: ClosureInfo
-	-> CmmExpr 		-- Cost Centre to stick in the object
-	-> CmmExpr 		-- Cost Centre to blame for this alloc
-				-- (usually the same; sometimes "OVERHEAD")
-
-	-> [(NonVoid StgArg, VirtualHpOffset)]	-- Offsets from start of the object
-					        -- ie Info ptr has offset zero.
-					        -- No void args in here
-	-> FCode (LocalReg, CmmAGraph)
-
--- allocDynClosure allocates the thing in the heap, 
+        :: ClosureInfo
+        -> CmmExpr              -- Cost Centre to stick in the object
+        -> CmmExpr              -- Cost Centre to blame for this alloc
+                                -- (usually the same; sometimes "OVERHEAD")
+
+        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object
+                                                -- ie Info ptr has offset zero.
+                                                -- No void args in here
+        -> FCode (LocalReg, CmmAGraph)
+
+allocDynClosureCmm
+        :: ClosureInfo -> CmmExpr -> CmmExpr
+        -> [(CmmExpr, VirtualHpOffset)]
+        -> FCode (LocalReg, CmmAGraph)
+
+-- allocDynClosure allocates the thing in the heap,
 -- and modifies the virtual Hp to account for this.
 -- The second return value is the graph that sets the value of the
 -- returned LocalReg, which should point to the closure after executing
@@ -93,84 +98,89 @@ allocDynClosure
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- allocDynClosure returns a LocalReg, not a (Hp+8) CmmExpr.
 -- Reason:
---	...allocate object...
---	obj = Hp + 8	
---	y = f(z)
---	...here obj is still valid,
---	   but Hp+8 means something quite different...
+--      ...allocate object...
+--      obj = Hp + 8
+--      y = f(z)
+--      ...here obj is still valid,
+--         but Hp+8 means something quite different...
 
 
 allocDynClosure cl_info use_cc _blame_cc args_w_offsets
-  = do	{ virt_hp <- getVirtHp
-
-	-- SAY WHAT WE ARE ABOUT TO DO
-	; tickyDynAlloc cl_info
-	; profDynAlloc cl_info use_cc	
-		-- ToDo: This is almost certainly wrong
-		-- We're ignoring blame_cc. But until we've
-		-- fixed the boxing hack in chooseDynCostCentres etc,
-		-- we're worried about making things worse by "fixing"
-		-- this part to use blame_cc!
-
-	-- FIND THE OFFSET OF THE INFO-PTR WORD
-	; let	info_offset = virt_hp + 1
-		-- info_offset is the VirtualHpOffset of the first
-		-- word of the new object
-		-- Remember, virtHp points to last allocated word, 
-		-- ie 1 *before* the info-ptr word of new object.
-
-		info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
-
-	-- ALLOCATE THE OBJECT
-	; base <- getHpRelOffset info_offset
+  = do  { let (args, offsets) = unzip args_w_offsets
+        ; cmm_args <- mapM getArgAmode args     -- No void args
+        ; allocDynClosureCmm cl_info use_cc _blame_cc (zip cmm_args offsets)
+        }
+
+allocDynClosureCmm cl_info use_cc _blame_cc amodes_w_offsets
+  = do  { virt_hp <- getVirtHp
+
+        -- SAY WHAT WE ARE ABOUT TO DO
+        ; tickyDynAlloc cl_info
+        ; profDynAlloc cl_info use_cc
+                -- ToDo: This is almost certainly wrong
+                -- We're ignoring blame_cc. But until we've
+                -- fixed the boxing hack in chooseDynCostCentres etc,
+                -- we're worried about making things worse by "fixing"
+                -- this part to use blame_cc!
+
+        -- FIND THE OFFSET OF THE INFO-PTR WORD
+        ; let   info_offset = virt_hp + 1
+                -- info_offset is the VirtualHpOffset of the first
+                -- word of the new object
+                -- Remember, virtHp points to last allocated word,
+                -- ie 1 *before* the info-ptr word of new object.
+
+                info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
+
+        -- ALLOCATE THE OBJECT
+        ; base <- getHpRelOffset info_offset
         ; emit (mkComment $ mkFastString "allocDynClosure")
-	; emitSetDynHdr base info_ptr  use_cc
-	; let (args, offsets) = unzip args_w_offsets
-	; cmm_args <- mapM getArgAmode args	-- No void args 
-	; hpStore base cmm_args offsets
-
-	-- BUMP THE VIRTUAL HEAP POINTER
-	; setVirtHp (virt_hp + closureSize cl_info)
-	
-	-- Assign to a temporary and return
-	-- Note [Return a LocalReg]
-	; hp_rel <- getHpRelOffset info_offset
-	; getCodeR $ assignTemp hp_rel }
+        ; emitSetDynHdr base info_ptr  use_cc
+        ; let (cmm_args, offsets) = unzip amodes_w_offsets
+        ; hpStore base cmm_args offsets
+
+        -- BUMP THE VIRTUAL HEAP POINTER
+        ; setVirtHp (virt_hp + closureSize cl_info)
+
+        -- Assign to a temporary and return
+        -- Note [Return a LocalReg]
+        ; hp_rel <- getHpRelOffset info_offset
+        ; getCodeR $ assignTemp hp_rel }
 
 emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
-emitSetDynHdr base info_ptr ccs 
+emitSetDynHdr base info_ptr ccs
   = hpStore base header [0..]
   where
     header :: [CmmExpr]
     header = [info_ptr] ++ dynProfHdr ccs
-     	-- ToDo: Gransim stuff
-	-- ToDo: Parallel stuff
-	-- No ticky header
+        -- ToDo: Gransim stuff
+        -- ToDo: Parallel stuff
+        -- No ticky header
 
 hpStore :: CmmExpr -> [CmmExpr] -> [VirtualHpOffset] -> FCode ()
 -- Store the item (expr,off) in base[off]
 hpStore base vals offs
   = emit (catAGraphs (zipWith mk_store vals offs))
   where
-    mk_store val off = mkStore (cmmOffsetW base off) val 
+    mk_store val off = mkStore (cmmOffsetW base off) val
 
 
 -----------------------------------------------------------
---		Layout of static closures
+--              Layout of static closures
 -----------------------------------------------------------
 
 -- Make a static closure, adding on any extra padding needed for CAFs,
 -- and adding a static link field if necessary.
 
-mkStaticClosureFields 
-	:: ClosureInfo 
-	-> CostCentreStack 
-	-> Bool 		-- Has CAF refs
-	-> [CmmLit]		-- Payload
-	-> [CmmLit]		-- The full closure
+mkStaticClosureFields
+        :: ClosureInfo
+        -> CostCentreStack
+        -> Bool                 -- Has CAF refs
+        -> [CmmLit]             -- Payload
+        -> [CmmLit]             -- The full closure
 mkStaticClosureFields cl_info ccs caf_refs payload
-  = mkStaticClosure info_lbl ccs payload padding_wds 
-	static_link_field saved_info_field
+  = mkStaticClosure info_lbl ccs payload padding
+        static_link_field saved_info_field
   where
     info_lbl = infoTableLabelFromCI cl_info
 
@@ -188,44 +198,44 @@ mkStaticClosureFields cl_info ccs caf_refs payload
 
     is_caf = closureNeedsUpdSpace cl_info
 
-    padding_wds
-	| not is_caf = []
-	| otherwise  = ASSERT(null payload) [mkIntCLit 0]
+    padding
+        | not is_caf = []
+        | otherwise  = ASSERT(null payload) [mkIntCLit 0]
 
     static_link_field
-	| is_caf || staticClosureNeedsLink cl_info = [static_link_value]
-	| otherwise				   = []
+        | is_caf || staticClosureNeedsLink cl_info = [static_link_value]
+        | otherwise                                = []
 
     saved_info_field
-	| is_caf     = [mkIntCLit 0]
-	| otherwise  = []
+        | is_caf     = [mkIntCLit 0]
+        | otherwise  = []
 
-	-- for a static constructor which has NoCafRefs, we set the
-	-- static link field to a non-zero value so the garbage
-	-- collector will ignore it.
+        -- for a static constructor which has NoCafRefs, we set the
+        -- static link field to a non-zero value so the garbage
+        -- collector will ignore it.
     static_link_value
-	| caf_refs	= mkIntCLit 0
-	| otherwise	= mkIntCLit 1
+        | caf_refs      = mkIntCLit 0
+        | otherwise     = mkIntCLit 1
 
 
 mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
   -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
-mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
+mkStaticClosure info_lbl ccs payload padding static_link_field saved_info_field
   =  [CmmLabel info_lbl]
   ++ variable_header_words
   ++ concatMap padLitToWord payload
-  ++ padding_wds
+  ++ padding
   ++ static_link_field
   ++ saved_info_field
   where
     variable_header_words
-	=  staticGranHdr
-	++ staticParHdr
-	++ staticProfHdr ccs
-	++ staticTickyHdr
+        =  staticGranHdr
+        ++ staticParHdr
+        ++ staticProfHdr ccs
+        ++ staticTickyHdr
 
--- JD: Simon had ellided this padding, but without it the C back end asserts failure.
--- Maybe it's a bad assertion, and this padding is indeed unnecessary?
+-- JD: Simon had ellided this padding, but without it the C back end asserts
+-- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary?
 padLitToWord :: CmmLit -> [CmmLit]
 padLitToWord lit = lit : padding pad_length
   where width = typeWidth (cmmLitType lit)
@@ -238,7 +248,7 @@ padLitToWord lit = lit : padding pad_length
                   | otherwise      = CmmInt 0 W64 : padding (n-8)
 
 -----------------------------------------------------------
---		Heap overflow checking
+--              Heap overflow checking
 -----------------------------------------------------------
 
 {- Note [Heap checks]
@@ -251,12 +261,12 @@ convention.
     nothing to its caller
 
   * A series of canned entry points like
-	r = gc_1p( r )
+        r = gc_1p( r )
     where r is a pointer.  This performs gc, and
     then returns its argument r to its caller.
-    
+
   * A series of canned entry points like
-	gcfun_2p( f, x, y )
+        gcfun_2p( f, x, y )
     where f is a function closure of arity 2
     This performs garbage collection, keeping alive the
     three argument ptrs, and then tail-calls f(x,y)
@@ -266,213 +276,251 @@ These are used in the following circumstances
 * entryHeapCheck: Function entry
     (a) With a canned GC entry sequence
         f( f_clo, x:ptr, y:ptr ) {
-    	     Hp = Hp+8
-    	     if Hp > HpLim goto L
-    	     ...
+             Hp = Hp+8
+             if Hp > HpLim goto L
+             ...
           L: HpAlloc = 8
              jump gcfun_2p( f_clo, x, y ) }
      Note the tail call to the garbage collector;
-     it should do no register shuffling  
+     it should do no register shuffling
 
     (b) No canned sequence
         f( f_clo, x:ptr, y:ptr, ...etc... ) {
-    	  T: Hp = Hp+8
-    	     if Hp > HpLim goto L
-    	     ...
+          T: Hp = Hp+8
+             if Hp > HpLim goto L
+             ...
           L: HpAlloc = 8
-             call gc() 	-- Needs an info table
-	     goto T }
+             call gc()  -- Needs an info table
+             goto T }
 
 * altHeapCheck: Immediately following an eval
-  Started as 
-	case f x y of r { (p,q) -> rhs }
+  Started as
+        case f x y of r { (p,q) -> rhs }
   (a) With a canned sequence for the results of f
        (which is the very common case since
        all boxed cases return just one pointer
-	   ...
-	   r = f( x, y )
-	K: 	-- K needs an info table
-	   Hp = Hp+8
-	   if Hp > HpLim goto L
-	   ...code for rhs...
+           ...
+           r = f( x, y )
+        K:      -- K needs an info table
+           Hp = Hp+8
+           if Hp > HpLim goto L
+           ...code for rhs...
 
-	L: r = gc_1p( r )
-	   goto K }
+        L: r = gc_1p( r )
+           goto K }
 
-	Here, the info table needed by the call 
-	to gc_1p should be the *same* as the
-	one for the call to f; the C-- optimiser 
-	spots this sharing opportunity)
+        Here, the info table needed by the call
+        to gc_1p should be the *same* as the
+        one for the call to f; the C-- optimiser
+        spots this sharing opportunity)
 
    (b) No canned sequence for results of f
        Note second info table
-	   ...
-	   (r1,r2,r3) = call f( x, y )
-	K: 
-	   Hp = Hp+8
-	   if Hp > HpLim goto L
-	   ...code for rhs...
+           ...
+           (r1,r2,r3) = call f( x, y )
+        K:
+           Hp = Hp+8
+           if Hp > HpLim goto L
+           ...code for rhs...
 
-	L: call gc()	-- Extra info table here
-	   goto K
+        L: call gc()    -- Extra info table here
+           goto K
 
 * generalHeapCheck: Anywhere else
   e.g. entry to thunk
-       case branch *not* following eval, 
+       case branch *not* following eval,
        or let-no-escape
   Exactly the same as the previous case:
 
-	K: 	-- K needs an info table
-	   Hp = Hp+8
-	   if Hp > HpLim goto L
-	   ...
+        K:      -- K needs an info table
+           Hp = Hp+8
+           if Hp > HpLim goto L
+           ...
 
-	L: call gc()
-	   goto K
+        L: call gc()
+           goto K
 -}
 
 --------------------------------------------------------------
 -- A heap/stack check at a function or thunk entry point.
 
-entryHeapCheck :: Maybe LocalReg -- Function (closure environment)
-	       -> Int           -- Arity -- not same as length args b/c of voids
-	       -> [LocalReg]	-- Non-void args (empty for thunk)
-	       -> FCode ()
-	       -> FCode ()
+entryHeapCheck :: ClosureInfo
+               -> Int            -- Arg Offset
+               -> Maybe LocalReg -- Function (closure environment)
+               -> Int            -- Arity -- not same as len args b/c of voids
+               -> [LocalReg]     -- Non-void args (empty for thunk)
+               -> FCode ()
+               -> FCode ()
 
-entryHeapCheck fun arity args code
+entryHeapCheck cl_info offset nodeSet arity args code
   = do updfr_sz <- getUpdFrameOff
-       heapCheck True (gc_call updfr_sz) code   -- The 'fun' keeps relevant CAFs alive
+       heapCheck True (gc_call updfr_sz) code
+
   where
+    is_thunk = arity == 0
+    is_fastf = case closureFunInfo cl_info of
+                    Just (_, ArgGen _) -> False
+                    _otherwise         -> True
+
+    args' = map (CmmReg . CmmLocal) args
+    setN = case nodeSet of
+                   Just n  -> mkAssign nodeReg (CmmReg $ CmmLocal n)
+                   Nothing -> mkAssign nodeReg $
+                       CmmLit (CmmLabel $ closureLabelFromCI cl_info)
+
+    {- Thunks:          Set R1 = node, jump GCEnter1
+       Function (fast): Set R1 = node, jump GCFun
+       Function (slow): Set R1 = node, call generic_gc -}
+    gc_call upd = setN <*> gc_lbl upd
+    gc_lbl upd
+        | is_thunk  = mkDirectJump (CmmReg $ CmmGlobal GCEnter1) [] sp
+        | is_fastf  = mkDirectJump (CmmReg $ CmmGlobal GCFun) [] sp
+        | otherwise = mkForeignJump Slow (CmmReg $ CmmGlobal GCFun) args' upd
+        where sp = max offset upd
+    {- DT (12/08/10) This is a little fishy, mainly the sp fix up amount.
+     - This is since the ncg inserts spills before the stack/heap check.
+     - This should be fixed up and then we won't need to fix up the Sp on
+     - GC calls, but until then this fishy code works -}
+
+{-
+    -- This code is slightly outdated now and we could easily keep the above
+    -- GC methods. However, there may be some performance gains to be made by
+    -- using more specialised GC entry points. Since the semi generic GCFun
+    -- entry needs to check the node and figure out what registers to save...
+    -- if we provided and used more specialised GC entry points then these
+    -- runtime decisions could be turned into compile time decisions.
+
     args'     = case fun of Just f  -> f : args
                             Nothing -> args
     arg_exprs = map (CmmReg . CmmLocal) args'
     gc_call updfr_sz
         | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz
-        | otherwise  = case gc_lbl args' of
-                         Just _lbl -> panic "StgCmmHeap.entryHeapCheck: gc_lbl not finished"
-				     -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
-                                     --         arg_exprs updfr_sz
-                         Nothing  -> mkCall generic_gc (GC, GC) [] [] updfr_sz
+        | otherwise =
+            case gc_lbl args' of
+                Just _lbl -> panic "StgCmmHeap.entryHeapCheck: not finished"
+                            -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
+                            --         arg_exprs updfr_sz
+                Nothing  -> mkCall generic_gc (GC, GC) [] [] updfr_sz
 
     gc_lbl :: [LocalReg] -> Maybe FastString
-{-
     gc_lbl [reg]
-	| isGcPtrType ty  = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
-	| isFloatType ty  = case width of
-			      W32 -> Just (sLit "stg_gc_f1") -- "stg_gc_fun_f1"
-			      W64 -> Just (sLit "stg_gc_d1") -- "stg_gc_fun_d1"
-			      _other -> Nothing
-	| otherwise	  = case width of
-			      W32 -> Just (sLit "stg_gc_unbx_r1") -- "stg_gc_fun_unbx_r1"
-			      W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1"
-			      _other -> Nothing	-- Narrow cases
-	where
-	  ty = localRegType reg
-	  width = typeWidth ty
--}
+        | isGcPtrType ty  = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
+        | isFloatType ty  = case width of
+                              W32 -> Just (sLit "stg_gc_f1")
+                              W64 -> Just (sLit "stg_gc_d1")
+                              _other -> Nothing
+        | width == wordWidth = Just (mkGcLabel "stg_gc_unbx_r1")
+        | width == W64       = Just (mkGcLabel "stg_gc_l1")
+        | otherwise          = Nothing
+        where
+          ty = localRegType reg
+          width = typeWidth ty
 
     gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs)
 
     gc_lbl_ptrs :: [Bool] -> Maybe FastString
-    -- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
+    -- JD: TEMPORARY -- UNTIL THESE FUNCTIONS EXIST...
     --gc_lbl_ptrs [True,True]      = Just (sLit "stg_gc_fun_2p")
     --gc_lbl_ptrs [True,True,True] = Just (sLit "stg_gc_fun_3p")
     gc_lbl_ptrs _ = Nothing
-    			
+-}
+
+
+--------------------------------------------------------------
+-- A heap/stack check at in a case alternative
 
 altHeapCheck :: [LocalReg] -> FCode a -> FCode a
 altHeapCheck regs code
   = do updfr_sz <- getUpdFrameOff
        heapCheck False (gc_call updfr_sz) code
-  where
-    gc_call updfr_sz
-	| null regs = mkCall generic_gc (GC, GC) [] [] updfr_sz
 
-	| Just _gc_lbl <- rts_label regs	-- Canned call
-	= panic "StgCmmHeap.altHeapCheck: rts_label not finished"
-		-- mkCall    (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC)
-		--	    regs (map (CmmReg . CmmLocal) regs) updfr_sz
-	| otherwise		-- No canned call, and non-empty live vars
-	= mkCall generic_gc (GC, GC) [] [] updfr_sz
-
-{-
-    rts_label [reg] 
-	| isGcPtrType ty  = Just (sLit "stg_gc_unpt_r1")
-	| isFloatType ty  = case width of
-			      W32 -> Just (sLit "stg_gc_f1")
-			      W64 -> Just (sLit "stg_gc_d1")
-			      _other -> Nothing
-	| otherwise	  = case width of
-			      W32 -> Just (sLit "stg_gc_unbx_r1")
-			      W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1"
-			      _other -> Nothing	-- Narrow cases
-	where
-	  ty = localRegType reg
-	  width = typeWidth ty
--}
+  where
+    reg_exprs = map (CmmReg . CmmLocal) regs
+
+    gc_call sp =
+        case rts_label regs of
+             Just gc -> mkCall (CmmLit gc) (GC, GC) regs reg_exprs sp
+             Nothing -> mkCall generic_gc (GC, GC) [] [] sp
+
+    rts_label [reg]
+        | isGcPtrType ty = Just (mkGcLabel "stg_gc_unpt_r1")
+        | isFloatType ty = case width of
+                                W32       -> Just (mkGcLabel "stg_gc_f1")
+                                W64       -> Just (mkGcLabel "stg_gc_d1")
+                                _         -> Nothing
+
+        | width == wordWidth = Just (mkGcLabel "stg_gc_unbx_r1")
+        | width == W64       = Just (mkGcLabel "stg_gc_l1")
+        | otherwise          = Nothing
+        where
+            ty = localRegType reg
+            width = typeWidth ty
 
     rts_label _ = Nothing
 
 
-generic_gc :: CmmExpr	-- The generic GC procedure; no params, no resuls
-generic_gc = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs")))
--- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
--- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))
+-- | The generic GC procedure; no params, no results
+generic_gc :: CmmExpr
+generic_gc = CmmLit $ mkGcLabel "stg_gc_noregs"
+
+-- | Create a CLabel for calling a garbage collector entry point
+mkGcLabel :: String -> CmmLit
+mkGcLabel = (CmmLabel . (mkCmmCodeLabel rtsPackageId) . fsLit)
 
 -------------------------------
 heapCheck :: Bool -> CmmAGraph -> FCode a -> FCode a
 heapCheck checkStack do_gc code
   = getHeapUsage $ \ hpHw ->
-    do	{ emit $ do_checks checkStack hpHw do_gc
-	     	-- Emit heap checks, but be sure to do it lazily so 
-		-- that the conditionals on hpHw don't cause a black hole
-	; tickyAllocHeap hpHw
-	; doGranAllocate hpHw
-	; setRealHp hpHw
-	; code }
+    -- Emit heap checks, but be sure to do it lazily so
+    -- that the conditionals on hpHw don't cause a black hole
+    do  { emit $ do_checks checkStack hpHw do_gc
+        ; tickyAllocHeap hpHw
+        ; doGranAllocate hpHw
+        ; setRealHp hpHw
+        ; code }
 
 do_checks :: Bool       -- Should we check the stack?
-          -> WordOff	-- Heap headroom
-          -> CmmAGraph	-- What to do on failure
+          -> WordOff    -- Heap headroom
+          -> CmmAGraph  -- What to do on failure
           -> CmmAGraph
 do_checks checkStack alloc do_gc
   = withFreshLabel "gc" $ \ loop_id ->
     withFreshLabel "gc" $ \ gc_id   ->
-      mkLabel loop_id 
+      mkLabel loop_id
       <*> (let hpCheck = if alloc == 0 then mkNop
                          else mkAssign hpReg bump_hp <*>
-                              mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
-           in if checkStack then
-                mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
-              else hpCheck)
+                              mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
+           in if checkStack
+                 then mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
+                 else hpCheck)
       <*> mkComment (mkFastString "outOfLine should follow:")
-      <*> outOfLine (mkLabel gc_id 
+      <*> outOfLine (mkLabel gc_id
                      <*> mkComment (mkFastString "outOfLine here")
                      <*> do_gc
                      <*> mkBranch loop_id)
-		-- Test for stack pointer exhaustion, then
-		-- bump heap pointer, and test for heap exhaustion
-		-- Note that we don't move the heap pointer unless the 
-		-- stack check succeeds.  Otherwise we might end up
-		-- with slop at the end of the current block, which can 
-		-- confuse the LDV profiler.
+                -- Test for stack pointer exhaustion, then
+                -- bump heap pointer, and test for heap exhaustion
+                -- Note that we don't move the heap pointer unless the
+                -- stack check succeeds.  Otherwise we might end up
+                -- with slop at the end of the current block, which can
+                -- confuse the LDV profiler.
   where
-    alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE))	-- Bytes
+    alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE)) -- Bytes
     bump_hp   = cmmOffsetExprB (CmmReg hpReg) alloc_lit
 
-	-- Sp overflow if (Sp - CmmHighStack < SpLim)
-    sp_oflo = CmmMachOp mo_wordULt 
-		  [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg)))
+    -- Sp overflow if (Sp - CmmHighStack < SpLim)
+    sp_oflo = CmmMachOp mo_wordULt
+                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg)))
                              [CmmReg spReg, CmmLit CmmHighStackMark],
                    CmmReg spLimReg]
-	-- Hp overflow if (Hp > HpLim)
-	-- (Hp has been incremented by now)
-	-- HpLim points to the LAST WORD of valid allocation space.
-    hp_oflo = CmmMachOp mo_wordUGt 
-		  [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
 
-    save_alloc = mkAssign (CmmGlobal HpAlloc) alloc_lit
+    -- Hp overflow if (Hp > HpLim)
+    -- (Hp has been incremented by now)
+    -- HpLim points to the LAST WORD of valid allocation space.
+    hp_oflo = CmmMachOp mo_wordUGt
+                  [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
+
+    alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
 
 {-
 
@@ -483,34 +531,34 @@ which will be in registers, and the others will be on the stack.  We
 always organise the stack-resident fields into pointers &
 non-pointers, and pass the number of each to the heap check code. -}
 
-unbxTupleHeapCheck 
-	:: [(Id, GlobalReg)]	-- Live registers
-	-> WordOff	-- no. of stack slots containing ptrs
-	-> WordOff	-- no. of stack slots containing nonptrs
-	-> CmmAGraph	-- code to insert in the failure path
-	-> FCode ()
-	-> FCode ()
+unbxTupleHeapCheck
+        :: [(Id, GlobalReg)]    -- Live registers
+        -> WordOff      -- no. of stack slots containing ptrs
+        -> WordOff      -- no. of stack slots containing nonptrs
+        -> CmmAGraph    -- code to insert in the failure path
+        -> FCode ()
+        -> FCode ()
 
 unbxTupleHeapCheck regs ptrs nptrs fail_code code
-  -- We can't manage more than 255 pointers/non-pointers 
+  -- We can't manage more than 255 pointers/non-pointers
   -- in a generic heap check.
   | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
-  | otherwise 
+  | otherwise
   = initHeapUsage $ \ hpHw -> do
-	{ codeOnly $ do { do_checks 0 {- no stack check -} hpHw
-				    full_fail_code rts_label
-			; tickyAllocHeap hpHw }
-	; setRealHp hpHw
-	; code }
+        { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
+                                    full_fail_code rts_label
+                        ; tickyAllocHeap hpHw }
+        ; setRealHp hpHw
+        ; code }
   where
     full_fail_code  = fail_code `plusStmts` oneStmt assign_liveness
-    assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) 	-- Ho ho ho!
-				(CmmLit (mkWordCLit liveness))
-    liveness 	    = mkRegLiveness regs ptrs nptrs
-    rts_label	    = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut")))
+    assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9))      -- Ho ho ho!
+                                (CmmLit (mkWordCLit liveness))
+    liveness        = mkRegLiveness regs ptrs nptrs
+    rts_label       = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut")))
 
 
-{- Old Gransim comment -- I have no idea whether it still makes sense (SLPJ Sep07)
+{- Old Gransim com -- I have no idea whether it still makes sense (SLPJ Sep07)
 For GrAnSim the code for doing a heap check and doing a context switch
 has been separated. Especially, the HEAP_CHK macro only performs a
 heap check. THREAD_CONTEXT_SWITCH should be used for doing a context
@@ -530,9 +578,9 @@ again on re-entry because someone else might have stolen the resource
 in the meantime.
 
 %************************************************************************
-%*									*
+%*                                                                      *
      Generic Heap/Stack Checks - used in the RTS
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -541,9 +589,9 @@ hpChkGen bytes liveness reentry
   = do_checks' bytes True assigns stg_gc_gen
   where
     assigns = mkStmts [
-    		CmmAssign (CmmGlobal (VanillaReg 9))  liveness,
-    		CmmAssign (CmmGlobal (VanillaReg 10)) reentry
-		]
+                CmmAssign (CmmGlobal (VanillaReg 9))  liveness,
+                CmmAssign (CmmGlobal (VanillaReg 10)) reentry
+                ]
 
 -- a heap check where R1 points to the closure to enter on return, and
 -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs
index e39a1013e3..a93af34961 100644
--- a/compiler/codeGen/StgCmmHpc.hs
+++ b/compiler/codeGen/StgCmmHpc.hs
@@ -12,8 +12,9 @@ import StgCmmUtils
 import StgCmmMonad
 import StgCmmForeign
 
-import MkZipCfgCmm
-import Cmm
+import MkGraph
+import CmmDecl
+import CmmExpr
 import CLabel
 import Module
 import CmmUtils
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 21e55ee074..eddf257e5f 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -6,13 +6,6 @@
 --
 -----------------------------------------------------------------------------
 
-{-# OPTIONS  #-}
--- 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
-
 module StgCmmLayout (
 	mkArgDescr, 
 	emitCall, emitReturn,
@@ -42,10 +35,11 @@ import StgCmmTicky
 import StgCmmUtils
 import StgCmmMonad
 
-import MkZipCfgCmm
+import MkGraph
 import SMRep
+import CmmDecl
+import CmmExpr
 import CmmUtils
-import Cmm
 import CLabel
 import StgSyn
 import DataCon
@@ -462,7 +456,7 @@ emitClosureProcAndInfoTable :: Bool                    -- top-level?
                             -> Id                      -- name of the closure
                             -> ClosureInfo             -- lots of info abt the closure
                             -> [NonVoid Id]            -- incoming arguments
-                            -> ((LocalReg, [LocalReg]) -> FCode ()) -- function body
+                            -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
                             -> FCode ()
 emitClosureProcAndInfoTable top_lvl bndr cl_info args body
  = do	{ let lf_info = closureLFInfo cl_info
@@ -474,9 +468,10 @@ emitClosureProcAndInfoTable top_lvl bndr cl_info args body
         ; let node_points = nodeMustPointToIt lf_info
         ; arg_regs <- bindArgsToRegs args
         ; let args' = if node_points then (node : arg_regs) else arg_regs
-              conv = if nodeMustPointToIt lf_info
-                     then NativeNodeCall else NativeDirectCall
-        ; emitClosureAndInfoTable cl_info conv args' $ body (node, arg_regs)
+              conv  = if nodeMustPointToIt lf_info then NativeNodeCall
+                                                   else NativeDirectCall
+              (offset, _) = mkCallEntry conv args'
+        ; emitClosureAndInfoTable cl_info conv args' $ body (offset, node, arg_regs)
         }
 
 -- Data constructors need closures, but not with all the argument handling
@@ -491,9 +486,9 @@ emitClosureAndInfoTable cl_info conv args body
   where
     info_lbl = infoTableLabelFromCI cl_info
 
--- Convert from 'ClosureInfo' to 'CmmInfo'.
+-- Convert from 'ClosureInfo' to 'CmmInfoTable'.
 -- Not used for return points.  (The 'smRepClosureTypeInt' call would panic.)
-mkCmmInfo :: ClosureInfo -> FCode CmmInfo
+mkCmmInfo :: ClosureInfo -> FCode CmmInfoTable
 mkCmmInfo cl_info
   = do	{ info <- closureTypeInfo cl_info k_with_con_name return 
         ; prof <- if opt_SccProfilingOn then
@@ -501,25 +496,13 @@ mkCmmInfo cl_info
 	               ad_lit <- mkStringCLit (closureValDescr  cl_info)
 	               return $ ProfilingInfo fd_lit ad_lit
                   else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
-	; return (CmmInfo gc_target Nothing
-                   (CmmInfoTable (isStaticClosure cl_info) prof cl_type info)) }
+	; return (CmmInfoTable (isStaticClosure cl_info) prof cl_type info) }
   where
     k_with_con_name con_info con info_lbl =
       do cstr <- mkByteStringCLit $ dataConIdentity con
          return $ con_info $ makeRelativeRefTo info_lbl cstr
     cl_type  = smRepClosureTypeInt (closureSMRep cl_info)
 
-    -- The gc_target is to inform the CPS pass when it inserts a stack check.
-    -- Since that pass isn't used yet we'll punt for now.
-    -- When the CPS pass is fully integrated, this should
-    -- be replaced by the label that any heap check jumped to,
-    -- so that branch can be shared by both the heap (from codeGen)
-    -- and stack checks (from the CPS pass).
-    -- JD: Actually, we've decided to go a different route here:
-    --     the code generator is now responsible for producing the
-    --     stack limit check explicitly, so this field is now obsolete.
-    gc_target = Nothing
-
 -----------------------------------------------------------------------------
 --
 --	Info table offsets
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 72f9cec393..919a5d0eee 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -51,10 +51,11 @@ module StgCmmMonad (
 
 import StgCmmClosure
 import DynFlags
-import MkZipCfgCmm
-import ZipCfgCmmRep (UpdFrameOffset)
+import MkGraph
 import BlockId
-import Cmm
+import CmmDecl
+import CmmExpr
+import CmmNode (UpdFrameOffset)
 import CLabel
 import TyCon	( PrimRep )
 import SMRep
@@ -243,7 +244,7 @@ data CgState
   = MkCgState {
      cgs_stmts :: CmmAGraph,	  -- Current procedure
 
-     cgs_tops  :: OrdList CmmTopZ,
+     cgs_tops  :: OrdList CmmTop,
 	-- Other procedures and data blocks in this compilation unit
 	-- Both are ordered only so that we can 
 	-- reduce forward references, when it's easy to do so
@@ -599,25 +600,25 @@ emitData sect lits
   where
     data_block = CmmData sect lits
 
-emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals ->
+emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> CmmFormals ->
                           CmmAGraph -> FCode ()
 emitProcWithConvention conv info lbl args blocks
   = do  { us <- newUniqSupply
-        ; let (uniq, us') = takeUniqFromSupply us
-              (offset, entry) = mkEntry (mkBlockId uniq) conv args
-              blks = initUs_ us' $ lgraphOfAGraph $ entry <*> blocks
-        ; let proc_block = CmmProc info lbl args ((offset, Just initUpdFrameOff), blks)
+        ; let (offset, entry) = mkCallEntry conv args
+              blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
+        ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff}
+              proc_block = CmmProc (TopInfo {info_tbl=info, stack_info=sinfo}) lbl blks
         ; state <- getState
         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 
-emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
+emitProc :: CmmInfoTable -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
 emitProc = emitProcWithConvention NativeNodeCall
 
 emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
 emitSimpleProc lbl code = 
-  emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code
+  emitProc CmmNonInfoTable lbl [] code
 
-getCmm :: FCode () -> FCode CmmZ
+getCmm :: FCode () -> FCode Cmm
 -- Get all the CmmTops (there should be no stmts)
 -- Return a single Cmm which may be split from other Cmms by
 -- object splitting (at a later stage)
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 1c1fab1ba6..8f688f023c 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -18,9 +18,10 @@ import StgCmmEnv
 import StgCmmMonad
 import StgCmmUtils
 
-import MkZipCfgCmm
+import MkGraph
 import StgSyn
-import Cmm
+import CmmDecl
+import CmmExpr
 import Type	( Type, tyConAppTyCon )
 import TyCon
 import CLabel
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index 944729f287..36d05acf90 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -38,8 +38,9 @@ import StgCmmUtils
 import StgCmmMonad
 import SMRep
 
-import MkZipCfgCmm
-import Cmm
+import MkGraph
+import CmmExpr
+import CmmDecl
 import CmmUtils
 import CLabel
 
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 3fa579b80c..e8642eb4e6 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -48,8 +48,8 @@ import StgCmmMonad
 import SMRep
 
 import StgSyn
-import Cmm
-import MkZipCfgCmm
+import CmmExpr
+import MkGraph
 import CmmUtils
 import CLabel
 
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 4b1446a7e2..48416e3f69 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -20,7 +20,7 @@ module StgCmmUtils (
 
 	tagToClosure, mkTaggedObjectLoad,
 
-        callerSaveVolatileRegs, get_GlobalReg_addr,
+        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
 
 	cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
         cmmUGtWord,
@@ -49,11 +49,11 @@ module StgCmmUtils (
 import StgCmmMonad
 import StgCmmClosure
 import BlockId
-import Cmm hiding (regUsedIn)
-import MkZipCfgCmm
+import CmmDecl
+import CmmExpr hiding (regUsedIn)
+import MkGraph
 import CLabel
 import CmmUtils
-import PprCmm		( {- instances -} )
 
 import ForeignCall
 import IdInfo