Produce new-style Cmm from the Cmm parser

The main change here is that the Cmm parser now allows high-level cmm
code with argument-passing and function calls.  For example:

foo ( gcptr a, bits32 b )
{
  if (b > 0) {
     // we can make tail calls passing arguments:
     jump stg_ap_0_fast(a);
  }

  return (x,y);
}

More details on the new cmm syntax are in Note [Syntax of .cmm files]
in CmmParse.y.

The old syntax is still more-or-less supported for those occasional
code fragments that really need to explicitly manipulate the stack.
However there are a couple of differences: it is now obligatory to
give a list of live GlobalRegs on every jump, e.g.

  jump %ENTRY_CODE(Sp(0)) [R1];

Again, more details in Note [Syntax of .cmm files].

I have rewritten most of the .cmm files in the RTS into the new
syntax, except for AutoApply.cmm which is generated by the genapply
program: this file could be generated in the new syntax instead and
would probably be better off for it, but I ran out of enthusiasm.

Some other changes in this batch:

 - The PrimOp calling convention is gone, primops now use the ordinary
   NativeNodeCall convention.  This means that primops and "foreign
   import prim" code must be written in high-level cmm, but they can
   now take more than 10 arguments.

 - CmmSink now does constant-folding (should fix #7219)

 - .cmm files now go through the cmmPipeline, and as a result we
   generate better code in many cases.  All the object files generated
   for the RTS .cmm files are now smaller.  Performance should be
   better too, but I haven't measured it yet.

 - RET_DYN frames are removed from the RTS, lots of code goes away

 - we now have some more canned GC points to cover unboxed-tuples with
   2-4 pointers, which will reduce code size a little.

22 files changed, 359 insertions, 357 deletions

diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs
index 1f5b711d86..d548741e1f 100644
--- a/compiler/codeGen/CgCallConv.hs
+++ b/compiler/codeGen/CgCallConv.hs
@@ -70,7 +70,7 @@ mkArgDescr _nm args
        let arg_bits = argBits dflags arg_reps
            arg_reps = filter nonVoidArg (map idCgRep args)
            -- Getting rid of voids eases matching of standard patterns
-       case stdPattern dflags arg_reps of
+       case stdPattern arg_reps of
            Just spec_id -> return (ArgSpec spec_id)
            Nothing      -> return (ArgGen arg_bits)
 
@@ -79,10 +79,9 @@ argBits _      []              = []
 argBits dflags (PtrArg : args) = False : argBits dflags args
 argBits dflags (arg    : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args
 
-stdPattern :: DynFlags -> [CgRep] -> Maybe StgHalfWord
-stdPattern dflags reps
-    = fmap (toStgHalfWord dflags)
-    $ case reps of
+stdPattern :: [CgRep] -> Maybe Int
+stdPattern reps
+    = case reps of
       []          -> Just ARG_NONE  -- just void args, probably
 
       [PtrArg]    -> Just ARG_P
diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index aeb87235e3..858de3a616 100644
--- a/compiler/codeGen/CgCon.lhs
+++ b/compiler/codeGen/CgCon.lhs
@@ -189,7 +189,7 @@ buildDynCon' dflags platform binder _ con [arg_amode]
   , (_, CmmLit (CmmInt val _)) <- arg_amode
   , let val_int = (fromIntegral val) :: Int
   , val_int <= mAX_INTLIKE dflags && val_int >= mIN_INTLIKE dflags
-  = do  { let intlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
+  = do  { let intlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE")
               offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1)
                 -- INTLIKE closures consist of a header and one word payload
               intlike_amode = CmmLit (cmmLabelOffW dflags intlike_lbl offsetW)
@@ -201,7 +201,7 @@ buildDynCon' dflags platform binder _ con [arg_amode]
   , (_, CmmLit (CmmInt val _)) <- arg_amode
   , let val_int = (fromIntegral val) :: Int
   , val_int <= mAX_CHARLIKE dflags && val_int >= mIN_CHARLIKE dflags
-  = do  { let charlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
+  = do  { let charlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE")
               offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1)
                 -- CHARLIKE closures consist of a header and one word payload
               charlike_amode = CmmLit (cmmLabelOffW dflags charlike_lbl offsetW)
diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs
index 965abf0db8..8cff77381d 100644
--- a/compiler/codeGen/CgHeapery.lhs
+++ b/compiler/codeGen/CgHeapery.lhs
@@ -415,7 +415,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code
         { dflags <- getDynFlags
         ; let full_fail_code  = fail_code `plusStmts` oneStmt assign_liveness
               assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr))    -- Ho ho ho!
-                                          (CmmLit (mkWordCLit dflags liveness))
+                                          (CmmLit (mkStgWordCLit dflags liveness))
               liveness        = mkRegLiveness dflags regs ptrs nptrs
               live            = Just $ map snd regs
               rts_label       = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut")))
diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index c124b5f68a..03e01b332a 100644
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -258,7 +258,7 @@ dynLdvInit :: DynFlags -> CmmExpr
 dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
   CmmMachOp (mo_wordOr dflags) [
       CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
-      CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags))
+      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))
   ]
 
 --
@@ -289,8 +289,8 @@ ldvEnter cl_ptr = do
         -- don't forget to substract node's tag
     ldv_wd = ldvWord dflags cl_ptr
     new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
-                                                     (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags))))
-                 (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags))))
+                                                     (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
+                 (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))
   ifProfiling $
      -- if (era > 0) {
      --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
@@ -308,10 +308,3 @@ ldvWord :: DynFlags -> CmmExpr -> CmmExpr
 ldvWord dflags closure_ptr
     = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
 
-lDV_CREATE_MASK :: DynFlags -> StgWord
-lDV_CREATE_MASK dflags = toStgWord dflags (iLDV_CREATE_MASK dflags)
-lDV_STATE_CREATE :: DynFlags -> StgWord
-lDV_STATE_CREATE dflags = toStgWord dflags (iLDV_STATE_CREATE dflags)
-lDV_STATE_USE :: DynFlags -> StgWord
-lDV_STATE_USE dflags = toStgWord dflags (iLDV_STATE_USE dflags)
-
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 3a106abfb4..9f9a2cfe26 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -800,8 +800,8 @@ getSRTInfo = do
             let srt_desc_lbl = mkLargeSRTLabel id
             emitRODataLits "getSRTInfo" srt_desc_lbl
              ( cmmLabelOffW dflags srt_lbl off
-               : mkWordCLit dflags (toStgWord dflags (toInteger len))
-               : map (mkWordCLit dflags) bmp)
+               : mkWordCLit dflags (toInteger len)
+               : map (mkWordCLit dflags . fromStgWord) bmp)
             return (C_SRT srt_desc_lbl 0 (srt_escape dflags))
 
       | otherwise
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index 740bfab845..f2cbc21d27 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -480,7 +480,7 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds srt_info descr
 		    -- anything else gets eta expanded.
   where
     name   = idName id
-    sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info)
+    sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
     nonptr_wds = tot_wds - ptr_wds
 
 mkConInfo :: DynFlags
@@ -492,7 +492,7 @@ mkConInfo dflags is_static data_con tot_wds ptr_wds
    = ConInfo {	closureSMRep = sm_rep,
 		closureCon = data_con }
   where
