Remove uses of fixC from the codeGen, and make the FCode monad strict

6 files changed, 222 insertions, 204 deletions

diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index d8127ab737..305c731ddf 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -124,25 +124,24 @@ variable. -}
 cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode ()
 cgTopBinding dflags (StgNonRec id rhs, _srts)
   = do	{ id' <- maybeExternaliseId dflags id
-	; info <- cgTopRhs id' rhs
-	; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
+        ; (info, fcode) <- cgTopRhs id' rhs
+        ; fcode
+        ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
 				     -- so we find it when we look up occurrences
         }
 
 cgTopBinding dflags (StgRec pairs, _srts)
   = do	{ let (bndrs, rhss) = unzip pairs
-	; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
+        ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs
 	; let pairs' = zip bndrs' rhss
-	; fixC_(\ new_binds -> do 
-		{ addBindsC new_binds
-		; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
-        ; return () }
+        ; r <- sequence $ unzipWith cgTopRhs pairs'
+        ; let (infos, fcodes) = unzip r
+        ; addBindsC infos
+        ; sequence_ fcodes
+        }
 
--- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
--- to enclose the listFCs in cgTopBinding, but that tickled the
--- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 
-cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo
+cgTopRhs :: Id -> StgRhs -> FCode (CgIdInfo, FCode ())
 	-- The Id is passed along for setting up a binding...
 	-- It's already been externalised if necessary
 
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 5aec9e3bbe..0e78eaf1fa 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -69,32 +69,37 @@ cgTopRhsClosure :: Id
 		-> UpdateFlag
                 -> [Id]                 -- Args
 		-> StgExpr
-		-> FCode CgIdInfo
-
-cgTopRhsClosure id ccs _ upd_flag args body = do
-  {	-- LAY OUT THE OBJECT
-    let name = idName id
-  ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
-  ; mod_name <- getModuleName
-  ; dflags   <- getDynFlags
-  ; let descr         = closureDescription dflags mod_name name
-        closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr
-        closure_label = mkLocalClosureLabel name (idCafInfo id)
-    	cg_id_info    = litIdInfo id lf_info (CmmLabel closure_label)
-        caffy         = idCafInfo id
-        info_tbl      = mkCmmInfo closure_info -- XXX short-cut
-        closure_rep   = mkStaticClosureFields dflags info_tbl ccs caffy []
-
-  	 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
-  ; emitDataLits closure_label closure_rep
-  ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
-	(_, _, fv_details) = mkVirtHeapOffsets dflags (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
-                                     (nonVoidIds args) (length args) body fv_details)
-
-  ; returnFC cg_id_info }
+                -> FCode (CgIdInfo, FCode ())
+
+cgTopRhsClosure id ccs _ upd_flag args body
+ = do { lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
+      ; let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
+            cg_id_info = litIdInfo id lf_info (CmmLabel closure_label)
+      ; return (cg_id_info, gen_code lf_info closure_label)
+      }
+  where
+  gen_code lf_info closure_label
+   = do {     -- LAY OUT THE OBJECT
+          let name = idName id
+        ; mod_name <- getModuleName
+        ; dflags   <- getDynFlags
+        ; let descr         = closureDescription dflags mod_name name
+              closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr
+
+              caffy         = idCafInfo id
+              info_tbl      = mkCmmInfo closure_info -- XXX short-cut
+              closure_rep   = mkStaticClosureFields dflags info_tbl ccs caffy []
+      
+        	 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
+        ; emitDataLits closure_label closure_rep
+        ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
+              (_, _, fv_details) = mkVirtHeapOffsets dflags (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
+                                (nonVoidIds args) (length args) body fv_details)
+      
+        ; return () }
 
 ------------------------------------------------------------------------
 --		Non-top-level bindings
@@ -102,25 +107,30 @@ cgTopRhsClosure id ccs _ upd_flag args body = do
 
 cgBind :: StgBinding -> FCode ()
 cgBind (StgNonRec name rhs)
-  = do	{ ((info, init), body) <- getCodeR $ cgRhs name rhs
+  = do  { (info, fcode) <- cgRhs name rhs
         ; addBindC (cg_id info) info
-        ; emit (body <*> init) }
+        ; init <- fcode
+        ; emit init
+        }
         -- init cannot be used in body, so slightly better to sink it eagerly
 
 cgBind (StgRec pairs)
-  = 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
-       ; emit (catAGraphs inits <*> body) }
+  = do  {  r <- sequence $ unzipWith cgRhs pairs
+        ;  let (id_infos, fcodes) = unzip r
+        ;  addBindsC id_infos
+        ;  (inits, body) <- getCodeR $ sequence fcodes
+        ;  emit (catAGraphs inits <*> body) }
 
 {- Note [cgBind rec]
+
    Recursive let-bindings are tricky.
    Consider the following pseudocode:
+
      let x = \_ ->  ... y ...
          y = \_ ->  ... z ...
          z = \_ ->  ... x ...
      in ...
+
    For each binding, we need to allocate a closure, and each closure must
    capture the address of the other closures.
    We want to generate the following C-- code:
@@ -139,24 +149,40 @@ cgBind (StgRec pairs)
      ...
 
    For each closure, we must generate not only the code to allocate and
-   initialize the closure itself, but also some Initialization Code that
+   initialize the closure itself, but also some initialization Code that
    sets a variable holding the closure pointer.
-   The complication here is that we don't know the heap offsets a priori,
-   which has two consequences:
-     1. we need a fixpoint
-     2. we can't trivially separate the Initialization Code from the
-        code that compiles the right-hand-sides
-
-   Note: We don't need this complication with let-no-escapes, because
-   in that case, the names are bound to labels in the environment,
-   and we don't need to emit any code to witness that binding.
--}
 
