add a comment
[ghc.git] / compiler / cmm / CmmParse.y
index 8c3559b..8033330 100644 (file)
 -----------------------------------------------------------------------------
 --
--- (c) The University of Glasgow, 2004-2006
+-- (c) The University of Glasgow, 2004-2012
 --
 -- Parser for concrete Cmm.
--- This doesn't just parse the Cmm file, we also do some code generation
--- along the way for switches and foreign calls etc.
 --
 -----------------------------------------------------------------------------
 
--- TODO: Add support for interruptible/uninterruptible foreign call specification
+{- -----------------------------------------------------------------------------
+Note [Syntax of .cmm files]
+
+NOTE: You are very much on your own in .cmm.  There is very little
+error checking at all:
+
+  * Type errors are detected by the (optional) -dcmm-lint pass, if you
+    don't turn this on then a type error will likely result in a panic
+    from the native code generator.
+
+  * Passing the wrong number of arguments or arguments of the wrong
+    type is not detected.
+
+There are two ways to write .cmm code:
+
+ (1) High-level Cmm code delegates the stack handling to GHC, and
+     never explicitly mentions Sp or registers.
+
+ (2) Low-level Cmm manages the stack itself, and must know about
+     calling conventions.
+
+Whether you want high-level or low-level Cmm is indicated by the
+presence of an argument list on a procedure.  For example:
+
+foo ( gcptr a, bits32 b )
+{
+  // this is high-level cmm code
+
+  if (b > 0) {
+     // we can make tail calls passing arguments:
+     jump stg_ap_0_fast(a);
+  }
+
+  push (stg_upd_frame_info, a) {
+    // stack frames can be explicitly pushed
+
+    (x,y) = call wibble(a,b,3,4);
+      // calls pass arguments and return results using the native
+      // Haskell calling convention.  The code generator will automatically
+      // construct a stack frame and an info table for the continuation.
+
+    return (x,y);
+      // we can return multiple values from the current proc
+  }
+}
+
+bar
+{
+  // this is low-level cmm code, indicated by the fact that we did not
+  // put an argument list on bar.
+
+  x = R1;  // the calling convention is explicit: better be careful
+           // that this works on all platforms!
+
+  jump %ENTRY_CODE(Sp(0))
+}
+
+Here is a list of rules for high-level and low-level code.  If you
+break the rules, you get a panic (for using a high-level construct in
+a low-level proc), or wrong code (when using low-level code in a
+high-level proc).  This stuff isn't checked! (TODO!)
+
+High-level only:
+
+  - tail-calls with arguments, e.g.
+    jump stg_fun (arg1, arg2);
+
+  - function calls:
+    (ret1,ret2) = call stg_fun (arg1, arg2);
+
+    This makes a call with the NativeNodeCall convention, and the
+    values are returned to the following code using the NativeReturn
+    convention.
+
+  - returning:
+    return (ret1, ret2)
+
+    These use the NativeReturn convention to return zero or more
+    results to the caller.
+
+  - pushing stack frames:
+    push (info_ptr, field1, ..., fieldN) { ... statements ... }
+
+  - reserving temporary stack space:
+
+      reserve N = x { ... }
+
+    this reserves an area of size N (words) on the top of the stack,
+    and binds its address to x (a local register).  Typically this is
+    used for allocating temporary storage for passing to foreign
+    functions.
+
+    Note that if you make any native calls or invoke the GC in the
+    scope of the reserve block, you are responsible for ensuring that
+    the stack you reserved is laid out correctly with an info table.
+
+Low-level only:
+
+  - References to Sp, R1-R8, F1-F4 etc.
+
+    NB. foreign calls may clobber the argument registers R1-R8, F1-F4
+    etc., so ensure they are saved into variables around foreign
+    calls.
+
+  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp
+    directly.
+
+Both high-level and low-level code can use a raw tail-call:
+
+    jump stg_fun [R1,R2]
+
+NB. you *must* specify the list of GlobalRegs that are passed via a
+jump, otherwise the register allocator will assume that all the
+GlobalRegs are dead at the jump.
+
+
+Calling Conventions
+-------------------
+
+High-level procedures use the NativeNode calling convention, or the
+NativeReturn convention if the 'return' keyword is used (see Stack
+Frames below).
+
+Low-level procedures implement their own calling convention, so it can
+be anything at all.
+
+If a low-level procedure implements the NativeNode calling convention,
+then it can be called by high-level code using an ordinary function
+call.  In general this is hard to arrange because the calling
+convention depends on the number of physical registers available for
+parameter passing, but there are two cases where the calling
+convention is platform-independent:
+
+ - Zero arguments.
+
+ - One argument of pointer or non-pointer word type; this is always
+   passed in R1 according to the NativeNode convention.
+
+ - Returning a single value; these conventions are fixed and platform
+   independent.
+
+
+Stack Frames
+------------
+
+A stack frame is written like this:
+
+INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )
+               return ( arg1, ..., argM )
+{
+  ... code ...
+}
+
+where field1 ... fieldN are the fields of the stack frame (with types)
+arg1...argN are the values returned to the stack frame (with types).
+The return values are assumed to be passed according to the
+NativeReturn convention.
+
+On entry to the code, the stack frame looks like:
+
+   |----------|
+   | fieldN   |
+   |   ...    |
+   | field1   |
+   |----------|
+   | info_ptr |
+   |----------|
+   |  argN    |
+   |   ...    | <- Sp
+
+and some of the args may be in registers.
+
+We prepend the code by a copyIn of the args, and assign all the stack
+frame fields to their formals.  The initial "arg offset" for stack
+layout purposes consists of the whole stack frame plus any args that
+might be on the stack.
+
+A tail-call may pass a stack frame to the callee using the following
+syntax:
+
+jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)
+
+where info_ptr and field1..fieldN describe the stack frame, and
+arg1..argN are the arguments passed to f using the NativeNodeCall
+convention.
+
+----------------------------------------------------------------------------- -}
 
 {
 {-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module CmmParse ( parseCmmFile ) where
 
-import CgMonad
-import CgExtCode
-import CgHeapery
-import CgUtils
-import CgProf
-import CgTicky
-import CgInfoTbls
-import CgForeignCall
-import CgTailCall
-import CgStackery
-import ClosureInfo
-import CgCallConv
-import CgClosure
-import CostCentre
-
-import BlockId
-import OldCmm
-import OldPprCmm()
+import StgCmmExtCode
+import CmmCallConv
+import StgCmmProf
+import StgCmmHeap
+import StgCmmMonad hiding ( getCode, getCodeR, emitLabel, emit, emitStore
+                          , emitAssign, emitOutOfLine, withUpdFrameOff
+                          , getUpdFrameOff )
+import qualified StgCmmMonad as F
+import StgCmmUtils
+import StgCmmForeign
+import StgCmmExpr
+import StgCmmClosure
+import StgCmmLayout     hiding (ArgRep(..))
+import StgCmmTicky
+import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )
+
+import CmmOpt
+import MkGraph
+import Cmm
 import CmmUtils
+import CmmInfo
+import BlockId
 import CmmLex
 import CLabel
 import SMRep
 import Lexer
 
+import CostCentre
 import ForeignCall
 import Module
 import Platform
@@ -68,6 +256,7 @@ import Control.Monad
 import Data.Array
 import Data.Char        ( ord )
 import System.Exit
+import Data.Maybe
 
 #include "HsVersions.h"
 }