-    sm_rep  = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info)
+    sm_rep  = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
     lf_info = mkConLFInfo data_con
     nonptr_wds = tot_wds - ptr_wds
 \end{code}
@@ -526,16 +526,16 @@ closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
 %************************************************************************
 
 \begin{code}
-lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo
-lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd
-lfClosureType dflags (LFCon con)                  = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con)))
-                                                           (dataConIdentity con)
-lfClosureType dflags (LFThunk _ _ _ is_sel _)     = thunkClosureType dflags is_sel
-lfClosureType _      _                            = panic "lfClosureType"
-
-thunkClosureType :: DynFlags -> StandardFormInfo -> ClosureTypeInfo
-thunkClosureType dflags (SelectorThunk off) = ThunkSelector (toStgWord dflags (toInteger off))
-thunkClosureType _      _                   = Thunk
+lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
+lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd
+lfClosureType (LFCon con)                  = Constr (dataConTagZ con)
+                                                    (dataConIdentity con)
+lfClosureType (LFThunk _ _ _ is_sel _)     = thunkClosureType is_sel
+lfClosureType _                            = panic "lfClosureType"
+
+thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
+thunkClosureType (SelectorThunk off) = ThunkSelector off
+thunkClosureType _                   = Thunk
 
 -- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
 -- gets compiled to a jump to g (if g has non-zero arity), instead of
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 37ca5e0d43..67aae3f6c0 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -245,7 +245,7 @@ cgDataCon data_con
             arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)]
 
             -- Dynamic closure code for non-nullary constructors only
-        ; whenC (not (isNullaryRepDataCon data_con))
+        ; when (not (isNullaryRepDataCon data_con))
                 (emit_info dyn_info_tbl tickyEnterDynCon)
 
                 -- Dynamic-Closure first, to reduce forward references
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 89d27dd161..5e46dcfd65 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -10,7 +10,7 @@ module StgCmmBind (
         cgTopRhsClosure,
         cgBind,
         emitBlackHoleCode,
-        pushUpdateFrame
+        pushUpdateFrame, emitUpdateFrame
   ) where
 
 #include "HsVersions.h"
@@ -37,7 +37,6 @@ import CLabel
 import StgSyn
 import CostCentre
 import Id
-import Control.Monad
 import Name
 import Module
 import ListSetOps
@@ -48,6 +47,8 @@ import FastString
 import Maybes
 import DynFlags
 
+import Control.Monad
+
 ------------------------------------------------------------------------
 --              Top-level bindings
 ------------------------------------------------------------------------
@@ -460,7 +461,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
                     (CmmMachOp (mo_wordSub dflags)
                          [ CmmReg nodeReg
                          , mkIntExpr dflags (funTag dflags cl_info) ])
-                ; whenC node_points (ldvEnterClosure cl_info)
+                ; when node_points (ldvEnterClosure cl_info)
                 ; granYield arg_regs node_points
 
                 -- Main payload
@@ -525,8 +526,8 @@ thunkCode cl_info fv_details _cc node arity body
         ; entryHeapCheck cl_info node' arity [] $ do
         { -- Overwrite with black hole if necessary
           -- but *after* the heap-overflow check
-        ; whenC (blackHoleOnEntry cl_info && node_points)
-                (blackHoleIt cl_info)
+        ; when (blackHoleOnEntry cl_info && node_points)
+                (blackHoleIt cl_info node)
 
           -- Push update frame
         ; setupUpdate cl_info node $
@@ -545,13 +546,14 @@ thunkCode cl_info fv_details _cc node arity body
 --              Update and black-hole wrappers
 ------------------------------------------------------------------------
 
-blackHoleIt :: ClosureInfo -> FCode ()
+blackHoleIt :: ClosureInfo -> LocalReg -> FCode ()
 -- Only called for closures with no args
 -- Node points to the closure
-blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
+blackHoleIt closure_info node
+  = emitBlackHoleCode (closureSingleEntry closure_info) (CmmReg (CmmLocal node))
 
-emitBlackHoleCode :: Bool -> FCode ()
-emitBlackHoleCode is_single_entry = do
+emitBlackHoleCode :: Bool -> CmmExpr -> FCode ()
+emitBlackHoleCode is_single_entry node = do
   dflags <- getDynFlags
 
   -- Eager blackholing is normally disabled, but can be turned on with
@@ -578,12 +580,12 @@ emitBlackHoleCode is_single_entry = do
              -- profiling), so currently eager blackholing doesn't
              -- work with profiling.
 
-  whenC eager_blackholing $ do
+  when eager_blackholing $ do
     tickyBlackHole (not is_single_entry)
-    emitStore (cmmOffsetW dflags (CmmReg nodeReg) (fixedHdrSize dflags))
+    emitStore (cmmOffsetW dflags node (fixedHdrSize dflags))
                   (CmmReg (CmmGlobal CurrentTSO))
     emitPrimCall [] MO_WriteBarrier []
-    emitStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
+    emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
 
 setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
         -- Nota Bene: this function does not change Node (even if it's a CAF),
@@ -634,13 +636,20 @@ pushUpdateFrame lbl updatee body
        let
            hdr         = fixedHdrSize dflags * wORD_SIZE dflags
            frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags
-           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags
        --
-       emitStore (CmmStackSlot Old frame) (mkLblExpr lbl)
-       emitStore (CmmStackSlot Old (frame - off_updatee)) updatee
-       initUpdFrameProf frame
+       emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee
        withUpdFrameOff frame body
 
+emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()
+emitUpdateFrame dflags frame lbl updatee = do
+  let
+           hdr         = fixedHdrSize dflags * wORD_SIZE dflags
+           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags
+  --
+  emitStore frame (mkLblExpr lbl)
+  emitStore (cmmOffset dflags frame off_updatee) updatee
+  initUpdFrameProf frame
+
 -----------------------------------------------------------------------------
 -- Entering a CAF
 --
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 4be5bd3d0c..f865c37ad8 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -353,16 +353,16 @@ isLFReEntrant _                = False
 --		Choosing SM reps
 -----------------------------------------------------------------------------
 
-lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo
-lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd
-lfClosureType dflags (LFCon con)                  = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con)))
-                                                           (dataConIdentity con)
-lfClosureType dflags (LFThunk _ _ _ is_sel _)     = thunkClosureType dflags is_sel
-lfClosureType _      _                            = panic "lfClosureType"
+lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
+lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd
+lfClosureType (LFCon con)                  = Constr (dataConTagZ con)
+                                                    (dataConIdentity con)
+lfClosureType (LFThunk _ _ _ is_sel _)     = thunkClosureType is_sel
+lfClosureType _                            = panic "lfClosureType"
 
-thunkClosureType :: DynFlags -> StandardFormInfo -> ClosureTypeInfo
-thunkClosureType dflags (SelectorThunk off) = ThunkSelector (toStgWord dflags (toInteger off))
-thunkClosureType _      _                   = Thunk
+thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
+thunkClosureType (SelectorThunk off) = ThunkSelector off
+thunkClosureType _                   = Thunk
 
 -- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
 -- gets compiled to a jump to g (if g has non-zero arity), instead of