---------------------
-cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
-   -- The Id is passed along so a binding can be set up
-   -- The returned values are the binding for the environment
-   -- and the Initialization Code that witnesses the binding
+   We could generate a pair of the (init code, body code), but since
+   the bindings are recursive we also have to initialise the
+   environment with the CgIdInfo for all the bindings before compiling
+   anything.  So we do this in 3 stages:
+
+     1. collect all the CgIdInfos and initialise the environment
+     2. compile each binding into (init, body) code
+     3. emit all the inits, and then all the bodies
+
+   We'd rather not have separate functions to do steps 1 and 2 for
+   each binding, since in pratice they share a lot of code.  So we
+   have just one function, cgRhs, that returns a pair of the CgIdInfo
+   for step 1, and a monadic computation to generate the code in step
+   2.
+
+   The alternative to separating things in this way is to use a
+   fixpoint.  That's what we used to do, but it introduces a
+   maintenance nightmare because there is a subtle dependency on not
+   being too strict everywhere.  Doing things this way means that the
+   FCode monad can be strict, for example.
+ -}
+
+cgRhs :: Id
+      -> StgRhs
+      -> FCode (
+                 CgIdInfo         -- The info for this binding
+               , FCode CmmAGraph  -- A computation which will generate the
+                                  -- code for the binding, and return an
+                                  -- assignent of the form "x = Hp - n"
+                                  -- (see above)
+               )
 
 cgRhs name (StgRhsCon cc con args)
   = buildDynCon name cc con args
@@ -174,7 +200,7 @@ mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo
              -> UpdateFlag
 	     -> [Id]			        -- Args
 	     -> StgExpr
-	     -> FCode (CgIdInfo, CmmAGraph)
+             -> FCode (CgIdInfo, FCode CmmAGraph)
 
 {- mkRhsClosure looks for two special forms of the right-hand side:
 	a) selector thunks
@@ -212,11 +238,11 @@ for semi-obvious reasons.
 -}
 
 ---------- Note [Selectors] ------------------
-mkRhsClosure	dflags bndr cc bi
+mkRhsClosure    dflags bndr _cc _bi
 		[NonVoid the_fv]   		-- Just one free var
 		upd_flag		-- Updatable thunk
                 []                      -- A thunk
