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.

1 files changed, 81 insertions, 45 deletions

diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index b99126187a..2985982d64 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -22,30 +22,36 @@ import LeaveCriticalSection;
    Stack underflow
    ------------------------------------------------------------------------- */
 
-INFO_TABLE_RET (stg_stack_underflow_frame, UNDERFLOW_FRAME, P_ unused)
+INFO_TABLE_RET (stg_stack_underflow_frame, UNDERFLOW_FRAME,
+                W_ info_ptr, P_ unused)
+    /* no args => explicit stack */
 {
     W_ new_tso;
     W_ ret_off;
 
+    SAVE_STGREGS
+
     SAVE_THREAD_STATE();
     ("ptr" ret_off) = foreign "C" threadStackUnderflow(MyCapability(),
                                                        CurrentTSO);
     LOAD_THREAD_STATE();
 
-    jump %ENTRY_CODE(Sp(ret_off));
+    RESTORE_STGREGS
+
+    jump %ENTRY_CODE(Sp(ret_off)) [*]; // NB. all registers live!
 }
 
 /* ----------------------------------------------------------------------------
    Restore a saved cost centre
    ------------------------------------------------------------------------- */
 
-INFO_TABLE_RET (stg_restore_cccs, RET_SMALL, W_ cccs)
+INFO_TABLE_RET (stg_restore_cccs, RET_SMALL, W_ info_ptr, W_ cccs)
 {
 #if defined(PROFILING)
     CCCS = Sp(1);
 #endif
     Sp_adj(2);
-    jump %ENTRY_CODE(Sp(0));
+    jump %ENTRY_CODE(Sp(0)) [*]; // NB. all registers live!
 }
 
 /* ----------------------------------------------------------------------------
@@ -53,10 +59,9 @@ INFO_TABLE_RET (stg_restore_cccs, RET_SMALL, W_ cccs)
    ------------------------------------------------------------------------- */
 
 /* 9 bits of return code for constructors created by the interpreter. */
-stg_interp_constr_entry
+stg_interp_constr_entry (P_ ret)
 {
-    /* R1 points at the constructor */
-    jump %ENTRY_CODE(Sp(0));
+    return (ret);
 }
 
 /* Some info tables to be used when compiled code returns a value to
@@ -94,76 +99,83 @@ stg_interp_constr_entry
 */
 
 INFO_TABLE_RET( stg_ctoi_R1p, RET_BCO)