@@ -110,41 +299,47 @@ import System.Exit
         '&&'    { L _ (CmmT_BoolAnd) }
         '||'    { L _ (CmmT_BoolOr) }
 
-        'CLOSURE'               { L _ (CmmT_CLOSURE) }
-        'INFO_TABLE'            { L _ (CmmT_INFO_TABLE) }
-        'INFO_TABLE_RET'        { L _ (CmmT_INFO_TABLE_RET) }
-        'INFO_TABLE_FUN'        { L _ (CmmT_INFO_TABLE_FUN) }
-        'INFO_TABLE_CONSTR'     { L _ (CmmT_INFO_TABLE_CONSTR) }
-        'INFO_TABLE_SELECTOR'   { L _ (CmmT_INFO_TABLE_SELECTOR) }
-        'else'                  { L _ (CmmT_else) }
-        'export'                { L _ (CmmT_export) }
-        'section'               { L _ (CmmT_section) }
-        'align'                 { L _ (CmmT_align) }
-        'goto'                  { L _ (CmmT_goto) }
-        'if'                    { L _ (CmmT_if) }
-        'jump'                  { L _ (CmmT_jump) }
-        'foreign'               { L _ (CmmT_foreign) }
-        'never'                 { L _ (CmmT_never) }
-        'prim'                  { L _ (CmmT_prim) }
-        'return'                { L _ (CmmT_return) }
-        'returns'               { L _ (CmmT_returns) }
-        'import'                { L _ (CmmT_import) }
-        'switch'                { L _ (CmmT_switch) }
-        'case'                  { L _ (CmmT_case) }
-        'default'               { L _ (CmmT_default) }
-        'bits8'                 { L _ (CmmT_bits8) }
-        'bits16'                { L _ (CmmT_bits16) }
-        'bits32'                { L _ (CmmT_bits32) }
-        'bits64'                { L _ (CmmT_bits64) }
-        'float32'               { L _ (CmmT_float32) }
-        'float64'               { L _ (CmmT_float64) }
-        'gcptr'                 { L _ (CmmT_gcptr) }
-
-        GLOBALREG               { L _ (CmmT_GlobalReg   $$) }
-        NAME                    { L _ (CmmT_Name        $$) }
-        STRING                  { L _ (CmmT_String      $$) }
-        INT                     { L _ (CmmT_Int         $$) }
-        FLOAT                   { L _ (CmmT_Float       $$) }
+        'CLOSURE'       { L _ (CmmT_CLOSURE) }
+        'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
+        'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
+        'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
+        'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
+        'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
+        'else'          { L _ (CmmT_else) }
+        'export'        { L _ (CmmT_export) }
+        'section'       { L _ (CmmT_section) }
+        'align'         { L _ (CmmT_align) }
+        'goto'          { L _ (CmmT_goto) }
+        'if'            { L _ (CmmT_if) }
+        'call'          { L _ (CmmT_call) }
+        'jump'          { L _ (CmmT_jump) }
+        'foreign'       { L _ (CmmT_foreign) }
+        'never'         { L _ (CmmT_never) }
+        'prim'          { L _ (CmmT_prim) }
+        'reserve'       { L _ (CmmT_reserve) }
+        'return'        { L _ (CmmT_return) }
+        'returns'       { L _ (CmmT_returns) }
+        'import'        { L _ (CmmT_import) }
+        'switch'        { L _ (CmmT_switch) }
+        'case'          { L _ (CmmT_case) }
+        'default'       { L _ (CmmT_default) }
+        'push'          { L _ (CmmT_push) }
+        'bits8'         { L _ (CmmT_bits8) }
+        'bits16'        { L _ (CmmT_bits16) }
+        'bits32'        { L _ (CmmT_bits32) }
+        'bits64'        { L _ (CmmT_bits64) }
+        'bits128'       { L _ (CmmT_bits128) }
+        'bits256'       { L _ (CmmT_bits256) }
+        'bits512'       { L _ (CmmT_bits512) }
+        'float32'       { L _ (CmmT_float32) }
+        'float64'       { L _ (CmmT_float64) }
+        'gcptr'         { L _ (CmmT_gcptr) }
+
+        GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
+        NAME            { L _ (CmmT_Name        $$) }
+        STRING          { L _ (CmmT_String      $$) }
+        INT             { L _ (CmmT_Int         $$) }
+        FLOAT           { L _ (CmmT_Float       $$) }
 
 %monad { P } { >>= } { return }
 %lexer { cmmlex } { L _ CmmT_EOF }
@@ -166,16 +361,16 @@ import System.Exit
 
 %%
 
-cmm     :: { ExtCode }
+cmm     :: { CmmParse () }
         : {- empty -}                   { return () }
         | cmmtop cmm                    { do $1; $2 }
 
-cmmtop  :: { ExtCode }
+cmmtop  :: { CmmParse () }
         : cmmproc                       { $1 }
         | cmmdata                       { $1 }
-        | decl                          { $1 }
-        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
-                {% withThisPackage $ \pkg ->
+        | decl                          { $1 } 
+        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
+                {% withThisPackage $ \pkg -> 
                    do lits <- sequence $6;
                       staticClosure pkg $3 $5 (map getLit lits) }
 
@@ -188,37 +383,37 @@ cmmtop  :: { ExtCode }
 --      * payload is always empty
 --      * we can derive closure and info table labels from a single NAME
 
-cmmdata :: { ExtCode }
-        : 'section' STRING '{' data_label statics '}'
+cmmdata :: { CmmParse () }
+        : 'section' STRING '{' data_label statics '}' 
                 { do lbl <- $4;
                      ss <- sequence $5;
                      code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) }
 