-		body@(StgCase (StgApp scrutinee [{-no args-}])
+                (StgCase (StgApp scrutinee [{-no args-}])
 		      _ _ _ _   -- ignore uniq, etc.
 		      (AlgAlt _)
 		      [(DataAlt _, params, _use_mask,
@@ -232,7 +258,7 @@ mkRhsClosure	dflags bndr cc bi
     -- will evaluate to.
     --
     -- srt is discarded; it must be empty
-    cgStdThunk bndr cc bi body lf_info [StgVarArg the_fv]
+    cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
   where
     lf_info 		  = mkSelectorLFInfo bndr offset_into_int
 				 (isUpdatable upd_flag)
@@ -243,11 +269,11 @@ mkRhsClosure	dflags bndr cc bi
     offset_into_int       = the_offset - fixedHdrSize dflags
 
 ---------- Note [Ap thunks] ------------------
-mkRhsClosure    dflags bndr cc bi
+mkRhsClosure    dflags bndr _cc _bi
 		fvs
 		upd_flag
                 []                      -- No args; a thunk
-		body@(StgApp fun_id args)
+                (StgApp fun_id args)
 
   | args `lengthIs` (arity-1)
  	&& all (isGcPtrRep . idPrimRep . stripNV) fvs
@@ -259,7 +285,8 @@ mkRhsClosure    dflags bndr cc bi
                                   -- thunk (e.g. its type) (#949)
 
                    -- Ha! an Ap thunk
-  = cgStdThunk bndr cc bi body lf_info payload
+  = cgRhsStdThunk bndr lf_info payload
+
   where
 	lf_info = mkApLFInfo bndr upd_flag arity
 	-- the payload has to be in the correct order, hence we can't
@@ -269,7 +296,12 @@ mkRhsClosure    dflags bndr cc bi
 
 ---------- Default case ------------------
 mkRhsClosure _ bndr cc _ fvs upd_flag args body
-  = do	{ 	-- LAY OUT THE OBJECT
+  = do  { lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
+        ; (id_info, reg) <- rhsIdInfo bndr lf_info
+        ; return (id_info, gen_code lf_info reg) }
+ where
+ gen_code lf_info reg
+  = do  {       -- LAY OUT THE OBJECT
 	-- If the binder is itself a free variable, then don't store
 	-- it in the closure.  Instead, just bind it to Node on entry.
 	-- NB we can be sure that Node will point to it, because we
@@ -285,8 +317,7 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body
 
 
 	-- MAKE CLOSURE INFO FOR THIS CLOSURE
-	; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
-	; mod_name <- getModuleName
+        ; mod_name <- getModuleName
         ; dflags <- getDynFlags
         ; let   name  = idName bndr
                 descr = closureDescription dflags mod_name name
@@ -316,23 +347,26 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body
                                          (map toVarArg fv_details)
 
 	-- RETURN
-        ; regIdInfo bndr lf_info hp_plus_n }
+        ; return (mkRhsInit reg lf_info hp_plus_n) }
+
 
 -- Use with care; if used inappropriately, it could break invariants.
 stripNV :: NonVoid a -> a
 stripNV (NonVoid a) = a
 
 -------------------------
-cgStdThunk
-	:: Id
-	-> CostCentreStack	-- Optional cost centre annotation
-	-> StgBinderInfo	-- XXX: not used??
-	-> StgExpr
-	-> LambdaFormInfo
-	-> [StgArg]			-- payload
-	-> FCode (CgIdInfo, CmmAGraph)
-
-cgStdThunk bndr _cc _bndr_info _body lf_info payload
+cgRhsStdThunk
+        :: Id
+        -> LambdaFormInfo
+        -> [StgArg]             -- payload
+        -> FCode (CgIdInfo, FCode CmmAGraph)
+
+cgRhsStdThunk bndr lf_info payload
+ = do  { (id_info, reg) <- rhsIdInfo bndr lf_info
+       ; return (id_info, gen_code reg)
+       }
+ where
+ gen_code reg
   = do	-- AHA!  A STANDARD-FORM THUNK
   {	-- LAY OUT THE OBJECT
     mod_name <- getModuleName
@@ -354,7 +388,8 @@ cgStdThunk bndr _cc _bndr_info _body lf_info payload
                                    use_cc blame_cc payload_w_offsets
 
 	-- RETURN
-  ; regIdInfo bndr lf_info hp_plus_n }
+  ; return (mkRhsInit reg lf_info hp_plus_n) }
+
 
 mkClosureLFInfo :: Id		-- The binder
 		-> TopLevelFlag	-- True of top level
@@ -364,8 +399,9 @@ mkClosureLFInfo :: Id		-- The binder
 		-> FCode LambdaFormInfo
 mkClosureLFInfo bndr top fvs upd_flag args
   | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
-  | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
-		   ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
+  | otherwise =
+      do { arg_descr <- mkArgDescr (idName bndr) args
+         ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
 
 
 ------------------------------------------------------------------------
@@ -451,7 +487,7 @@ bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff)
 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
 
 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
-load_fvs node lf_info = mapCs (\ (reg, off) ->
+load_fvs node lf_info = mapM_ (\ (reg, off) ->
       emit $ mkTaggedObjectLoad reg node off tag)
   where tag = lfDynTag lf_info
 
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index 23226bb45e..083e615b78 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -54,10 +54,18 @@ import Data.Char
 cgTopRhsCon :: Id               -- Name of thing bound to this RHS
             -> DataCon          -- Id
             -> [StgArg]         -- Args
-            -> FCode CgIdInfo
+            -> FCode (CgIdInfo, FCode ())
 cgTopRhsCon id con args
-  = do {
-          dflags <- getDynFlags
+  = return ( id_info, gen_code )
+  where
+   name          = idName id
+   caffy         = idCafInfo id -- any stgArgHasCafRefs args
+   closure_label = mkClosureLabel name caffy
+
+   id_info = litIdInfo id (mkConLFInfo con) (CmmLabel closure_label)
+
+   gen_code =
+     do { dflags <- getDynFlags
         ; when (platformOS (targetPlatform dflags) == OSMinGW32) $
               -- Windows DLLs have a problem with static cross-DLL refs.
               ASSERT( not (isDllConApp dflags con args) ) return ()
@@ -65,10 +73,6 @@ cgTopRhsCon id con args
 
         -- LAY IT OUT
         ; let
-            name          = idName id
-            caffy         = idCafInfo id -- any stgArgHasCafRefs args
-            closure_label = mkClosureLabel name caffy
-
             (tot_wds, --  #ptr_wds + #nonptr_wds
              ptr_wds, --  #ptr_wds
              nv_args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args)
@@ -97,8 +101,7 @@ cgTopRhsCon id con args
                 -- BUILD THE OBJECT
         ; emitDataLits closure_label closure_rep
 
-                -- RETURN
-        ; return $ litIdInfo id (mkConLFInfo con) (CmmLabel closure_label) }
+        ; return () }
 
 
 ---------------------------------------------------------------
@@ -111,7 +114,7 @@ buildDynCon :: Id                 -- Name of the thing to which this constr will
                                   -- current CCS if currentOrSubsumedCCS
             -> DataCon            -- The data constructor
             -> [StgArg]           -- Its args
-            -> FCode (CgIdInfo, CmmAGraph)
+            -> FCode (CgIdInfo, FCode CmmAGraph)
                -- Return details about how to find it and initialization code
 buildDynCon binder cc con args
     = do dflags <- getDynFlags
@@ -123,7 +126,7 @@ buildDynCon' :: DynFlags
              -> CostCentreStack
              -> DataCon
              -> [StgArg]
-             -> FCode (CgIdInfo, CmmAGraph)
+             -> FCode (CgIdInfo, FCode CmmAGraph)
 
 {- We used to pass a boolean indicating whether all the
 args were of size zero, so we could use a static
@@ -149,7 +152,7 @@ premature looking at the args will cause the compiler to black-hole!
 buildDynCon' _ _ binder _cc con []
   = return (litIdInfo binder (mkConLFInfo con)
                 (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
-            mkNop)
+            return mkNop)
 
 -------- buildDynCon': Charlike and Intlike constructors -----------
 {- The following three paragraphs about @Char@-like and @Int@-like
@@ -188,7 +191,8 @@ buildDynCon' dflags platform binder _cc con [arg]
               offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize dflags + 1)
                 -- INTLIKE closures consist of a header and one word payload
               intlike_amode = cmmLabelOffW intlike_lbl offsetW
-        ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) }
+        ; return ( litIdInfo binder (mkConLFInfo con) intlike_amode
+                 , return mkNop) }
 
 buildDynCon' dflags platform binder _cc con [arg]
   | maybeCharLikeCon con
@@ -201,26 +205,33 @@ buildDynCon' dflags platform binder _cc con [arg]
               offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize dflags + 1)
                 -- CHARLIKE closures consist of a header and one word payload
               charlike_amode = cmmLabelOffW charlike_lbl offsetW
-        ; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) }
+        ; return ( litIdInfo binder (mkConLFInfo con) charlike_amode
+                 , return mkNop) }
 
 -------- buildDynCon': the general case -----------
 buildDynCon' dflags _ binder ccs con args
