Add a way to reserve temporary stack space in high-level Cmm

We occasionally need to reserve some temporary memory in a primop for
passing to a foreign function.  We've been using the stack for this,
but when we moved to high-level Cmm it became quite fragile because
primops are in high-level Cmm and the stack is supposed to be under
the control of the Cmm pipeline.

So this change puts things on a firmer footing by adding a new Cmm
construct 'reserve'.  e.g. in decodeFloat_Int#:

    reserve 2 = tmp {

      mp_tmp1  = tmp + WDS(1);
      mp_tmp_w = tmp;

      /* Perform the operation */
      ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);

      r1 = W_[mp_tmp1];
      r2 = W_[mp_tmp_w];
    }

reserve is described in CmmParse.y.

Unfortunately the argument to reserve must be a compile-time constant.
We might have to extend the parser to allow expressions with
arithmetic operators if this is too restrictive.

Note also that the return instruction for the procedure must be
outside the scope of the reserved stack area, so we have to extract
the values from the reserved area before we close the scope.  This
means some more local variables (r1, r2 in the example above).  The
generated code is more or less identical to what we had before though.

2 files changed, 28 insertions, 1 deletions

diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x
index 1b823ccb09..bb5b4e3ae5 100644
--- a/compiler/cmm/CmmLex.x
+++ b/compiler/cmm/CmmLex.x
@@ -152,6 +152,7 @@ data CmmToken
   | CmmT_foreign
   | CmmT_never
   | CmmT_prim
+  | CmmT_reserve
   | CmmT_return
   | CmmT_returns
   | CmmT_import
@@ -234,7 +235,8 @@ reservedWordsFM = listToUFM $
         ( "foreign",            CmmT_foreign ),
 	( "never",		CmmT_never ),
 	( "prim",		CmmT_prim ),
-	( "return",		CmmT_return ),
+        ( "reserve",            CmmT_reserve ),
+        ( "return",             CmmT_return ),
 	( "returns",		CmmT_returns ),
 	( "import",		CmmT_import ),
 	( "switch",		CmmT_switch ),
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index a0c9bc4eb5..8438198f7d 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -89,6 +89,19 @@ High-level only:
   - 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.
@@ -302,6 +315,7 @@ import Data.Maybe
         '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) }
@@ -614,6 +628,8 @@ stmt    :: { CmmParse () }
                 { cmmIfThenElse $2 $4 $6 }
         | 'push' '(' exprs0 ')' maybe_body
                 { pushStackFrame $3 $5 }
+        | 'reserve' INT '=' lreg maybe_body
+                { reserveStackFrame (fromIntegral $2) $4 $5 }
 
 foreignLabel     :: { CmmParse CmmExpr }
         : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
@@ -1060,6 +1076,15 @@ pushStackFrame fields body = do
   emit g
   withUpdFrameOff new_updfr_off body
 
+reserveStackFrame :: Int -> CmmParse CmmReg -> CmmParse () -> CmmParse ()
+reserveStackFrame size preg body = do
+  dflags <- getDynFlags
+  old_updfr_off <- getUpdFrameOff
+  reg <- preg
+  let frame = old_updfr_off + wORD_SIZE dflags * size
+  emitAssign reg (CmmStackSlot Old frame)
+  withUpdFrameOff frame body
+
 profilingInfo dflags desc_str ty_str
   = if not (gopt Opt_SccProfilingOn dflags)
     then NoProfilingInfo