-data_label :: { ExtFCode CLabel }
-    : NAME ':'
-                {% withThisPackage $ \pkg ->
+data_label :: { CmmParse CLabel }
+    : NAME ':'  
+                {% withThisPackage $ \pkg -> 
                    return (mkCmmDataLabel pkg $1) }
 
-statics :: { [ExtFCode [CmmStatic]] }
+statics :: { [CmmParse [CmmStatic]] }
         : {- empty -}                   { [] }
         | static statics                { $1 : $2 }
-
+    
 -- Strings aren't used much in the RTS HC code, so it doesn't seem
 -- worth allowing inline strings.  C-- doesn't allow them anyway.
-static  :: { ExtFCode [CmmStatic] }
+static  :: { CmmParse [CmmStatic] }
         : type expr ';' { do e <- $2;
                              return [CmmStaticLit (getLit e)] }
         | type ';'                      { return [CmmUninitialised
                                                         (widthInBytes (typeWidth $1))] }
         | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
-        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised
+        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised 
                                                         (fromIntegral $3)] }
-        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised
-                                                (widthInBytes (typeWidth $1) *
+        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised 
+                                                (widthInBytes (typeWidth $1) * 
                                                         fromIntegral $3)] }
         | 'CLOSURE' '(' NAME lits ')'
                 { do { lits <- sequence $4
-             ; dflags <- getDynFlags
+                ; dflags <- getDynFlags
                      ; return $ map CmmStaticLit $
                         mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
                          -- mkForeignLabel because these are only used
@@ -226,137 +421,137 @@ static  :: { ExtFCode [CmmStatic] }
                         dontCareCCS (map getLit lits) [] [] [] } }
         -- arrays of closures required for the CHARLIKE & INTLIKE arrays
 
-lits    :: { [ExtFCode CmmExpr] }
+lits    :: { [CmmParse CmmExpr] }
         : {- empty -}           { [] }
         | ',' expr lits         { $2 : $3 }
 
-cmmproc :: { ExtCode }
--- TODO: add real SRT/info tables to parsed Cmm
-        : info maybe_formals_without_hints '{' body '}'
-                { do ((entry_ret_label, info, live, formals), stmts) <-
-                       getCgStmtsEC' $ loopDecls $ do {
-                         (entry_ret_label, info, live) <- $1;
-                         formals <- sequence $2;
+cmmproc :: { CmmParse () }
+        : info maybe_conv maybe_formals maybe_body
+                { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
+                       getCodeR $ loopDecls $ do {
+                         (entry_ret_label, info, stk_formals) <- $1;
+                         formals <- sequence (fromMaybe [] $3);
                          $4;
-                         return (entry_ret_label, info, live, formals) }
-                     blks <- code (cgStmtsToBlocks stmts)
-                     code (emitInfoTableAndCode entry_ret_label info formals blks) }
+                         return (entry_ret_label, info, stk_formals, formals) }
+                     let do_layout = isJust $3
+                     code (emitProcWithStackFrame $2 info
+                                entry_ret_label stk_formals formals agraph
+                                do_layout ) }
 
-        | info maybe_formals_without_hints ';'
-                { do (entry_ret_label, info, live) <- $1;
-                     formals <- sequence $2;
-                     code (emitInfoTableAndCode entry_ret_label info formals []) }
+maybe_conv :: { Convention }
+           : {- empty -}        { NativeNodeCall }
+           | 'return'           { NativeReturn }
 
-        | NAME maybe_formals_without_hints '{' body '}'
+maybe_body :: { CmmParse () }
+           : ';'                { return () }
+           | '{' body '}'       { $2 }
+
+info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
+        : NAME
                 {% withThisPackage $ \pkg ->
                    do   newFunctionName $1 pkg
-                        (formals, stmts) <-
-                                getCgStmtsEC' $ loopDecls $ do {
-                                        formals <- sequence $2;
-                                        $4;
-                                        return formals }
-                        blks <- code (cgStmtsToBlocks stmts)
-                        code (emitProc Nothing (mkCmmCodeLabel pkg $1) formals blks) }
-
-info    :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-        : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' STRING ',' STRING ')'
+                        return (mkCmmCodeLabel pkg $1, Nothing, []) }
+
+
+        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- ptrs, nptrs, closure type, description, type
                 {% withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $11 $13
-                          rep  = mkRTSRep $9 $
+                          rep  = mkRTSRep (fromIntegral $9) $
                                    mkHeapRep dflags False (fromIntegral $5)
                                                    (fromIntegral $7) Thunk
                               -- not really Thunk, but that makes the info table
                               -- we want.
                       return (mkCmmEntryLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
                                            , cit_prof = prof, cit_srt = NoC_SRT },
                               []) }
-
-        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' STRING ',' STRING ',' stgHalfWord ')'
+        
+        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
                 -- ptrs, nptrs, closure type, description, type, fun type
-                {% withThisPackage $ \pkg ->
+                {% withThisPackage $ \pkg -> 
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $11 $13
-                          ty   = Fun (toStgHalfWord dflags 0) (ArgSpec $15)
+                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
                                 -- Arity zero, arg_type $15
-                          rep = mkRTSRep $9 $
+                          rep = mkRTSRep (fromIntegral $9) $
                                     mkHeapRep dflags False (fromIntegral $5)
                                                     (fromIntegral $7) ty
                       return (mkCmmEntryLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
                                            , cit_prof = prof, cit_srt = NoC_SRT },
                               []) }
                 -- we leave most of the fields zero here.  This is only used
                 -- to generate the BCO info table in the RTS at the moment.
 
-        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' stgHalfWord ',' STRING ',' STRING ')'
+        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- ptrs, nptrs, tag, closure type, description, type
                 {% withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $13 $15
-                          ty  = Constr $9  -- Tag
+                          ty  = Constr (fromIntegral $9)  -- Tag
                                        (stringToWord8s $13)
-                          rep = mkRTSRep $11 $
+                          rep = mkRTSRep (fromIntegral $11) $
                                   mkHeapRep dflags False (fromIntegral $5)
                                                   (fromIntegral $7) ty
                       return (mkCmmEntryLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
                                            , cit_prof = prof, cit_srt = NoC_SRT },
                               []) }
 
                      -- If profiling is on, this string gets duplicated,
                      -- but that's the way the old code did it we can fix it some other time.
-
-        | 'INFO_TABLE_SELECTOR' '(' NAME ',' stgWord ',' stgHalfWord ',' STRING ',' STRING ')'
+        
+        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- selector, closure type, description, type
                 {% withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $9 $11
-                          ty  = ThunkSelector $5
-                          rep = mkRTSRep $7 $
+                          ty  = ThunkSelector (fromIntegral $5)
+                          rep = mkRTSRep (fromIntegral $7) $
                                    mkHeapRep dflags False 0 0 ty
                       return (mkCmmEntryLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
                                            , cit_prof = prof, cit_srt = NoC_SRT },
                               []) }
 