+    /* explicit stack */
 {
     Sp_adj(-2);
     Sp(1) = R1;
     Sp(0) = stg_enter_info;
-    jump stg_yield_to_interpreter;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is a pointer, but unlifted, in R1 ...
  */
 INFO_TABLE_RET( stg_ctoi_R1unpt, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-2);
     Sp(1) = R1;
-    Sp(0) = stg_gc_unpt_r1_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_p_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is a non-pointer in R1 ...
  */
 INFO_TABLE_RET( stg_ctoi_R1n, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-2);
     Sp(1) = R1;
-    Sp(0) = stg_gc_unbx_r1_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_p_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is in F1
  */
 INFO_TABLE_RET( stg_ctoi_F1, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-2);
     F_[Sp + WDS(1)] = F1;
-    Sp(0) = stg_gc_f1_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_f_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is in D1
  */
 INFO_TABLE_RET( stg_ctoi_D1, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-1) - SIZEOF_DOUBLE;
     D_[Sp + WDS(1)] = D1;
-    Sp(0) = stg_gc_d1_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_d_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is in L1
  */
 INFO_TABLE_RET( stg_ctoi_L1, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-1) - 8;
     L_[Sp + WDS(1)] = L1;
-    Sp(0) = stg_gc_l1_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_l_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
  * When the returned value is a void
  */
 INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
+    /* explicit stack */
 {
     Sp_adj(-1);
-    Sp(0) = stg_gc_void_info;
-    jump stg_yield_to_interpreter;
+    Sp(0) = stg_ret_v_info;
+    jump stg_yield_to_interpreter [];
 }
 
 /*
@@ -172,9 +184,10 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
  * stack.
  */
 INFO_TABLE_RET( stg_apply_interp, RET_BCO )
+    /* explicit stack */
 {
     /* Just in case we end up in here... (we shouldn't) */
-    jump stg_yield_to_interpreter;
+    jump stg_yield_to_interpreter [];
 }
 
 /* ----------------------------------------------------------------------------
@@ -182,12 +195,13 @@ INFO_TABLE_RET( stg_apply_interp, RET_BCO )
    ------------------------------------------------------------------------- */
 
 INFO_TABLE_FUN( stg_BCO, 4, 0, BCO, "BCO", "BCO", ARG_BCO )
+    /* explicit stack */
 {
   /* entering a BCO means "apply it", same as a function */
   Sp_adj(-2);
   Sp(1) = R1;
   Sp(0) = stg_apply_interp_info;
-  jump stg_yield_to_interpreter;
+  jump stg_yield_to_interpreter [];
 }
 
 /* ----------------------------------------------------------------------------
@@ -201,30 +215,48 @@ INFO_TABLE_FUN( stg_BCO, 4, 0, BCO, "BCO", "BCO", ARG_BCO )
    ------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_IND,1,0,IND,"IND","IND")
+#if 0
+/*
+  This version in high-level cmm generates slightly less good code
+  than the low-level version below it. (ToDo)
+*/
+    (P_ node)
+{
+    TICK_ENT_DYN_IND(); /* tick */
+    node = UNTAG(StgInd_indirectee(node));
+    TICK_ENT_VIA_NODE();
+    jump %GET_ENTRY(node) (node);
+}
+#else
+    /* explicit stack */
 {
     TICK_ENT_DYN_IND(); /* tick */
     R1 = UNTAG(StgInd_indirectee(R1));
     TICK_ENT_VIA_NODE();
-    jump %GET_ENTRY(R1);
+    jump %GET_ENTRY(R1) [R1];
 }
+#endif
 
 INFO_TABLE(stg_IND_direct,1,0,IND,"IND","IND")
+    (P_ node)
 {
     TICK_ENT_DYN_IND(); /* tick */
-    R1 = StgInd_indirectee(R1);
+    node = StgInd_indirectee(node);
     TICK_ENT_VIA_NODE();
-    jump %ENTRY_CODE(Sp(0));
+    jump %ENTRY_CODE(Sp(0)) (node);
 }
 
 INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC")
+    /* explicit stack */
 {
     TICK_ENT_STATIC_IND(); /* tick */
     R1 = UNTAG(StgInd_indirectee(R1));
     TICK_ENT_VIA_NODE();
-    jump %GET_ENTRY(R1);
+    jump %GET_ENTRY(R1) [R1];
 }
 
 INFO_TABLE(stg_IND_PERM,1,0,IND_PERM,"IND_PERM","IND_PERM")
+    /* explicit stack */
 {
     /* Don't add INDs to granularity cost */
 
@@ -259,7 +291,7 @@ INFO_TABLE(stg_IND_PERM,1,0,IND_PERM,"IND_PERM","IND_PERM")
     TICK_ENT_VIA_NODE();
 #endif
 
-    jump %GET_ENTRY(R1);
+    jump %GET_ENTRY(R1) [R1];
 }
 
 /* ----------------------------------------------------------------------------
@@ -272,16 +304,17 @@ INFO_TABLE(stg_IND_PERM,1,0,IND_PERM,"IND_PERM","IND_PERM")
    ------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
+    (P_ node)
 {
-    W_ r, p, info, bq, msg, owner, bd;
+    W_ r, info, owner, bd;
+    P_ p, bq, msg;
 
     TICK_ENT_DYN_IND(); /* tick */
 
 retry:
-    p = StgInd_indirectee(R1);
+    p = StgInd_indirectee(node);
     if (GETTAG(p) != 0) {
-        R1 = p;
-        jump %ENTRY_CODE(Sp(0));
+        return (p);
     }
 
     info = StgHeader_info(p);
@@ -296,33 +329,33 @@ retry:
         info == stg_BLOCKING_QUEUE_CLEAN_info ||
         info == stg_BLOCKING_QUEUE_DIRTY_info)
     {
-        ("ptr" msg) = foreign "C" allocate(MyCapability() "ptr",
-                                           BYTES_TO_WDS(SIZEOF_MessageBlackHole)) [R1];
+        ("ptr" msg) = ccall allocate(MyCapability() "ptr",
+                                     BYTES_TO_WDS(SIZEOF_MessageBlackHole));
 
         SET_HDR(msg, stg_MSG_BLACKHOLE_info, CCS_SYSTEM);
         MessageBlackHole_tso(msg) = CurrentTSO;
-        MessageBlackHole_bh(msg) = R1;
+        MessageBlackHole_bh(msg) = node;
 
-        (r) = foreign "C" messageBlackHole(MyCapability() "ptr", msg "ptr") [R1];
+        (r) = ccall messageBlackHole(MyCapability() "ptr", msg "ptr");
 
         if (r == 0) {
             goto retry;
         } else {
             StgTSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16;
             StgTSO_block_info(CurrentTSO) = msg;
-            jump stg_block_blackhole;
+            jump stg_block_blackhole(node);
         }
     }
     else
     {
-        R1 = p;
-        ENTER();
+        ENTER(p);
     }
 }
 
 INFO_TABLE(__stg_EAGER_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
+    (P_ node)
 {
-    jump ENTRY_LBL(stg_BLACKHOLE);
+    jump ENTRY_LBL(stg_BLACKHOLE) (node);
 }
 
 // CAF_BLACKHOLE is allocated when entering a CAF.  The reason it is
@@ -332,8 +365,9 @@ INFO_TABLE(__stg_EAGER_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
 // evaluation by another thread (a BLACKHOLE).  See threadPaused().
 //
 INFO_TABLE(stg_CAF_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
+    (P_ node)
 {
-    jump ENTRY_LBL(stg_BLACKHOLE);
+    jump ENTRY_LBL(stg_BLACKHOLE) (node);
 }
 
 INFO_TABLE(stg_BLOCKING_QUEUE_CLEAN,4,0,BLOCKING_QUEUE,"BLOCKING_QUEUE","BLOCKING_QUEUE")
@@ -349,6 +383,7 @@ INFO_TABLE(stg_BLOCKING_QUEUE_DIRTY,4,0,BLOCKING_QUEUE,"BLOCKING_QUEUE","BLOCKIN
    ------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_WHITEHOLE, 0,0, WHITEHOLE, "WHITEHOLE", "WHITEHOLE")
+    (P_ node)
 {
 #if defined(THREADED_RTS)
     W_ info, i;
@@ -356,18 +391,18 @@ INFO_TABLE(stg_WHITEHOLE, 0,0, WHITEHOLE, "WHITEHOLE", "WHITEHOLE")
     i = 0;
 loop:
     // spin until the WHITEHOLE is updated
-    info = StgHeader_info(R1);
+    info = StgHeader_info(node);
     if (info == stg_WHITEHOLE_info) {
         i = i + 1;
         if (i == SPIN_COUNT) {
             i = 0;
-            foreign "C" yieldThread() [R1];
+            ccall yieldThread();
         }
         goto loop;
     }
-    jump %ENTRY_CODE(info);
+    jump %ENTRY_CODE(info) (node);
 #else
-    foreign "C" barf("WHITEHOLE object entered!") never returns;
+    ccall barf("WHITEHOLE object entered!") never returns;
 #endif
 }
 
@@ -556,8 +591,9 @@ INFO_TABLE(stg_MUT_VAR_DIRTY, 1, 0, MUT_VAR_DIRTY, "MUT_VAR_DIRTY", "MUT_VAR_DIR
  * ------------------------------------------------------------------------- */
 
 INFO_TABLE( stg_dummy_ret, 0, 0, CONSTR_NOCAF_STATIC, "DUMMY_RET", "DUMMY_RET")
+    ()
 {
-  jump %ENTRY_CODE(Sp(0));
+    return ();
 }
 CLOSURE(stg_dummy_ret_closure,stg_dummy_ret);