-  = do  { let (tot_wds, ptr_wds, args_w_offsets)
-                = mkVirtConstrOffsets dflags (addArgReps args)
-                -- No void args in args_w_offsets
-              nonptr_wds = tot_wds - ptr_wds
-              info_tbl = mkDataConInfoTable dflags con False ptr_wds nonptr_wds
-        ; hp_plus_n <- allocDynClosure info_tbl lf_info
-                                         use_cc blame_cc args_w_offsets
-        ; regIdInfo binder lf_info hp_plus_n }
-  where
-    lf_info = mkConLFInfo con
-
-    use_cc      -- cost-centre to stick in the object
-      | isCurrentCCS ccs = curCCS
-      | otherwise        = panic "buildDynCon: non-current CCS not implemented"
-
-    blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
+  = do  { (id_info, reg) <- rhsIdInfo binder lf_info
+        ; return (id_info, gen_code reg)
+        }
+ where
+  lf_info = mkConLFInfo con
+
+  gen_code reg
+    = do  { let (tot_wds, ptr_wds, args_w_offsets)
+                  = mkVirtConstrOffsets dflags (addArgReps args)
+                  -- No void args in args_w_offsets
+                nonptr_wds = tot_wds - ptr_wds
+                info_tbl = mkDataConInfoTable dflags con False
+                                ptr_wds nonptr_wds
+          ; hp_plus_n <- allocDynClosure info_tbl lf_info
+                                          use_cc blame_cc args_w_offsets
+          ; return (mkRhsInit reg lf_info hp_plus_n) }
+    where
+      use_cc      -- cost-centre to stick in the object
+        | isCurrentCCS ccs = curCCS
+        | otherwise        = panic "buildDynCon: non-current CCS not implemented"
+  
+      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
 
 
 ---------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index 4d91451628..9f1f161d37 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -18,7 +18,7 @@ module StgCmmEnv (
 
 	cgIdInfoId, cgIdInfoLF,
 
-	litIdInfo, lneIdInfo, regIdInfo,
+        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
 	idInfoToAmode,
 
         NonVoid(..), isVoidId, nonVoidIds,
@@ -41,10 +41,10 @@ import StgCmmClosure
 
 import CLabel
 
+import MkGraph
 import BlockId
 import CmmExpr
 import CmmUtils
-import MkGraph (CmmAGraph, mkAssign)
 import FastString
 import Id
 import VarEnv
@@ -89,26 +89,24 @@ litIdInfo id lf lit
   where
     tag = lfDynTag lf
 
-lneIdInfo :: Id -> [LocalReg] -> CgIdInfo
+lneIdInfo :: Id -> [NonVoid Id] -> CgIdInfo
 lneIdInfo id regs 
   = CgIdInfo { cg_id = id, cg_lf = lf
-             , cg_loc = LneLoc blk_id regs
+             , cg_loc = LneLoc blk_id (map idToReg regs)
 	     , cg_tag = lfDynTag lf }
   where
     lf     = mkLFLetNoEscape
     blk_id = mkBlockId (idUnique id)
 
--- Because the register may be spilled to the stack in untagged form, we
--- modify the initialization code 'init' to immediately tag the
--- register, and store a plain register in the CgIdInfo.  We allocate
--- a new register in order to keep single-assignment and help out the
--- inliner. -- EZY
-regIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> FCode (CgIdInfo, CmmAGraph)
-regIdInfo id lf_info expr
-  = do { reg <- newTemp (cmmExprType expr)
-       ; let init = mkAssign (CmmLocal reg)
-                             (addDynTag expr (lfDynTag lf_info))
-       ; return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), init) }
+
+rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
+rhsIdInfo id lf_info
+  = do { reg <- newTemp gcWord
+       ; return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) }
+
+mkRhsInit :: LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
+mkRhsInit reg lf_info expr
+  = mkAssign (CmmLocal reg) (addDynTag expr (lfDynTag lf_info))
 
 idInfoToAmode :: CgIdInfo -> CmmExpr
 -- Returns a CmmExpr for the *tagged* pointer
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index cf3dc67dfc..038503eee7 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -45,13 +45,14 @@ import PrimOp
 import TyCon
 import Type
 import CostCentre	( CostCentreStack, currentCCS )