-        | 'INFO_TABLE_RET' '(' NAME ',' stgHalfWord ')'
+        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
                 -- closure type (no live regs)
                 {% withThisPackage $ \pkg ->
                    do let prof = NoProfilingInfo
-                          rep  = mkRTSRep $5 $ mkStackRep []
+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
                       return (mkCmmRetLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
                                            , cit_rep = rep
                                            , cit_prof = prof, cit_srt = NoC_SRT },
                               []) }
 
-        | 'INFO_TABLE_RET' '(' NAME ',' stgHalfWord ',' formals_without_hints0 ')'
+        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
                 -- closure type, live regs
                 {% withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
-                      live <- sequence (map (liftM Just) $7)
+                      live <- sequence $7
                       let prof = NoProfilingInfo
-                          bitmap = mkLiveness dflags live
-                          rep  = mkRTSRep $5 $ mkStackRep bitmap
+                          -- drop one for the info pointer
+                          bitmap = mkLiveness dflags (map Just (drop 1 live))
+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
                       return (mkCmmRetLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
                                            , cit_rep = rep
                                            , cit_prof = prof, cit_srt = NoC_SRT },
-                              []) }
+                              live) }
 
-body    :: { ExtCode }
+body    :: { CmmParse () }
         : {- empty -}                   { return () }
         | decl body                     { do $1; $2 }
         | stmt body                     { do $1; $2 }
 
-decl    :: { ExtCode }
+decl    :: { CmmParse () }
         : type names ';'                { mapM_ (newLocal $1) $2 }
         | 'import' importNames ';'      { mapM_ newImport $2 }
         | 'export' names ';'            { return () }  -- ignore exports
@@ -373,39 +568,41 @@ importName
 
         -- A label imported without an explicit packageId.
         --      These are taken to come frome some foreign, unnamed package.
-        : NAME
+        : NAME  
         { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
 
         -- A label imported with an explicit packageId.
         | STRING NAME
-        { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
-
-
+        { ($2, mkCmmCodeLabel (fsToPackageKey (mkFastString $1)) $2) }
+        
+        
 names   :: { [FastString] }
         : NAME                          { [$1] }
         | NAME ',' names                { $1 : $3 }
 
-stmt    :: { ExtCode }
-        : ';'                                   { nopEC }
+stmt    :: { CmmParse () }
+        : ';'                                   { return () }
 
         | NAME ':'
-                { do l <- newLabel $1; code (labelC l) }
+                { do l <- newLabel $1; emitLabel l }
+
+
 
         | lreg '=' expr ';'
-                { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
+                { do reg <- $1; e <- $3; emitAssign reg e }
         | type '[' expr ']' '=' expr ';'
                 { doStore $1 $3 $6 }
 
-        -- Gah! We really want to say "maybe_results" but that causes
+        -- Gah! We really want to say "foreign_results" but that causes
         -- a shift/reduce conflict with assignment.  We either
         -- we expand out the no-result and single result cases or
         -- we tweak the syntax to avoid the conflict.  The later
         -- option is taken here because the other way would require
         -- multiple levels of expanding and get unwieldy.
-        | maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';'
-                {% foreignCall $3 $1 $4 $6 $9 $8 $10 }
-        | maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';'
-                {% primCall $1 $4 $6 $9 $8 }
+        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
+                {% foreignCall $3 $1 $4 $6 $8 $9 }
+        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
+                {% primCall $1 $4 $6 }
         -- stmt-level macros, stealing syntax from ordinary C-- function calls.
         -- Perhaps we ought to use the %%-form?
         | NAME '(' exprs0 ')' ';'
@@ -413,42 +610,58 @@ stmt    :: { ExtCode }
         | 'switch' maybe_range expr '{' arms default '}'
                 { do as <- sequence $5; doSwitch $2 $3 as $6 }
         | 'goto' NAME ';'
-                { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
+                { do l <- lookupLabel $2; emit (mkBranch l) }
+        | 'return' '(' exprs0 ')' ';'
+                { doReturn $3 }
         | 'jump' expr vols ';'
-                { do e <- $2; stmtEC (CmmJump e $3) }
-        | 'return' ';'
-                { stmtEC CmmReturn }
+                { doRawJump $2 $3 }
+        | 'jump' expr '(' exprs0 ')' ';'
+                { doJumpWithStack $2 [] $4 }
+        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'
+                { doJumpWithStack $2 $4 $7 }
+        | 'call' expr '(' exprs0 ')' ';'
+                { doCall $2 [] $4 }
+        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
+                { doCall $6 $2 $8 }
         | 'if' bool_expr 'goto' NAME
                 { do l <- lookupLabel $4; cmmRawIf $2 l }
-        | 'if' bool_expr '{' body '}' else
+        | 'if' bool_expr '{' body '}' else      
                 { cmmIfThenElse $2 $4 $6 }
+        | 'push' '(' exprs0 ')' maybe_body
+                { pushStackFrame $3 $5 }
+        | 'reserve' expr '=' lreg maybe_body
+                { reserveStackFrame $2 $4 $5 }
+
+foreignLabel     :: { CmmParse CmmExpr }
+        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
 
 opt_never_returns :: { CmmReturnInfo }
         :                               { CmmMayReturn }
         | 'never' 'returns'             { CmmNeverReturns }
 
-bool_expr :: { ExtFCode BoolExpr }
+bool_expr :: { CmmParse BoolExpr }
         : bool_op                       { $1 }
         | expr                          { do e <- $1; return (BoolTest e) }
 
-bool_op :: { ExtFCode BoolExpr }
-        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
+bool_op :: { CmmParse BoolExpr }
+        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
                                           return (BoolAnd e1 e2) }
-        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
+        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
                                           return (BoolOr e1 e2)  }
         | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
         | '(' bool_op ')'               { $2 }
 
--- This is not C-- syntax.  What to do?
-safety  :: { CmmSafety }
-        : {- empty -}                   { CmmUnsafe } -- Default may change soon
+safety  :: { Safety }
+        : {- empty -}                   { PlayRisky }
         | STRING                        {% parseSafety $1 }
 
--- This is not C-- syntax.  What to do?
-vols    :: { Maybe [GlobalReg] }
-        : {- empty -}                   { Nothing }
-        | '[' ']'                       { Just [] }
-        | '[' globals ']'               { Just $2 }
+vols    :: { [GlobalReg] }
+        : '[' ']'                       { [] }
+        | '[' '*' ']'                   {% do df <- getDynFlags
+                                         ; return (realArgRegsCover df) }
+                                           -- All of them. See comment attached
+                                           -- to realArgRegsCover
+        | '[' globals ']'               { $2 }
 
 globals :: { [GlobalReg] }
         : GLOBALREG                     { [$1] }
@@ -458,14 +671,14 @@ maybe_range :: { Maybe (Int,Int) }
         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
         | {- empty -}           { Nothing }
 
-arms    :: { [ExtFCode ([Int],Either BlockId ExtCode)] }
+arms    :: { [CmmParse ([Int],Either BlockId (CmmParse ()))] }
         : {- empty -}                   { [] }
         | arm arms                      { $1 : $2 }
 
-arm     :: { ExtFCode ([Int],Either BlockId ExtCode) }
+arm     :: { CmmParse ([Int],Either BlockId (CmmParse ())) }
         : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
 
-arm_body :: { ExtFCode (Either BlockId ExtCode) }
+arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
         : '{' body '}'                  { return (Right $2) }
         | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
 
@@ -473,7 +686,7 @@ ints    :: { [Int] }
         : INT                           { [ fromIntegral $1 ] }
         | INT ',' ints                  { fromIntegral $1 : $3 }
 
-default :: { Maybe ExtCode }
+default :: { Maybe (CmmParse ()) }
         : 'default' ':' '{' body '}'    { Just $4 }
         -- taking a few liberties with the C-- syntax here; C-- doesn't have
         -- 'default' branches
@@ -481,13 +694,13 @@ default :: { Maybe ExtCode }
 
 -- Note: OldCmm doesn't support a first class 'else' statement, though
 -- CmmNode does.
-else    :: { ExtCode }
-        : {- empty -}                   { nopEC }
+else    :: { CmmParse () }
+        : {- empty -}                   { return () }
         | 'else' '{' body '}'           { $3 }
 
 -- we have to write this out longhand so that Happy's precedence rules
 -- can kick in.
-expr    :: { ExtFCode CmmExpr }
+expr    :: { CmmParse CmmExpr }
         : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
         | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
         | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
@@ -510,10 +723,10 @@ expr    :: { ExtFCode CmmExpr }
                                                 return (mkMachOp mo [$1,$5]) } }
         | expr0                         { $1 }
 