@@ -373,8 +373,6 @@ thunkClosureType _      _                   = Thunk
 --		nodeMustPointToIt
 -----------------------------------------------------------------------------
 
--- Be sure to see the stg-details notes about these...
-
 nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
 nodeMustPointToIt _ (LFReEntrant top _ no_fvs _)
   = not no_fvs ||   -- Certainly if it has fvs we need to point to it
@@ -687,7 +685,7 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
                   closureProf      = prof }     -- (we don't have an SRT yet)
   where
     name       = idName id
-    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info)
+    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
     prof       = mkProfilingInfo dflags id val_descr
     nonptr_wds = tot_wds - ptr_wds
 
@@ -899,8 +897,7 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
 
    sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type
 
-   cl_type = Constr (toStgHalfWord dflags (toInteger (dataConTagZ data_con)))
-                    (dataConIdentity data_con)
+   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
 
    prof | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo
         | otherwise                            = ProfilingInfo ty_descr val_descr
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index c822a64e2c..8e775dec51 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -185,7 +185,7 @@ buildDynCon' dflags platform binder _cc con [arg]
   , StgLitArg (MachInt val) <- arg
   , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
   , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
-  = do  { let intlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
+  = do  { let intlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE")
               val_int = fromIntegral val :: Int
               offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1)
                 -- INTLIKE closures consist of a header and one word payload
@@ -200,7 +200,7 @@ buildDynCon' dflags platform binder _cc con [arg]
   , let val_int = ord val :: Int
   , val_int <= mAX_CHARLIKE dflags
   , val_int >= mIN_CHARLIKE dflags
-  = do  { let charlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
+  = do  { let charlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE")
               offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1)
                 -- CHARLIKE closures consist of a header and one word payload
               charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index a8ffc12bb0..a0859252ff 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -717,12 +717,12 @@ emitEnter fun = do
       --
       AssignTo res_regs _ -> do
        { lret <- newLabelC
-       ; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs
+       ; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []
        ; lcall <- newLabelC
        ; updfr_off <- getUpdFrameOff
        ; let area = Young lret
        ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area
-                                          [fun] updfr_off (0,[])
+                                          [fun] updfr_off []
          -- refer to fun via nodeReg after the copyout, to avoid having
          -- both live simultaneously; this sometimes enables fun to be
          -- inlined in the RHS of the R1 assignment.
diff --git a/compiler/codeGen/CgExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs
index a651319a49..b0608227ae 100644
--- a/compiler/codeGen/CgExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -9,44 +9,36 @@
 -- to collect declarations as we parse the proc, and feed the environment
 -- back in circularly (to avoid a two-pass algorithm).
 
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module CgExtCode (
-	ExtFCode(..),
-	ExtCode,
-	Named(..), Env,
+module StgCmmExtCode (
+	CmmParse(..),
+        Named(..), Env,
 	
 	loopDecls,
 	getEnv,
 
 	newLocal,
-	newLabel,
+        newLabel,
+        newBlockId,
 	newFunctionName,
 	newImport,
 	lookupLabel,
 	lookupName,
 
 	code,
-	code2,
-	nopEC,
-	stmtEC,
-	stmtsEC,
-	getCgStmtsEC,
-	getCgStmtsEC',
-	forkLabelledCodeEC
+        emit, emitLabel, emitAssign, emitStore,
+        getCode, getCodeR,
+        emitOutOfLine,
+        withUpdFrameOff, getUpdFrameOff
 )
 
 where
 
-import CgMonad
+import qualified StgCmmMonad as F
+import StgCmmMonad (FCode, newUnique)
 
+import Cmm
 import CLabel
-import OldCmm hiding( ClosureTypeInfo(..) )
+import MkGraph
 
 -- import BasicTypes
 import BlockId
@@ -73,22 +65,22 @@ type Decls 	= [(FastString,Named)]
 
 -- | Does a computation in the FCode monad, with a current environment
 --	and a list of local declarations. Returns the resulting list of declarations.
-newtype ExtFCode a 	
+newtype CmmParse a 	
 	= EC { unEC :: Env -> Decls -> FCode (Decls, a) }
 
-type ExtCode = ExtFCode ()
+type ExtCode = CmmParse ()
 
-returnExtFC :: a -> ExtFCode a
+returnExtFC :: a -> CmmParse a
 returnExtFC a 	= EC $ \_ s -> return (s, a)
 
-thenExtFC :: ExtFCode a -> (a -> ExtFCode b) -> ExtFCode b
+thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
 
-instance Monad ExtFCode where
+instance Monad CmmParse where
   (>>=) = thenExtFC
   return = returnExtFC
 
-instance HasDynFlags ExtFCode where
+instance HasDynFlags CmmParse where
     getDynFlags = EC (\_ d -> do dflags <- getDynFlags
                                  return (d, dflags))
 
@@ -99,15 +91,15 @@ instance HasDynFlags ExtFCode where
 -- 	procedure, and imports that scope over the entire module.
 --	Discards the local declaration contained within decl'
 --
-loopDecls :: ExtFCode a -> ExtFCode a
+loopDecls :: CmmParse a -> CmmParse a
 loopDecls (EC fcode) =
       EC $ \e globalDecls -> do
-	(_, a) <- fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
+        (_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
 	return (globalDecls, a)
 
 
 -- | Get the current environment from the monad.
-getEnv :: ExtFCode Env
+getEnv :: CmmParse Env
 getEnv 	= EC $ \e s -> return (s, e)
 
 
@@ -127,7 +119,7 @@ addLabel name block_id
 newLocal 
 	:: CmmType 		-- ^ data type
 	-> FastString 		-- ^ name of variable
-	-> ExtFCode LocalReg	-- ^ register holding the value
+	-> CmmParse LocalReg	-- ^ register holding the value
 	
 newLocal ty name = do
    u <- code newUnique
@@ -137,12 +129,14 @@ newLocal ty name = do
 
 
 -- | Allocate a fresh label.
-newLabel :: FastString -> ExtFCode BlockId
+newLabel :: FastString -> CmmParse BlockId
 newLabel name = do
    u <- code newUnique
    addLabel name (mkBlockId u)
    return (mkBlockId u)
 
+newBlockId :: CmmParse BlockId
+newBlockId = code F.newLabelC
 
 -- | Add add a local function to the environment.
 newFunctionName 
@@ -159,7 +153,7 @@ newFunctionName name pkg
 --	over the whole module.
 newImport 
 	:: (FastString, CLabel) 
-	-> ExtFCode ()
+	-> CmmParse ()
 
 newImport (name, cmmLabel) 
    = addVarDecl name (CmmLit (CmmLabel cmmLabel))
@@ -168,7 +162,7 @@ newImport (name, cmmLabel)
 -- | Lookup the BlockId bound to the label with this name.
 --	If one hasn't been bound yet, create a fresh one based on the 
 --	Unique of the name.
-lookupLabel :: FastString -> ExtFCode BlockId
+lookupLabel :: FastString -> CmmParse BlockId
 lookupLabel name = do
   env <- getEnv
   return $ 
@@ -181,7 +175,7 @@ lookupLabel name = do
 --	Unknown names are treated as if they had been 'import'ed from the runtime system.
 -- 	This saves us a lot of bother in the RTS sources, at the expense of
 -- 	deferring some errors to link time.
-lookupName :: FastString -> ExtFCode CmmExpr
+lookupName :: FastString -> CmmParse CmmExpr
 lookupName name = do
   env    <- getEnv
   return $ 
@@ -191,51 +185,40 @@ lookupName name = do
 	_other 		-> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
 
 
--- | Lift an FCode computation into the ExtFCode monad
-code :: FCode a -> ExtFCode a
+-- | Lift an FCode computation into the CmmParse monad
+code :: FCode a -> CmmParse a
 code fc = EC $ \_ s -> do 
 		r <- fc
  		return (s, r)
 
+emit :: CmmAGraph -> CmmParse ()
+emit = code . F.emit
 
-code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) -> ExtFCode b -> ExtFCode c
-code2 f (EC ec) 
-	= EC $ \e s -> do 
-		((s', _),c) <- f (ec e s)
-		return (s',c)
+emitLabel :: BlockId -> CmmParse ()
+emitLabel = code. F.emitLabel
 
+emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()
+emitAssign l r = code (F.emitAssign l r)
 
--- | Do nothing in the ExtFCode monad.
-nopEC :: ExtFCode ()
-nopEC = code nopC
+emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()
+emitStore l r = code (F.emitStore l r)
 
+getCode :: CmmParse a -> CmmParse CmmAGraph
+getCode (EC ec) = EC $ \e s -> do
+  ((s',_), gr) <- F.getCodeR (ec e s)
+  return (s', gr)
 
--- | Accumulate a CmmStmt into the monad state.
-stmtEC :: CmmStmt -> ExtFCode () 
-stmtEC stmt = code (stmtC stmt)
+getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
+getCodeR (EC ec) = EC $ \e s -> do
+  ((s', r), gr) <- F.getCodeR (ec e s)
+  return (s', (r,gr))
 
+emitOutOfLine :: BlockId -> CmmAGraph -> CmmParse ()
+emitOutOfLine l g = code (F.emitOutOfLine l g)
 
--- | Accumulate some CmmStmts into the monad state.
-stmtsEC :: [CmmStmt] -> ExtFCode ()
-stmtsEC stmts = code (stmtsC stmts)
-
-
--- | Get the generated statements out of the monad state.
-getCgStmtsEC :: ExtFCode a -> ExtFCode CgStmts
-getCgStmtsEC = code2 getCgStmts'
-
-
--- | Get the generated statements, and the return value out of the monad state.
-getCgStmtsEC' :: ExtFCode a -> ExtFCode (a, CgStmts)
-getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
-  where f ((decl, b), c) = return ((decl, b), (b, c))
-
-
--- | Emit a chunk of code outside the instruction stream, 
---	and return its block id. 
-forkLabelledCodeEC :: ExtFCode a -> ExtFCode BlockId
-forkLabelledCodeEC ec = do
-  stmts <- getCgStmtsEC ec
-  code (forkCgStmts stmts)
-
+withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
+withUpdFrameOff size inner
+  = EC $ \e s -> F.withUpdFrameOff size $ (unEC inner) e s
 
+getUpdFrameOff :: CmmParse UpdFrameOffset
+getUpdFrameOff = code $ F.getUpdFrameOff
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index 9e4db9cdaa..1830f7b6d6 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -9,9 +9,10 @@
 module StgCmmForeign (
   cgForeignCall, loadThreadState, saveThreadState,
   emitPrimCall, emitCCall,
+  emitForeignCall,     -- For CmmParse
   emitSaveThreadState, -- will be needed by the Cmm parser
   emitLoadThreadState, -- ditto
-  emitOpenNursery,
+  emitCloseNursery, emitOpenNursery
  ) where
 
 #include "HsVersions.h"
@@ -24,10 +25,8 @@ import StgCmmUtils
 import StgCmmClosure
 import StgCmmLayout
 
-import BlockId
 import Cmm
 import CmmUtils
-import OldCmm ( CmmReturnInfo(..) )
 import MkGraph
 import Type
 import TysPrim
@@ -85,7 +84,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
                    DynamicTarget    ->  case cmm_args of
                                            (fn,_):rest -> (unzip rest, fn)
                                            [] -> panic "cgForeignCall []"
-              fc = ForeignConvention cconv arg_hints res_hints
+              fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn
               call_target = ForeignTarget cmm_target fc
 
         -- we want to emit code for the call, and then emitReturn.
@@ -100,12 +99,10 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
         ; sequel <- getSequel
         ; case sequel of
             AssignTo assign_to_these _ ->
-                emitForeignCall safety assign_to_these call_target
-                                     call_args CmmMayReturn
+                emitForeignCall safety assign_to_these call_target call_args
 
             _something_else ->
-                do { _ <- emitForeignCall safety res_regs call_target
-                                     call_args CmmMayReturn
+                do { _ <- emitForeignCall safety res_regs call_target call_args
                    ; emitReturn (map (CmmReg . CmmLocal) res_regs)
                    }
          }
@@ -183,17 +180,17 @@ emitCCall :: [(CmmFormal,ForeignHint)]
           -> [(CmmActual,ForeignHint)]
           -> FCode ()
 emitCCall hinted_results fn hinted_args
-  = void $ emitForeignCall PlayRisky results target args CmmMayReturn
+  = void $ emitForeignCall PlayRisky results target args
   where
     (args, arg_hints) = unzip hinted_args
     (results, result_hints) = unzip hinted_results
     target = ForeignTarget fn fc
-    fc = ForeignConvention CCallConv arg_hints result_hints
+    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn
 
 
 emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
 emitPrimCall res op args
-  = void $ emitForeignCall PlayRisky res (PrimTarget op) args CmmMayReturn
+  = void $ emitForeignCall PlayRisky res (PrimTarget op) args
 
 -- alternative entry point, used by CmmParse
 emitForeignCall
@@ -201,10 +198,8 @@ emitForeignCall
         -> [CmmFormal]          -- where to put the results
         -> ForeignTarget        -- the op
         -> [CmmActual]          -- arguments
-        -> CmmReturnInfo        -- This can say "never returns"
-                                --   only RTS procedures do this
         -> FCode ReturnKind
-emitForeignCall safety results target args _ret
+emitForeignCall safety results target args
   | not (playSafe safety) = do
     dflags <- getDynFlags
     let (caller_save, caller_load) = callerSaveVolatileRegs dflags
@@ -218,7 +213,7 @@ emitForeignCall safety results target args _ret
     updfr_off <- getUpdFrameOff
     temp_target <- load_target_into_temp target
     k <- newLabelC
-    let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results
+    let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results []
        -- see Note [safe foreign call convention]
     emit $
            (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))
@@ -285,17 +280,15 @@ saveThreadState dflags =
         mkStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS
       else mkNop
 
-emitSaveThreadState :: BlockId -> FCode ()
-emitSaveThreadState bid = do
+emitSaveThreadState :: FCode ()
+emitSaveThreadState = do
   dflags <- getDynFlags
+  emit (saveThreadState dflags)
 
-  -- CurrentTSO->stackobj->sp = Sp;
-  emitStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags))
-                 (CmmStackSlot (Young bid) (widthInBytes (typeWidth (gcWord dflags))))
-  emit $ closeNursery dflags
-  -- and save the current cost centre stack in the TSO when profiling:
-  when (dopt Opt_SccProfilingOn dflags) $
-        emitStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS
+emitCloseNursery :: FCode ()
+emitCloseNursery = do
+  df <- getDynFlags
+  emit (closeNursery df)
 
    -- CurrentNursery->free = Hp+1;
 closeNursery :: DynFlags -> CmmAGraph
@@ -303,8 +296,6 @@ closeNursery dflags = mkStore (nursery_bdescr_free dflags) (cmmOffsetW dflags st
 
 loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
 loadThreadState dflags tso stack = do
-  -- tso <- newTemp (gcWord dflags) -- TODO FIXME NOW
-  -- stack <- newTemp (gcWord dflags) -- TODO FIXME NOW
   catAGraphs [
         -- tso = CurrentTSO;
         mkAssign (CmmLocal tso) stgCurrentTSO,
@@ -321,9 +312,18 @@ loadThreadState dflags tso stack = do
           storeCurCCS
             (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType dflags))
         else mkNop]
-emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
-emitLoadThreadState tso stack = do dflags <- getDynFlags
-                                   emit $ loadThreadState dflags tso stack
+
+emitLoadThreadState :: FCode ()
+emitLoadThreadState = do
+  dflags <- getDynFlags
+  load_tso <- newTemp (gcWord dflags)
+  load_stack <- newTemp (gcWord dflags)
+  emit $ loadThreadState dflags load_tso load_stack
+
+emitOpenNursery :: FCode ()
+emitOpenNursery = do
+  df <- getDynFlags
+  emit (openNursery df)
 
 openNursery :: DynFlags -> CmmAGraph
 openNursery dflags = catAGraphs [
@@ -345,9 +345,6 @@ openNursery dflags = catAGraphs [
                 )
             )
    ]
-emitOpenNursery :: FCode ()
-emitOpenNursery = do dflags <- getDynFlags
-                     emit $ openNursery dflags
 
 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr
 nursery_bdescr_free   dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags)
diff --git a/compiler/codeGen/StgCmmGran.hs b/compiler/codeGen/StgCmmGran.hs
index 2abca3fe16..fe00d7c384 100644
--- a/compiler/codeGen/StgCmmGran.hs
+++ b/compiler/codeGen/StgCmmGran.hs
@@ -53,7 +53,7 @@ staticGranHdr = []
 doGranAllocate :: CmmExpr -> Code
 -- macro DO_GRAN_ALLOCATE
 doGranAllocate hp
-  | not opt_GranMacros = nopC
+  | not opt_GranMacros = return ()
   | otherwise          = panic "doGranAllocate"
 
 
@@ -75,7 +75,7 @@ granFetchAndReschedule regs node_reqd
   = do { fetch
        ; reschedule liveness node_reqd }
   | otherwise
-  = nopC
+  = return ()
   where
     liveness = mkRegLiveness regs 0 0
 
@@ -109,7 +109,7 @@ granYield :: [(Id,GlobalReg)]   -- Live registers
 
 granYield regs node_reqd
   | opt_GranMacros && node_reqd = yield liveness
-  | otherwise                   = nopC
+  | otherwise                   = return ()
   where
      liveness = mkRegLiveness regs 0 0
 
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index b7cca48f5a..c133ab00d4 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -11,6 +11,8 @@ module StgCmmHeap (
         getHpRelOffset, hpRel,
 
         entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,
+        heapStackCheckGen,
+        entryHeapCheck',
 
         mkVirtHeapOffsets, mkVirtConstrOffsets,
         mkStaticClosureFields, mkStaticClosure,
@@ -47,6 +49,7 @@ import FastString( mkFastString, fsLit )
 import Util
 
 import Control.Monad (when)
+import Data.Maybe (isJust)
 
 -----------------------------------------------------------
 --              Initialise dynamic heap objects
@@ -334,16 +337,28 @@ entryHeapCheck :: ClosureInfo
                -> FCode ()
 
 entryHeapCheck cl_info nodeSet arity args code
+  = entryHeapCheck' is_fastf node arity args code
+  where
+    node = case nodeSet of
+              Just r  -> CmmReg (CmmLocal r)
+              Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)
+
+    is_fastf = case closureFunInfo cl_info of
+                 Just (_, ArgGen _) -> False
+                 _otherwise         -> True
+
+-- | lower-level version for CmmParse
+entryHeapCheck' :: Bool           -- is a known function pattern
+                -> CmmExpr        -- expression for the closure pointer
+                -> Int            -- Arity -- not same as len args b/c of voids
+                -> [LocalReg]     -- Non-void args (empty for thunk)
+                -> FCode ()
+                -> FCode ()
+entryHeapCheck' is_fastf node arity args code
   = do dflags <- getDynFlags
        let is_thunk = arity == 0
-           is_fastf = case closureFunInfo cl_info of
-                           Just (_, ArgGen _) -> False
-                           _otherwise         -> True
 
            args' = map (CmmReg . CmmLocal) args
-           node = case nodeSet of
-                      Just r  -> CmmReg (CmmLocal r)
-                      Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)
            stg_gc_fun    = CmmReg (CmmGlobal GCFun)
            stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
 
@@ -373,50 +388,6 @@ entryHeapCheck cl_info nodeSet arity args code
        emitLabel loop_id
        heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code
 
-{-
-    -- 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: 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")
-                              W64 -> Just (sLit "stg_gc_d1")
-                              _other -> Nothing
-        | width == wordWidth dflags = 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 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 in a case alternative
 
@@ -445,7 +416,7 @@ altOrNoEscapeHeapCheck checkYield regs code = do
       Nothing -> genericGC checkYield code
       Just gc -> do
         lret <- newLabelC
-        let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs
+        let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
         lcont <- newLabelC
         emitOutOfLine lret (copyin <*> mkBranch lcont)
         emitLabel lcont
@@ -475,23 +446,29 @@ cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code
     reg_exprs = map (CmmReg . CmmLocal) regs
       -- Note [stg_gc arguments]
 
+      -- NB. we use the NativeReturn convention for passing arguments
+      -- to the canned heap-check routines, because we are in a case
+      -- alternative and hence the [LocalReg] was passed to us in the
+      -- NativeReturn convention.
     gc_call dflags label sp
-      | cont_on_stack = mkJumpReturnsTo dflags label GC reg_exprs lret off sp
-      | otherwise     = mkCallReturnsTo dflags label GC reg_exprs lret off sp (0,[])
+      | cont_on_stack
+      = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp
+      | otherwise
+      = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []
 
 genericGC :: Bool -> FCode a -> FCode a
 genericGC checkYield code
   = do updfr_sz <- getUpdFrameOff
        lretry <- newLabelC
        emitLabel lretry
-       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz (0,[])
+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
        heapCheck False checkYield (call <*> mkBranch lretry) code
 
 cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr
 cannedGCEntryPoint dflags regs
-  = case regs of
+  = case map localRegType regs of
       []  -> Just (mkGcLabel "stg_gc_noregs")
-      [reg]
+      [ty]
           | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")
           | isFloatType ty -> case width of
                                   W32       -> Just (mkGcLabel "stg_gc_f1")
@@ -502,8 +479,19 @@ cannedGCEntryPoint dflags regs
           | width == W64              -> Just (mkGcLabel "stg_gc_l1")
           | otherwise                 -> Nothing
           where
-              ty = localRegType reg
               width = typeWidth ty
+      [ty1,ty2]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")
+      [ty1,ty2,ty3]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2
+          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")
+      [ty1,ty2,ty3,ty4]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2
+          && isGcPtrType ty3
+          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")
       _otherwise -> Nothing
 
 -- Note [stg_gc arguments]
@@ -538,51 +526,70 @@ heapCheck checkStack checkYield do_gc code
   = getHeapUsage $ \ hpHw ->
     -- Emit heap checks, but be sure to do it lazily so
     -- that the conditionals on hpHw don't cause a black hole
-    do  { codeOnly $ do_checks checkStack checkYield hpHw do_gc
+    do  { dflags <- getDynFlags
+        ; let mb_alloc_bytes
+                 | hpHw > 0  = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))
+                 | otherwise = Nothing
+              stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)
+                      | otherwise  = Nothing
+        ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc
         ; tickyAllocHeap hpHw
         ; doGranAllocate hpHw
         ; setRealHp hpHw
         ; code }
 
-do_checks :: Bool       -- Should we check the stack?
+heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
+heapStackCheckGen stk_hwm mb_bytes
+  = do updfr_sz <- getUpdFrameOff
+       lretry <- newLabelC
+       emitLabel lretry
+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
+       do_checks stk_hwm False  mb_bytes (call <*> mkBranch lretry)
+
+do_checks :: Maybe CmmExpr    -- Should we check the stack?
           -> Bool       -- Should we check for preemption?
-          -> WordOff    -- Heap headroom
+          -> Maybe CmmExpr    -- Heap headroom (bytes)
           -> CmmAGraph  -- What to do on failure
           -> FCode ()
-do_checks checkStack checkYield alloc do_gc = do
+do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
   dflags <- getDynFlags
+  gc_id <- newLabelC
+
   let
-    alloc_lit = mkIntExpr dflags (alloc * wORD_SIZE dflags) -- Bytes
-    bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit
+    Just alloc_lit = mb_alloc_lit
+
+    bump_hp   = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit
 
     -- Sp overflow if (Sp - CmmHighStack < SpLim)
-    sp_oflo = CmmMachOp (mo_wordULt dflags)
+    sp_oflo sp_hwm =
+         CmmMachOp (mo_wordULt dflags)
                   [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))
-                             [CmmReg spReg, CmmLit CmmHighStackMark],
+                             [CmmReg spReg, sp_hwm],
                    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 dflags)
-                        [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
-
-    -- Yielding if HpLim == 0
-    yielding = CmmMachOp (mo_wordEq dflags)
-                        [CmmReg (CmmGlobal HpLim), CmmLit (zeroCLit dflags)]
+                  [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
 
     alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
-  gc_id <- newLabelC
 
-  when checkStack $ do
-     emit =<< mkCmmIfGoto sp_oflo gc_id
+  case mb_stk_hwm of
+    Nothing -> return ()
+    Just stk_hwm -> emit =<< mkCmmIfGoto (sp_oflo stk_hwm) gc_id
 
-  if (alloc /= 0)
+  if (isJust mb_alloc_lit)
     then do
-      emitAssign hpReg bump_hp
-      emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
+     emitAssign hpReg bump_hp
+     emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
     else do
-      when (not (dopt Opt_OmitYields dflags) && checkYield) (emit =<< mkCmmIfGoto yielding gc_id)
+      when (not (dopt Opt_OmitYields dflags) && checkYield) $ do
+         -- Yielding if HpLim == 0
+         let yielding = CmmMachOp (mo_wordEq dflags)
+                                  [CmmReg (CmmGlobal HpLim),
+                                   CmmLit (zeroCLit dflags)]
+         emit =<< mkCmmIfGoto yielding gc_id
 
   emitOutOfLine gc_id $
      do_gc -- this is expected to jump back somewhere
diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs
index cb60e9dd71..85f4c161ad 100644
--- a/compiler/codeGen/StgCmmHpc.hs
+++ b/compiler/codeGen/StgCmmHpc.hs
@@ -19,6 +19,8 @@ import StgCmmUtils
 import HscTypes
 import DynFlags
 
+import Control.Monad
+
 mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph
 mkTickBox dflags mod n
   = mkStore tick_box (CmmMachOp (MO_Add W64)
@@ -36,7 +38,7 @@ initHpc _ (NoHpcInfo {})
   = return ()
 initHpc this_mod (HpcInfo tickCount _hashNo)
   = do dflags <- getDynFlags
-       whenC (dopt Opt_Hpc dflags) $
+       when (dopt Opt_Hpc dflags) $
            do emitDataLits (mkHpcTicksLabel this_mod)
                            [ (CmmInt 0 W64)
                            | _ <- take tickCount [0 :: Int ..]
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 75d8d1c38f..4742332107 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -111,7 +111,7 @@ emitCall convs fun args
 --
 emitCallWithExtraStack
    :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
-   -> (ByteOff, [(CmmExpr,ByteOff)]) -> FCode ReturnKind
+   -> [CmmExpr] -> FCode ReturnKind
 emitCallWithExtraStack (callConv, retConv) fun args extra_stack
   = do	{ dflags <- getDynFlags
         ; adjustHpBackwards
@@ -124,7 +124,7 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack
             AssignTo res_regs _ -> do
               k <- newLabelC
               let area = Young k
-                  (off, copyin) = copyInOflow dflags retConv area res_regs
+                  (off, copyin) = copyInOflow dflags retConv area res_regs []
                   copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off
                                    extra_stack
               emit (copyout <*> mkLabel k <*> copyin)
@@ -222,7 +222,7 @@ direct_call caller call_conv lbl arity args
        emitCallWithExtraStack (call_conv, NativeReturn)
                               target
                               (nonVArgs fast_args)
-                              (mkStkOffsets dflags (stack_args dflags))
+                              (nonVArgs (stack_args dflags))
   where
     target = CmmLit (CmmLabel lbl)
     (fast_args, rest_args) = splitAt real_arity args
@@ -326,32 +326,7 @@ slowCallPattern []		      = (fsLit "stg_ap_0", 0)
 
 
 -------------------------------------------------------------------------
--- Fix the byte-offsets of a bunch of things to push on the stack
-
--- This is used for pushing slow-call continuations.
--- See Note [over-saturated calls].
-
-mkStkOffsets
-  :: DynFlags
-  -> [(ArgRep, Maybe CmmExpr)]    -- things to make offsets for
-  -> ( ByteOff                    -- OUTPUTS: Topmost allocated word
-     , [(CmmExpr, ByteOff)] )     -- things with offsets (voids filtered out)
-mkStkOffsets dflags things
-    = loop 0 [] (reverse things)
-  where
-    loop offset offs [] = (offset,offs)
-    loop offset offs ((_,Nothing):things) = loop offset offs things
-	-- ignore Void arguments
-    loop offset offs ((rep,Just thing):things)
-        = loop thing_off ((thing, thing_off):offs) things
-	where
-          thing_off = offset + argRepSizeW dflags rep * wORD_SIZE dflags
-	    -- offset of thing is offset+size, because we're 
-	    -- growing the stack *downwards* as the offsets increase.
-
-
--------------------------------------------------------------------------
---	Classifying arguments: ArgRep
+--      Classifying arguments: ArgRep
 -------------------------------------------------------------------------
 
 -- ArgRep is not exported (even abstractly)
@@ -472,7 +447,7 @@ mkArgDescr _nm args
        let arg_bits = argBits dflags arg_reps
            arg_reps = filter isNonV (map idArgRep args)
            -- Getting rid of voids eases matching of standard patterns
-       case stdPattern dflags arg_reps of
+       case stdPattern arg_reps of
            Just spec_id -> return (ArgSpec spec_id)
            Nothing      -> return (ArgGen arg_bits)
 
@@ -483,10 +458,9 @@ argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)
                     ++ argBits dflags args
 
 ----------------------
-stdPattern :: DynFlags -> [ArgRep] -> Maybe StgHalfWord
-stdPattern dflags reps
-  = fmap (toStgHalfWord dflags)
-  $ case reps of
+stdPattern :: [ArgRep] -> Maybe Int
+stdPattern reps
+  = case reps of
 	[]  -> Just ARG_NONE	-- just void args, probably
 	[N] -> Just ARG_N
 	[P] -> Just ARG_P
@@ -545,7 +519,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
         ; let args' = if node_points then (node : arg_regs) else arg_regs
               conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall
                                                           else NativeDirectCall
-              (offset, _) = mkCallEntry dflags conv args'
+              (offset, _) = mkCallEntry dflags conv args' []
         ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
         }
 
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index fb290d8e96..b7797bdae6 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -18,15 +18,16 @@ module StgCmmMonad (
 	FCode,	-- type
 
         initC, runC, thenC, thenFC, listCs,
-        returnFC, nopC, whenC,
+        returnFC, fixC,
 	newUnique, newUniqSupply, 
 
         newLabelC, emitLabel,
 
-	emit, emitDecl, emitProc, emitProcWithConvention, emitSimpleProc,
+        emit, emitDecl, emitProc,
+        emitProcWithConvention, emitProcWithStackFrame,
         emitOutOfLine, emitAssign, emitStore, emitComment,
 
-	getCmm, cgStmtsToBlocks,
+        getCmm, aGraphToGraph,
 	getCodeR, getCode, getHeapUsage,
 
         mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
@@ -89,7 +90,30 @@ infixr 9 `thenFC`
 
 
 --------------------------------------------------------
---	The FCode monad and its types
+-- The FCode monad and its types
+--
+-- FCode is the monad plumbed through the Stg->Cmm code generator, and
+-- the Cmm parser.  It contains the following things:
+--
+--  - A writer monad, collecting:
+--    - code for the current function, in the form of a CmmAGraph.
+--      The function "emit" appends more code to this.
+--    - the top-level CmmDecls accumulated so far
+--
+--  - A state monad with:
+--    - the local bindings in scope
+--    - the current heap usage
+--    - a UniqSupply
+--
+--  - A reader monad, for CgInfoDownwards, containing
+--    - DynFlags,
+--    - the current Module
+--    - the static top-level environmnet
+--    - the update-frame offset
+--    - the ticky counter label
+--    - the Sequel (the continuation to return to)
+
+
 --------------------------------------------------------
 
 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #))
@@ -120,13 +144,6 @@ thenC (FCode m) (FCode k) =
         FCode $ \info_down state -> case m info_down state of
                                      (# _,new_state #) -> k info_down new_state
 
-nopC :: FCode ()
-nopC = return ()
-
-whenC :: Bool -> FCode () -> FCode ()
-whenC True  code  = code
-whenC False _code = nopC
-
 listCs :: [FCode ()] -> FCode ()
 listCs [] = return ()
 listCs (fc:fcs) = do
@@ -141,6 +158,15 @@ thenFC (FCode m) k = FCode $
                  case k m_result of
                    FCode kcode -> kcode info_down new_state
 
+fixC :: (a -> FCode a) -> FCode a
+fixC fcode = FCode (
+	\info_down state -> 
+		let
+                        (v,s) = doFCode (fcode v) info_down state
+                in
+                        (# v, s #)
+	)
+
 --------------------------------------------------------
 --	The code generator environment
 --------------------------------------------------------
@@ -478,7 +504,7 @@ getSequel = do  { info <- getInfoDown
 -- Note: I'm including the size of the original return address
 -- in the size of the update frame -- hence the default case on `get'.
 
-withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode ()
+withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
 withUpdFrameOff size code
   = do	{ info  <- getInfoDown
 	; withInfoDown code (info {cgd_updfr_off = size }) }
@@ -675,31 +701,60 @@ emitDecl decl
 emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
 emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
 
+emitProcWithStackFrame
+   :: Convention                        -- entry convention
+   -> Maybe CmmInfoTable                -- info table?
+   -> CLabel                            -- label for the proc
+   -> [CmmFormal]                       -- stack frame
+   -> [CmmFormal]                       -- arguments
+   -> CmmAGraph                         -- code
+   -> Bool                              -- do stack layout?
+   -> FCode ()
+
+emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
+  = do  { dflags <- getDynFlags
+        ; emitProc_ mb_info lbl blocks (widthInBytes (wordWidth dflags)) False
+        }
+emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout
+  = do  { dflags <- getDynFlags
+        ; let (offset, entry) = mkCallEntry dflags conv args stk_args
+        ; emitProc_ mb_info lbl (entry <*> blocks) offset True
+        }
+emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
+
 emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
-                       -> [CmmFormal] -> CmmAGraph -> FCode ()
+                       -> [CmmFormal]
+                       -> CmmAGraph
+                       -> FCode ()
 emitProcWithConvention conv mb_info lbl args blocks
+  = emitProcWithStackFrame conv mb_info lbl [] args blocks True
+
+emitProc :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> FCode ()
+emitProc  mb_info lbl blocks offset
+ = emitProc_ mb_info lbl blocks offset True
+
+emitProc_ :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> Bool
+          -> FCode ()
+emitProc_ mb_info lbl blocks offset do_layout
   = do  { dflags <- getDynFlags
-        ; us <- newUniqSupply
-        ; let (offset, entry) = mkCallEntry dflags conv args
-              blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
-        ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just (initUpdFrameOff dflags)}
-              tinfo = TopInfo {info_tbls = infos, stack_info=sinfo}
-              proc_block = CmmProc tinfo lbl blks
+        ; l <- newLabelC
+        ; let
+              blks = labelAGraph l blocks
 
-              infos | Just info <- mb_info
-                    = mapSingleton (g_entry blks) info
-                    | otherwise
-                    = mapEmpty
+              infos | Just info <- mb_info = mapSingleton (g_entry blks) info
+                    | otherwise            = mapEmpty
 
-        ; state <- getState
-        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+              sinfo = StackInfo { arg_space = offset
+                                , updfr_space = Just (initUpdFrameOff dflags)
+                                , do_layout = do_layout }
+
+              tinfo = TopInfo { info_tbls = infos
+                              , stack_info=sinfo}
 
-emitProc :: Maybe CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode ()
-emitProc = emitProcWithConvention NativeNodeCall
+              proc_block = CmmProc tinfo lbl blks
 
-emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
-emitSimpleProc lbl code = 
-  emitProc Nothing lbl [] code
+        ; state <- getState
+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 
 getCmm :: FCode () -> FCode CmmGroup
 -- Get all the CmmTops (there should be no stmts)
@@ -735,29 +790,25 @@ mkCmmIfThen e tbranch = do
 
 
 mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
-       -> UpdFrameOffset -> (ByteOff,[(CmmExpr,ByteOff)]) -> FCode CmmAGraph
+       -> UpdFrameOffset -> [CmmActual] -> FCode CmmAGraph
 mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
   dflags <- getDynFlags
   k <- newLabelC
   let area = Young k
-      (off, copyin) = copyInOflow dflags retConv area results
+      (off, copyin) = copyInOflow dflags retConv area results []
       copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
   return (copyout <*> mkLabel k <*> copyin)
 
 mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
           -> FCode CmmAGraph
 mkCmmCall f results actuals updfr_off
-   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off (0,[])
+   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []
 
 
 -- ----------------------------------------------------------------------------
--- CgStmts
-
--- These functions deal in terms of CgStmts, which is an abstract type
--- representing the code in the current proc.
+-- turn CmmAGraph into CmmGraph, for making a new proc.
 
--- turn CgStmts into [CmmBasicBlock], for making a new proc.
-cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
-cgStmtsToBlocks stmts
-  = do  { us <- newUniqSupply
-	; return (initUs_ us (lgraphOfAGraph stmts)) }	
+aGraphToGraph :: CmmAGraph -> FCode CmmGraph
+aGraphToGraph stmts
+  = do  { l <- newLabelC
+        ; return (labelAGraph l stmts) }
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index cbb2aa70bd..97104ce4a2 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -97,7 +97,7 @@ cgOpApp (StgPrimOp primop) args res_ty
   | primOpOutOfLine primop
   = do	{ cmm_args <- getNonVoidArgAmodes args
         ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
-        ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args }
+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
 
   | ReturnsPrim VoidRep <- result_info
   = do cgPrimOp [] primop args 
@@ -130,7 +130,7 @@ cgOpApp (StgPrimOp primop) args res_ty
 cgOpApp (StgPrimCallOp primcall) args _res_ty
   = do	{ cmm_args <- getNonVoidArgAmodes args
         ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
-        ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args }
+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
 
 ---------------------------------------------------
 cgPrimOp   :: [LocalReg]	-- where to put the results
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index b666554403..1b218462e1 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -82,24 +82,22 @@ costCentreFrom :: DynFlags
 	       -> CmmExpr	-- The cost centre from that closure
 costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)
 
+-- | The profiling header words in a static closure
 staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
--- The profiling header words in a static closure
--- Was SET_STATIC_PROF_HDR
 staticProfHdr dflags ccs
  = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]
 
+-- | Profiling header words in a dynamic closure
 dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
--- Profiling header words in a dynamic closure
 dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
 
-initUpdFrameProf :: ByteOff -> FCode ()
--- Initialise the profiling field of an update frame
-initUpdFrameProf frame_off
+-- | Initialise the profiling field of an update frame
+initUpdFrameProf :: CmmExpr -> FCode ()
+initUpdFrameProf frame
   = ifProfiling $	-- frame->header.prof.ccs = CCCS
     do dflags <- getDynFlags
-       emitStore (CmmStackSlot Old (frame_off - oFFSET_StgHeader_ccs dflags))
-                 curCCS
-	-- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) 
+       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS
+        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
 	-- is unnecessary because it is not used anyhow.
 
 ---------------------------------------------------------------------------
@@ -200,7 +198,7 @@ ifProfiling code
   = do dflags <- getDynFlags
        if dopt Opt_SccProfilingOn dflags
            then code
-           else nopC
+           else return ()
 
 ifProfilingL :: DynFlags -> [a] -> [a]
 ifProfilingL dflags xs
@@ -216,7 +214,7 @@ initCostCentres :: CollectedCCs -> FCode ()
 -- Emit the declarations
 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
   = do dflags <- getDynFlags
-       whenC (dopt Opt_SccProfilingOn dflags) $
+       when (dopt Opt_SccProfilingOn dflags) $
            do mapM_ emitCostCentreDecl local_CCs
               mapM_ emitCostCentreStackDecl singleton_CCSs
 
@@ -283,7 +281,7 @@ emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
 emitSetCCC cc tick push
  = do dflags <- getDynFlags
       if not (dopt Opt_SccProfilingOn dflags)
-          then nopC
+          then return ()
           else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW
                   pushCostCentre tmp curCCS cc
                   when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
@@ -321,7 +319,7 @@ dynLdvInit :: DynFlags -> CmmExpr
 dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE  
   CmmMachOp (mo_wordOr dflags) [
       CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
-      CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags))
+      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))
   ]
         
 --
@@ -350,8 +348,8 @@ ldvEnter cl_ptr = do
     let -- don't forget to substract node's tag
         ldv_wd = ldvWord dflags cl_ptr
         new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
-                                                         (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags))))
-                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags))))
+                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
+                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))
     ifProfiling $
          -- if (era > 0) {
          --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
@@ -371,10 +369,3 @@ ldvWord :: DynFlags -> CmmExpr -> CmmExpr
 ldvWord dflags closure_ptr
     = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
 
-lDV_CREATE_MASK :: DynFlags -> StgWord
-lDV_CREATE_MASK dflags = toStgWord dflags (iLDV_CREATE_MASK dflags)
-lDV_STATE_CREATE :: DynFlags -> StgWord
-lDV_STATE_CREATE dflags = toStgWord dflags (iLDV_STATE_CREATE dflags)
-lDV_STATE_USE :: DynFlags -> StgWord
-lDV_STATE_USE dflags = toStgWord dflags (iLDV_STATE_USE dflags)
-
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 79ad3ff822..01babb212f 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -333,7 +333,7 @@ tickyAllocHeap hp
 ifTicky :: FCode () -> FCode ()
 ifTicky code = do dflags <- getDynFlags
                   if dopt Opt_Ticky dflags then code
-                                           else nopC
+                                           else return ()
 
 -- All the ticky-ticky counters are declared "unsigned long" in C
 bumpTickyCounter :: FastString -> FCode ()
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 386e7f46d6..138e00ee52 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -36,7 +36,6 @@ module StgCmmUtils (
         addToMem, addToMemE, addToMemLbl,
         mkWordCLit,
         newStringCLit, newByteStringCLit,
-        packHalfWordsCLit,
         blankWord
   ) where
 
@@ -196,9 +195,9 @@ emitRtsCallGen res pkg fun args safe
     call updfr_off =
       if safe then
         emit =<< mkCmmCall fun_expr res' args' updfr_off
-      else
-        emit $ mkUnsafeCall (ForeignTarget fun_expr
-                         (ForeignConvention CCallConv arg_hints res_hints)) res' args'
+      else do
+        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
+        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
     (args', arg_hints) = unzip args
     (res',  res_hints) = unzip res
     fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)