-import Control.Monad (when)
 import Maybes
 import Util
 import FastString
 import Outputable
 import UniqSupply
 
+import Control.Monad (when,void)
+
 ------------------------------------------------------------------------
 --		cgExpr: the main function
 ------------------------------------------------------------------------
@@ -108,17 +109,17 @@ cgLneBinds :: BlockId -> StgBinding -> FCode ()
 cgLneBinds join_id (StgNonRec bndr rhs)
   = do  { local_cc <- saveCurrentCostCentre
                 -- See Note [Saving the current cost centre]
-        ; info <- cgLetNoEscapeRhs join_id local_cc bndr rhs 
+        ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs
+        ; fcode
         ; addBindC (cg_id info) info }
 
 cgLneBinds join_id (StgRec pairs)
   = do  { local_cc <- saveCurrentCostCentre
-        ; new_bindings <- fixC (\ new_bindings -> do
-                { addBindsC new_bindings
-                ; listFCs [ cgLetNoEscapeRhs join_id local_cc b e 
-                          | (b,e) <- pairs ] })
-        ; addBindsC new_bindings }
-
+        ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs
+        ; let (infos, fcodes) = unzip r
+        ; addBindsC infos
+        ; sequence_ fcodes
+        }
 
 -------------------------
 cgLetNoEscapeRhs