-expr0   :: { ExtFCode CmmExpr }
+expr0   :: { CmmParse CmmExpr }
         : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
         | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
-        | STRING                 { do s <- code (newStringCLit $1);
+        | STRING                 { do s <- code (newStringCLit $1); 
                                       return (CmmLit s) }
         | reg                    { $1 }
         | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
@@ -526,80 +739,77 @@ maybe_ty :: { CmmType }
         : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }
         | '::' type                     { $2 }
 
-maybe_actuals :: { [ExtFCode HintedCmmActual] }
-        : {- empty -}                   { [] }
-        | '(' cmm_hint_exprs0 ')'       { $2 }
-
-cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] }
+cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
         : {- empty -}                   { [] }
         | cmm_hint_exprs                { $1 }
 
-cmm_hint_exprs :: { [ExtFCode HintedCmmActual] }
-        : cmm_hint_expr                         { [$1] }
+cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
+        : cmm_hint_expr                 { [$1] }
         | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
 
-cmm_hint_expr :: { ExtFCode HintedCmmActual }
-        : expr                          { do e <- $1; return (CmmHinted e (inferCmmHint e)) }
+cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
+        : expr                          { do e <- $1;
+                                             return (e, inferCmmHint e) }
         | expr STRING                   {% do h <- parseCmmHint $2;
                                               return $ do
-                                                e <- $1; return (CmmHinted e h) }
+                                                e <- $1; return (e, h) }
 
-exprs0  :: { [ExtFCode CmmExpr] }
+exprs0  :: { [CmmParse CmmExpr] }
         : {- empty -}                   { [] }
         | exprs                         { $1 }
 
-exprs   :: { [ExtFCode CmmExpr] }
+exprs   :: { [CmmParse CmmExpr] }
         : expr                          { [ $1 ] }
         | expr ',' exprs                { $1 : $3 }
 
-reg     :: { ExtFCode CmmExpr }
+reg     :: { CmmParse CmmExpr }
         : NAME                  { lookupName $1 }
         | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
 
-maybe_results :: { [ExtFCode HintedCmmFormal] }
-        : {- empty -}           { [] }
-        | '(' cmm_formals ')' '='       { $2 }
+foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }
+        : {- empty -}                   { [] }
+        | '(' foreign_formals ')' '='   { $2 }
 
-cmm_formals :: { [ExtFCode HintedCmmFormal] }
-        : cmm_formal                    { [$1] }
-        | cmm_formal ','                { [$1] }
-        | cmm_formal ',' cmm_formals    { $1 : $3 }
+foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
+        : foreign_formal                        { [$1] }
+        | foreign_formal ','                    { [$1] }
+        | foreign_formal ',' foreign_formals    { $1 : $3 }
 
-cmm_formal :: { ExtFCode HintedCmmFormal }
-        : local_lreg                    { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) }
-        | STRING local_lreg             {% do h <- parseCmmHint $1;
-                                              return $ do
-                                                e <- $2; return (CmmHinted e h) }
+foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
+        : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
+        | STRING local_lreg     {% do h <- parseCmmHint $1;
+                                      return $ do
+                                         e <- $2; return (e,h) }
 
-local_lreg :: { ExtFCode LocalReg }
+local_lreg :: { CmmParse LocalReg }
         : NAME                  { do e <- lookupName $1;
                                      return $
-                                       case e of
+                                       case e of 
                                         CmmReg (CmmLocal r) -> r
                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
 
-lreg    :: { ExtFCode CmmReg }
+lreg    :: { CmmParse CmmReg }
         : NAME                  { do e <- lookupName $1;
                                      return $
-                                       case e of
+                                       case e of 
                                         CmmReg r -> r
                                         other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
         | GLOBALREG             { return (CmmGlobal $1) }
 
-maybe_formals_without_hints :: { [ExtFCode LocalReg] }
-        : {- empty -}                           { [] }
-        | '(' formals_without_hints0 ')'        { $2 }
+maybe_formals :: { Maybe [CmmParse LocalReg] }
+        : {- empty -}           { Nothing }
+        | '(' formals0 ')'      { Just $2 }
 
-formals_without_hints0 :: { [ExtFCode LocalReg] }
-        : {- empty -}                   { [] }
-        | formals_without_hints         { $1 }
+formals0 :: { [CmmParse LocalReg] }
+        : {- empty -}           { [] }
+        | formals               { $1 }
 
-formals_without_hints :: { [ExtFCode LocalReg] }
-        : formal_without_hint ','                       { [$1] }
-        | formal_without_hint                           { [$1] }
-        | formal_without_hint ',' formals_without_hints { $1 : $3 }
+formals :: { [CmmParse LocalReg] }
+        : formal ','            { [$1] }
+        | formal                { [$1] }
+        | formal ',' formals       { $1 : $3 }
 
-formal_without_hint :: { ExtFCode LocalReg }
+formal :: { CmmParse LocalReg }
         : type NAME             { newLocal $1 $2 }
 
 type    :: { CmmType }
@@ -610,16 +820,13 @@ typenot8 :: { CmmType }
         : 'bits16'              { b16 }
         | 'bits32'              { b32 }
         | 'bits64'              { b64 }
+        | 'bits128'             { b128 }
+        | 'bits256'             { b256 }
+        | 'bits512'             { b512 }
         | 'float32'             { f32 }
         | 'float64'             { f64 }
         | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
 
-stgWord :: { StgWord }
-        : INT                   {% do dflags <- getDynFlags; return $ toStgWord dflags $1 }
-
-stgHalfWord :: { StgHalfWord }
-        : INT                   {% do dflags <- getDynFlags; return $ toStgHalfWord dflags $1 }
-
 {
 section :: String -> Section
 section "text"      = Text
@@ -632,11 +839,22 @@ section s           = OtherSection s
 mkString :: String -> CmmStatic
 mkString s = CmmString (map (fromIntegral.ord) s)
 
+-- |
+-- Given an info table, decide what the entry convention for the proc
+-- is.  That is, for an INFO_TABLE_RET we want the return convention,
+-- otherwise it is a NativeNodeCall.
+--
+infoConv :: Maybe CmmInfoTable -> Convention
+infoConv Nothing = NativeNodeCall
+infoConv (Just info)
+  | isStackRep (cit_rep info) = NativeReturn
+  | otherwise                 = NativeNodeCall
+
 -- mkMachOp infers the type of the MachOp from the type of its first
 -- argument.  We assume that this is correct: for MachOps that don't have
 -- symmetrical args (e.g. shift ops), the first arg determines the type of
 -- the op.
-mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
+mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
 mkMachOp fn args = do
   dflags <- getDynFlags
   arg_exprs <- sequence args
@@ -653,7 +871,7 @@ nameToMachOp name =
         Nothing -> fail ("unknown primitive " ++ unpackFS name)
         Just m  -> return m
 
-exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
+exprOp :: FastString -> [CmmParse CmmExpr] -> P (CmmParse CmmExpr)
 exprOp name args_code = do
   dflags <- getDynFlags
   case lookupUFM (exprMacros dflags) name of
@@ -751,14 +969,22 @@ callishMachOps = listToUFM $
         ( "write_barrier", MO_WriteBarrier ),
         ( "memcpy", MO_Memcpy ),
         ( "memset", MO_Memset ),
-        ( "memmove", MO_Memmove )
+        ( "memmove", MO_Memmove ),
+
+        ("prefetch0",MO_Prefetch_Data 0),
+        ("prefetch1",MO_Prefetch_Data 1),
+        ("prefetch2",MO_Prefetch_Data 2),
+        ("prefetch3",MO_Prefetch_Data 3)
+
         -- ToDo: the rest, maybe
+        -- edit: which rest?
+        -- also: how do we tell CMM Lint how to type check callish macops?
     ]
 
-parseSafety :: String -> P CmmSafety
-parseSafety "safe"   = return (CmmSafe NoC_SRT)
-parseSafety "unsafe" = return CmmUnsafe
-parseSafety "interruptible" = return CmmInterruptible
+parseSafety :: String -> P Safety
+parseSafety "safe"   = return PlaySafe
+parseSafety "unsafe" = return PlayRisky
+parseSafety "interruptible" = return PlayInterruptible
 parseSafety str      = fail ("unrecognised safety: " ++ str)
 
 parseCmmHint :: String -> P ForeignHint
@@ -788,7 +1014,7 @@ happyError = srcParseFail
 -- -----------------------------------------------------------------------------
 -- Statement-level macros
 
-stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
+stmtMacro :: FastString -> [CmmParse CmmExpr] -> P (CmmParse ())
 stmtMacro fun args_code = do
   case lookupUFM stmtMacros fun of
     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
@@ -796,57 +1022,86 @@ stmtMacro fun args_code = do
         args <- sequence args_code
         code (fcode args)
 
-stmtMacros :: UniqFM ([CmmExpr] -> Code)
+stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
 stmtMacros = listToUFM [
   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
+  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),
+
   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
-  ( fsLit "ENTER_CCS_THUNK",      \[e] -> enterCostCentreThunk e ),
-  ( fsLit "HP_CHK_GEN",           \[words,liveness,reentry] ->
-                                      hpChkGen words liveness reentry ),
-  ( fsLit "HP_CHK_NP_ASSIGN_SP0", \[e,f] -> hpChkNodePointsAssignSp0 e f ),
-  ( fsLit "LOAD_THREAD_STATE",    \[] -> emitLoadThreadState ),
-  ( fsLit "LDV_ENTER",            \[e] -> ldvEnter e ),
-  ( fsLit "LDV_RECORD_CREATE",    \[e] -> ldvRecordCreate e ),
   ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
+
+  -- completely generic heap and stack checks, for use in high-level cmm.
+  ( fsLit "HP_CHK_GEN",            \[bytes] ->
+                                      heapStackCheckGen Nothing (Just bytes) ),
+  ( fsLit "STK_CHK_GEN",           \[] ->
+                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),
+
+  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
+  -- we use the stack for a bit of temporary storage in a couple of primops
+  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
+                                      heapStackCheckGen (Just bytes) Nothing ),
+
+  -- A stack check on entry to a thunk, where the argument is the thunk pointer.
+  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),
+
+  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
+  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),
+
+  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
+  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),
+
   ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
-  ( fsLit "SAVE_THREAD_STATE",    \[] -> emitSaveThreadState ),
   ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
                                         emitSetDynHdr ptr info ccs ),
-  ( fsLit "STK_CHK_GEN",          \[words,liveness,reentry] ->
-                                      stkChkGen words liveness reentry ),
-  ( fsLit "STK_CHK_NP",    \[e] -> stkChkNodePoints e ),
   ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
                                         tickyAllocPrim hdr goods slop ),
-  ( fsLit "TICK_ALLOC_PAP",       \[goods,slop] ->
+  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
                                         tickyAllocPAP goods slop ),
-  ( fsLit "TICK_ALLOC_UP_THK",    \[goods,slop] ->
+  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
                                         tickyAllocThunk goods slop ),