@@ -126,20 +127,21 @@ cgLetNoEscapeRhs
     -> Maybe LocalReg	-- Saved cost centre
     -> Id
     -> StgRhs
-    -> FCode CgIdInfo
+    -> FCode (CgIdInfo, FCode ())
 
 cgLetNoEscapeRhs join_id local_cc bndr rhs =
-  do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs 
+  do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs
      ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
-     ; emitOutOfLine bid $ rhs_body <*> mkBranch join_id
-     ; return info
+     ; let code = do { body <- getCode rhs_code
+                     ; emitOutOfLine bid (body <*> mkBranch join_id) }
+     ; return (info, code)
      }
 
 cgLetNoEscapeRhsBody
     :: Maybe LocalReg	-- Saved cost centre
     -> Id
     -> StgRhs
-    -> FCode CgIdInfo
+    -> FCode (CgIdInfo, FCode ())
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
   = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
@@ -156,17 +158,18 @@ cgLetNoEscapeClosure
 	-> CostCentreStack   	-- XXX: *** NOT USED *** why not?
 	-> [NonVoid Id]		-- Args (as in \ args -> body)
     	-> StgExpr		-- Body (as in above)
-	-> FCode CgIdInfo
+        -> FCode (CgIdInfo, FCode ())
 
 cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
-  = do  { arg_regs <- forkProc $ do	
-		{ restoreCurrentCostCentre cc_slot
-		; arg_regs <- bindArgsToRegs args
-                ; _ <- altHeapCheck arg_regs (cgExpr body)
+  = return ( lneIdInfo bndr args
+           , code )
+  where
+   code = forkProc $ do
+                  { restoreCurrentCostCentre cc_slot
+                  ; arg_regs <- bindArgsToRegs args
+                  ; void $ altHeapCheck arg_regs (cgExpr body) }
 			-- Using altHeapCheck just reduces
 			-- instructions to save on stack
-		; return arg_regs }
-	; return $ lneIdInfo bndr arg_regs}
 
 
 ------------------------------------------------------------------------
@@ -600,11 +603,12 @@ cgConApp con stg_args
 
   | otherwise	--  Boxed constructors; allocate and return
   = ASSERT( stg_args `lengthIs` dataConRepRepArity con )