-  ( fsLit "UPD_BH_UPDATABLE",       \[] -> emitBlackHoleCode False ),
-  ( fsLit "UPD_BH_SINGLE_ENTRY",    \[] -> emitBlackHoleCode True ),
-
-  ( fsLit "RET_P",      \[a] ->       emitRetUT [(PtrArg,a)]),
-  ( fsLit "RET_N",      \[a] ->       emitRetUT [(NonPtrArg,a)]),
-  ( fsLit "RET_PP",     \[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
-  ( fsLit "RET_NN",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
-  ( fsLit "RET_NP",     \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
-  ( fsLit "RET_PPP",    \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
-  ( fsLit "RET_NPP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
-  ( fsLit "RET_NNP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
-  ( fsLit "RET_NNN",  \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]),
-  ( fsLit "RET_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
-  ( fsLit "RET_NNNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
-  ( fsLit "RET_NPNP",   \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
-
+  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )
  ]
 
+emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
+emitPushUpdateFrame sp e = do
+  dflags <- getDynFlags
+  emitUpdateFrame dflags sp mkUpdInfoLabel e
+
+pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
+pushStackFrame fields body = do
+  dflags <- getDynFlags
+  exprs <- sequence fields
+  updfr_off <- getUpdFrameOff
+  let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
+                                           [] updfr_off exprs
+  emit g
+  withUpdFrameOff new_updfr_off body
+
+reserveStackFrame
+  :: CmmParse CmmExpr
+  -> CmmParse CmmReg
+  -> CmmParse ()
+  -> CmmParse ()
+reserveStackFrame psize preg body = do
+  dflags <- getDynFlags
+  old_updfr_off <- getUpdFrameOff
+  reg <- preg
+  esize <- psize
+  let size = case constantFoldExpr dflags esize of
+               CmmLit (CmmInt n _) -> n
+               _other -> pprPanic "CmmParse: not a compile-time integer: "
+                            (ppr esize)
+  let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size
+  emitAssign reg (CmmStackSlot Old frame)
+  withUpdFrameOff frame body
 
 profilingInfo dflags desc_str ty_str
-  = if not (dopt Opt_SccProfilingOn dflags)
+  = if not (gopt Opt_SccProfilingOn dflags)
     then NoProfilingInfo
     else ProfilingInfo (stringToWord8s desc_str)
                        (stringToWord8s ty_str)
 
-staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
+staticClosure :: PackageKey -> FastString -> FastString -> [CmmLit] -> CmmParse ()
 staticClosure pkg cl_label info payload
   = do dflags <- getDynFlags
        let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
@@ -854,78 +1109,99 @@ staticClosure pkg cl_label info payload
 
 foreignCall
         :: String
-        -> [ExtFCode HintedCmmFormal]
-        -> ExtFCode CmmExpr
-        -> [ExtFCode HintedCmmActual]
-        -> Maybe [GlobalReg]
-        -> CmmSafety
+        -> [CmmParse (LocalReg, ForeignHint)]
+        -> CmmParse CmmExpr
+        -> [CmmParse (CmmExpr, ForeignHint)]
+        -> Safety
         -> CmmReturnInfo
-        -> P ExtCode
-foreignCall conv_string results_code expr_code args_code vols safety ret
-  = do  convention <- case conv_string of
+        -> P (CmmParse ())
+foreignCall conv_string results_code expr_code args_code safety ret
+  = do  conv <- case conv_string of
           "C" -> return CCallConv
           "stdcall" -> return StdCallConv
-          "C--" -> return CmmCallConv
           _ -> fail ("unknown calling convention: " ++ conv_string)
         return $ do
           dflags <- getDynFlags
-          let platform = targetPlatform dflags
           results <- sequence results_code
           expr <- expr_code
           args <- sequence args_code
-          case convention of
-            -- Temporary hack so at least some functions are CmmSafe
-            CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret))
-            _ ->
-              let expr' = adjCallTarget dflags convention expr args in
-              case safety of
-              CmmUnsafe ->
-                code (emitForeignCall' PlayRisky results
-                   (CmmCallee expr' convention) args vols NoC_SRT ret)
-              CmmSafe srt ->
-                code (emitForeignCall' PlaySafe results
-                   (CmmCallee expr' convention) args vols NoC_SRT ret) where
-              CmmInterruptible ->
-                code (emitForeignCall' PlayInterruptible results
-                   (CmmCallee expr' convention) args vols NoC_SRT ret)
-
-adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr]
+          let
+                  expr' = adjCallTarget dflags conv expr args
+                  (arg_exprs, arg_hints) = unzip args
+                  (res_regs,  res_hints) = unzip results
+                  fc = ForeignConvention conv arg_hints res_hints ret
+                  target = ForeignTarget expr' fc
+          _ <- code $ emitForeignCall safety res_regs target arg_exprs
+          return ()
+
+
+doReturn :: [CmmParse CmmExpr] -> CmmParse ()
+doReturn exprs_code = do
+  dflags <- getDynFlags
+  exprs <- sequence exprs_code
+  updfr_off <- getUpdFrameOff
+  emit (mkReturnSimple dflags exprs updfr_off)
+
+mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
+mkReturnSimple dflags actuals updfr_off =
+  mkReturn dflags e actuals updfr_off
+  where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
+                             (gcWord dflags))
+
+doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
+doRawJump expr_code vols = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  updfr_off <- getUpdFrameOff
+  emit (mkRawJump dflags expr updfr_off vols)
+
+doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
+                -> [CmmParse CmmExpr] -> CmmParse ()
+doJumpWithStack expr_code stk_code args_code = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  stk_args <- sequence stk_code
+  args <- sequence args_code
+  updfr_off <- getUpdFrameOff
+  emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
+
+doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
+       -> CmmParse ()
+doCall expr_code res_code args_code = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  args <- sequence args_code
+  ress <- sequence res_code
+  updfr_off <- getUpdFrameOff
+  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
+  emit c
+
+adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
               -> CmmExpr
 -- On Windows, we have to add the '@N' suffix to the label when making
 -- a call with the stdcall calling convention.
 adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
  | platformOS (targetPlatform dflags) == OSMinGW32
   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
-  where size (CmmHinted e _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
+  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
                  -- c.f. CgForeignCall.emitForeignCall
 adjCallTarget _ _ expr _
   = expr
 
 primCall
-        :: [ExtFCode HintedCmmFormal]
+        :: [CmmParse (CmmFormal, ForeignHint)]
         -> FastString
-        -> [ExtFCode HintedCmmActual]
-        -> Maybe [GlobalReg]
-        -> CmmSafety
-        -> P ExtCode
-primCall results_code name args_code vols safety
+        -> [CmmParse CmmExpr]
+        -> P (CmmParse ())
+primCall results_code name args_code
   = case lookupUFM callishMachOps name of
         Nothing -> fail ("unknown primitive " ++ unpackFS name)
         Just p  -> return $ do
                 results <- sequence results_code
                 args <- sequence args_code
-                case safety of
-                  CmmUnsafe ->
-                    code (emitForeignCall' PlayRisky results
-                      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
-                  CmmSafe srt ->
-                    code (emitForeignCall' PlaySafe results
-                      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where
-                  CmmInterruptible ->
-                    code (emitForeignCall' PlayInterruptible results
-                      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
-
-doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
+                code (emitPrimCall (map fst results) p args)
+
+doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
 doStore rep addr_code val_code
   = do dflags <- getDynFlags
        addr <- addr_code
@@ -940,19 +1216,7 @@ doStore rep addr_code val_code
        let coerce_val
                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
                 | otherwise              = val
-       stmtEC (CmmStore addr coerce_val)
-
--- Return an unboxed tuple.
-emitRetUT :: [(CgRep,CmmExpr)] -> Code
-emitRetUT args = do
-  dflags <- getDynFlags
-  tickyUnboxedTupleReturn (length args)  -- TICK
-  (sp, stmts, live) <- pushUnboxedTuple 0 args
-  emitSimultaneously stmts -- NB. the args might overlap with the stack slots
-                           -- or regs that we assign to, so better use
-                           -- simultaneous assignments here (#3546)
-  when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW dflags spReg (-sp)))
-  stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW dflags spReg sp) (bWord dflags))) (Just live)
+       emitStore addr coerce_val
 
 -- -----------------------------------------------------------------------------
 -- If-then-else and boolean expressions
@@ -966,16 +1230,16 @@ data BoolExpr
 -- ToDo: smart constructors which simplify the boolean expression.
 
 cmmIfThenElse cond then_part else_part = do
-     then_id <- code newLabelC
-     join_id <- code newLabelC
+     then_id <- newBlockId
+     join_id <- newBlockId
      c <- cond
      emitCond c then_id
      else_part
-     stmtEC (CmmBranch join_id)
-     code (labelC then_id)
+     emit (mkBranch join_id)
+     emitLabel then_id
      then_part
      -- fall through to join
-     code (labelC join_id)
+     emitLabel join_id
 
 cmmRawIf cond then_id = do
     c <- cond
@@ -984,15 +1248,17 @@ cmmRawIf cond then_id = do
 -- 'emitCond cond true_id'  emits code to test whether the cond is true,
 -- branching to true_id if so, and falling through otherwise.
 emitCond (BoolTest e) then_id = do
-  stmtEC (CmmCondBranch e then_id)
+  else_id <- newBlockId
+  emit (mkCbranch e then_id else_id)
+  emitLabel else_id
 emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
   | Just op' <- maybeInvertComparison op
   = emitCond (BoolTest (CmmMachOp op' args)) then_id
 emitCond (BoolNot e) then_id = do
-  else_id <- code newLabelC
+  else_id <- newBlockId
   emitCond e else_id
-  stmtEC (CmmBranch then_id)
-  code (labelC else_id)
+  emit (mkBranch then_id)
+  emitLabel else_id
 emitCond (e1 `BoolOr` e2) then_id = do
   emitCond e1 then_id
   emitCond e2 then_id
@@ -1001,13 +1267,13 @@ emitCond (e1 `BoolAnd` e2) then_id = do
         -- extra branch instruction, but we can't use maybeInvertComparison
         -- here because we can't look too closely at the expression since
         -- we're in a loop.
-  and_id <- code newLabelC
-  else_id <- code newLabelC
+  and_id <- newBlockId
+  else_id <- newBlockId
   emitCond e1 and_id
-  stmtEC (CmmBranch else_id)
-  code (labelC and_id)
+  emit (mkBranch else_id)
+  emitLabel and_id
   emitCond e2 then_id
-  code (labelC else_id)
+  emitLabel else_id
 
 
 -- -----------------------------------------------------------------------------
@@ -1020,15 +1286,15 @@ emitCond (e1 `BoolAnd` e2) then_id = do
 -- optional range on the switch (eg. switch [0..7] {...}), or by
 -- the minimum/maximum values from the branches.
 
-doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
-         -> Maybe ExtCode -> ExtCode
+doSwitch :: Maybe (Int,Int) -> CmmParse CmmExpr -> [([Int],Either BlockId (CmmParse ()))]
+         -> Maybe (CmmParse ()) -> CmmParse ()
 doSwitch mb_range scrut arms deflt
    = do
         -- Compile code for the default branch
-        dflt_entry <-
+        dflt_entry <- 
                 case deflt of
                   Nothing -> return Nothing
-                  Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
+                  Just e  -> do b <- forkLabelledCode e; return (Just b)
 
         -- Compile each case branch
         table_entries <- mapM emitArm arms
@@ -1037,7 +1303,7 @@ doSwitch mb_range scrut arms deflt
         let
             all_entries = concat table_entries
             ixs = map fst all_entries
-            (min,max)
+            (min,max) 
                 | Just (l,u) <- mb_range = (l,u)
                 | otherwise              = (minimum ixs, maximum ixs)
 
@@ -1045,14 +1311,21 @@ doSwitch mb_range scrut arms deflt
                                 all_entries)
         expr <- scrut
         -- ToDo: check for out of range and jump to default if necessary
-        stmtEC (CmmSwitch expr entries)
+        emit (mkSwitch expr entries)
    where
-        emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
+        emitArm :: ([Int],Either BlockId (CmmParse ())) -> CmmParse [(Int,BlockId)]
         emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
         emitArm (ints,Right code) = do
-           blockid <- forkLabelledCodeEC code
+           blockid <- forkLabelledCode code
            return [ (i,blockid) | i <- ints ]
 
+forkLabelledCode :: CmmParse () -> CmmParse BlockId
+forkLabelledCode p = do
+  ag <- getCode p
+  l <- newBlockId
+  emitOutOfLine l ag
+  return l
+
 -- -----------------------------------------------------------------------------
 -- Putting it all together
 
@@ -1061,7 +1334,7 @@ doSwitch mb_range scrut arms deflt
 initEnv :: DynFlags -> Env
 initEnv dflags = listToUFM [
   ( fsLit "SIZEOF_StgHeader",
-    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE dflags)) (wordWidth dflags)) )),
+    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
   ( fsLit "SIZEOF_StgInfoTable",
     VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
   ]