-    do	{ (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args
+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con)
+                                     currentCCS con stg_args
 	   	-- The first "con" says that the name bound to this closure is
 		-- is "con", which is a bit of a fudge, but it only affects profiling
 
-        ; emit init
+        ; emit =<< fcode_init
 	; emitReturn [idInfoToAmode idinfo] }
 
 
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 1819e44bb6..2290914310 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -17,8 +17,8 @@
 module StgCmmMonad (
 	FCode,	-- type
 
-        initC, runC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
-	returnFC, fixC, fixC_, nopC, whenC, 
+        initC, runC, thenC, thenFC, listCs,
+        returnFC, nopC, whenC,
 	newUnique, newUniqSupply, 
 
         newLabelC, emitLabel,
@@ -93,10 +93,10 @@ infixr 9 `thenFC`
 --	The FCode monad and its types
 --------------------------------------------------------
 
-newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
+newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #))
 
 instance Functor FCode where
-  fmap f (FCode g) = FCode $ \i s -> let (a,s') = g i s in (f a, s')
+  fmap f (FCode g) = FCode $ \i s -> case g i s of (# a, s' #) -> (# f a, s' #)
 
 instance Monad FCode where
 	(>>=) = thenFC
@@ -111,15 +111,15 @@ initC  = do { uniqs <- mkSplitUniqSupply 'c'
             ; return (initCgState uniqs) }
 
 runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
-runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st
+runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st
 
 returnFC :: a -> FCode a
-returnFC val = FCode (\_info_down state -> (val, state))
+returnFC val = FCode (\_info_down state -> (# val, state #))
 
 thenC :: FCode () -> FCode a -> FCode a
 thenC (FCode m) (FCode k) = 
-  	FCode (\info_down state -> let (_,new_state) = m info_down state in 
-  		k info_down new_state)
+        FCode $ \info_down state -> case m info_down state of
+                                     (# _,new_state #) -> k info_down new_state
 
 nopC :: FCode ()
 nopC = return ()
@@ -134,45 +134,13 @@ listCs (fc:fcs) = do
 	fc
 	listCs fcs
    	
-mapCs :: (a -> FCode ()) -> [a] -> FCode ()
-mapCs = mapM_
-
-thenFC	:: FCode a -> (a -> FCode c) -> FCode c
-thenFC (FCode m) k = FCode (
+thenFC  :: FCode a -> (a -> FCode c) -> FCode c
+thenFC (FCode m) k = FCode $
 	\info_down state ->
-		let 
-			(m_result, new_state) = m info_down state
-			(FCode kcode) = k m_result
-		in 
-			kcode info_down new_state
-	)
-    -- Note: this is a lazy monad.  We can't easily make it strict due
-    -- to the use of fixC for compiling recursive bindings (see Note
-    -- [cgBind rec]).  cgRhs returns a CgIdInfo which is fed back in
-    -- via the CgBindings, and making the monad strict means that we
-    -- can't look at the CgIdInfo too early.  Things seem to just
-    -- about work when the monad is lazy.  I hate this stuff --SDM
-
-
-listFCs :: [FCode a] -> FCode [a]
-listFCs = Prelude.sequence
-
-mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
-mapFCs = mapM
-
-fixC :: (a -> FCode a) -> FCode a
-fixC fcode = FCode (
-	\info_down state -> 
-		let
-			FCode fc = fcode v
-			result@(v,_) = fc info_down state
-			--	    ^--------^
-		in
-			result
-	)
-
-fixC_ :: (a -> FCode a) -> FCode ()
-fixC_ fcode = fixC fcode >> return ()
+            case m info_down state of
+              (# m_result, new_state #) ->
+                 case k m_result of
+                   FCode kcode -> kcode info_down new_state
 
 --------------------------------------------------------
 --	The code generator environment
@@ -405,10 +373,10 @@ hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
 --------------------------------------------------------
 
 getState :: FCode CgState
-getState = FCode $ \_info_down state -> (state,state)
+getState = FCode $ \_info_down state -> (# state, state #)
 
 setState :: CgState -> FCode ()
-setState state = FCode $ \_info_down _ -> ((),state)
+setState state = FCode $ \_info_down _ -> (# (), state #)
 
 getHpUsage :: FCode HeapUsage
 getHpUsage = do
@@ -452,7 +420,8 @@ getStaticBinds = do
 
 withState :: FCode a -> CgState -> FCode (a,CgState)
 withState (FCode fcode) newstate = FCode $ \info_down state -> 
-	let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
+  case fcode info_down newstate of
+    (# retval, state2 #) -> (# (retval,state2), state #)
 
 newUniqSupply :: FCode UniqSupply
 newUniqSupply = do
@@ -468,7 +437,7 @@ newUnique = do
 
 ------------------
 getInfoDown :: FCode CgInfoDownwards
-getInfoDown = FCode $ \info_down state -> (info_down,state)
+getInfoDown = FCode $ \info_down state -> (# info_down,state #)
 
 instance HasDynFlags FCode where
     getDynFlags = liftM cgd_dflags getInfoDown
@@ -480,8 +449,9 @@ withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
 withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state 
 
 doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
-doFCode (FCode fcode) info_down state = fcode info_down state
-
+doFCode (FCode fcode) info_down state =
+  case fcode info_down state of
+    (# a, s #) -> ( a, s )
 
 -- ----------------------------------------------------------------------------
 -- Get the current module name