Generalise `Control.Monad.{when,unless,guard}`
[ghc.git] / rts / Apply.cmm
index a98edee..9d18e95 100644 (file)
 
 STRING(stg_ap_0_ret_str,"stg_ap_0_ret... ")
 
-stg_ap_0_fast
-{ 
-    // fn is in R1, no args on the stack
-
+stg_ap_0_fast ( P_ fun )
+{
     IF_DEBUG(apply,
-       foreign "C" debugBelch(stg_ap_0_ret_str) [R1];
-       foreign "C" printClosure(R1 "ptr") [R1]);
+        ccall debugBelch(stg_ap_0_ret_str);
+        ccall printClosure(R1 "ptr"));
 
     IF_DEBUG(sanity,
-       foreign "C" checkStackChunk(Sp "ptr",
-                                   CurrentTSO + TSO_OFFSET_StgTSO_stack +
-                                   WDS(TO_W_(StgTSO_stack_size(CurrentTSO))) "ptr") [R1]);
+        ccall checkStackFrame(Sp "ptr"));
 
-    ENTER();
+    ENTER(fun);
 }
 
 /* -----------------------------------------------------------------------------
@@ -58,13 +54,13 @@ stg_ap_0_fast
    -------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_PAP,/*special layout*/0,0,PAP,"PAP","PAP")
-{  foreign "C" barf("PAP object entered!") never returns; }
-    
-stg_PAP_apply
+{  ccall barf("PAP object entered!") never returns; }
+
+stg_PAP_apply /* no args => explicit stack */
 {
   W_ Words;
   W_ pap;
-    
+
   pap = R1;
 
   Words = TO_W_(StgPAP_n_args(pap));
@@ -78,19 +74,20 @@ stg_PAP_apply
       // there is a return address in R2 in the event of a
       // stack check failure.  The various stg_apply functions arrange
       // this before calling stg_PAP_entry.
-      Sp_adj(-1); 
+      Sp_adj(-1);
       Sp(0) = R2;
-      jump stg_gc_unpt_r1;
+      jump stg_gc_unpt_r1 [R1];
   }
   Sp_adj(-Words);
 
   // profiling
   TICK_ENT_PAP();
   LDV_ENTER(pap);
-  // Enter PAP cost centre 
-  ENTER_CCS_PAP_CL(pap);
+#ifdef PROFILING
+  ccall enterFunCCS(BaseReg "ptr", StgHeader_ccs(pap) "ptr");
+#endif
 
-  // Reload the stack 
+  // Reload the stack
   W_ i;
   W_ p;
   p = pap + SIZEOF_StgHeader + OFFSET_StgPAP_payload;
@@ -108,41 +105,41 @@ for:
 /* DEBUGGING CODE, ensures that arity 1 and 2 functions are entered tagged
   if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == 1 ) {
     if (GETTAG(R1)!=1) {
-       W_[0]=1;
+        W_[0]=1;
     }
   }
 
   if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == 2 ) {
     if (GETTAG(R1)!=2) {
-       W_[0]=1;
+        W_[0]=1;
     }
   }
 */
 
-  // Off we go! 
+  // Off we go!
   TICK_ENT_VIA_NODE();
 
 #ifdef NO_ARG_REGS
-  jump %GET_ENTRY(UNTAG(R1));
+  jump %GET_ENTRY(UNTAG(R1)) [R1];
 #else
       W_ info;
       info = %GET_FUN_INFO(UNTAG(R1));
       W_ type;
       type = TO_W_(StgFunInfoExtra_fun_type(info));
       if (type == ARG_GEN) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_GEN_BIG) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_BCO) {
-         Sp_adj(-2);
-         Sp(1) = R1;
-         Sp(0) = stg_apply_interp_info;
-         jump stg_yield_to_interpreter;
+          Sp_adj(-2);
+          Sp(1) = R1;
+          Sp(0) = stg_apply_interp_info;
+          jump stg_yield_to_interpreter [];
       }
-      jump W_[stg_ap_stack_entries + 
-               WDS(TO_W_(StgFunInfoExtra_fun_type(info)))];
+      jump W_[stg_ap_stack_entries +
+                WDS(TO_W_(StgFunInfoExtra_fun_type(info)))] [R1];
 #endif
 }
 
@@ -156,32 +153,31 @@ for:
    -------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_AP,/*special layout*/0,0,AP,"AP","AP")
+ /* no args => explicit stack */
 {
   W_ Words;
   W_ ap;
-    
+
   ap = R1;
-  
+
   Words = TO_W_(StgAP_n_args(ap));
 
-  /* 
-   * Check for stack overflow.  IMPORTANT: use a _NP check here,
+  /*
+   * Check for stack overflow.  IMPORTANT: use a _ENTER check here,
    * because if the check fails, we might end up blackholing this very
    * closure, in which case we must enter the blackhole on return rather
    * than continuing to evaluate the now-defunct closure.
    */
-  STK_CHK_NP(WDS(Words) + SIZEOF_StgUpdateFrame);
+  STK_CHK_ENTER(WDS(Words) + SIZEOF_StgUpdateFrame, R1);
 
   PUSH_UPD_FRAME(Sp - SIZEOF_StgUpdateFrame, R1);
   Sp = Sp - SIZEOF_StgUpdateFrame - WDS(Words);
 
   TICK_ENT_AP();
   LDV_ENTER(ap);
+  ENTER_CCS_THUNK(ap);
 
-  // Enter PAP cost centre
-  ENTER_CCS_PAP_CL(ap);   // ToDo: ENTER_CC_AP_CL 
-
-  // Reload the stack 
+  // Reload the stack
   W_ i;
   W_ p;
   p = ap + SIZEOF_StgHeader + OFFSET_StgAP_payload;
@@ -196,62 +192,61 @@ for:
 
   R1 = StgAP_fun(ap);
 
-  // Off we go! 
+  // Off we go!
   TICK_ENT_VIA_NODE();
 
 #ifdef NO_ARG_REGS
-  jump %GET_ENTRY(UNTAG(R1));
+  jump %GET_ENTRY(UNTAG(R1)) [R1];
 #else
       W_ info;
       info = %GET_FUN_INFO(UNTAG(R1));
       W_ type;
       type = TO_W_(StgFunInfoExtra_fun_type(info));
       if (type == ARG_GEN) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_GEN_BIG) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_BCO) {
-         Sp_adj(-2);
-         Sp(1) = R1;
-         Sp(0) = stg_apply_interp_info;
-         jump stg_yield_to_interpreter;
+          Sp_adj(-2);
+          Sp(1) = R1;
+          Sp(0) = stg_apply_interp_info;
+          jump stg_yield_to_interpreter [];
       }
-      jump W_[stg_ap_stack_entries + 
-               WDS(TO_W_(StgFunInfoExtra_fun_type(info)))];
+      jump W_[stg_ap_stack_entries +
+                WDS(TO_W_(StgFunInfoExtra_fun_type(info)))] [R1];
 #endif
 }
 
 /* AP_NOUPD is exactly like AP, except that no update frame is pushed.
-   Use for thunks that are guaranteed to be entered once only, such as 
+   Use for thunks that are guaranteed to be entered once only, such as
    those generated by the byte-code compiler for inserting breakpoints. */
 
 INFO_TABLE(stg_AP_NOUPD,/*special layout*/0,0,AP,"AP_NOUPD","AP_NOUPD")
+   /* no args => explicit stack */
 {
   W_ Words;
   W_ ap;
-    
+
   ap = R1;
-  
+
   Words = TO_W_(StgAP_n_args(ap));
 
-  /* 
-   * Check for stack overflow.  IMPORTANT: use a _NP check here,
+  /*
+   * Check for stack overflow.  IMPORTANT: use a _ENTER check here,
    * because if the check fails, we might end up blackholing this very
    * closure, in which case we must enter the blackhole on return rather
    * than continuing to evaluate the now-defunct closure.
    */
-  STK_CHK_NP(WDS(Words));
+  STK_CHK_ENTER(WDS(Words), R1);
   Sp = Sp - WDS(Words);
 
   TICK_ENT_AP();
   LDV_ENTER(ap);
+  ENTER_CCS_THUNK(ap);
 
-  // Enter PAP cost centre
-  ENTER_CCS_PAP_CL(ap);   // ToDo: ENTER_CC_AP_CL 
-
-  // Reload the stack 
+  // Reload the stack
   W_ i;
   W_ p;
   p = ap + SIZEOF_StgHeader + OFFSET_StgAP_payload;
@@ -266,30 +261,30 @@ for:
 
   R1 = StgAP_fun(ap);
 
-  // Off we go! 
+  // Off we go!
   TICK_ENT_VIA_NODE();
 
 #ifdef NO_ARG_REGS
-  jump %GET_ENTRY(UNTAG(R1));
+  jump %GET_ENTRY(UNTAG(R1)) [R1];
 #else
       W_ info;
       info = %GET_FUN_INFO(UNTAG(R1));
       W_ type;
       type = TO_W_(StgFunInfoExtra_fun_type(info));
       if (type == ARG_GEN) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_GEN_BIG) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_BCO) {
-         Sp_adj(-2);
-         Sp(1) = R1;
-         Sp(0) = stg_apply_interp_info;
-         jump stg_yield_to_interpreter;
+          Sp_adj(-2);
+          Sp(1) = R1;
+          Sp(0) = stg_apply_interp_info;
+          jump stg_yield_to_interpreter [];
       }
-      jump W_[stg_ap_stack_entries + 
-               WDS(TO_W_(StgFunInfoExtra_fun_type(info)))];
+      jump W_[stg_ap_stack_entries +
+                WDS(TO_W_(StgFunInfoExtra_fun_type(info)))] [R1];
 #endif
 }
 
@@ -305,21 +300,22 @@ for:
    -------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK")
+  /* no args => explicit stack */
 {
   W_ Words;
   W_ ap;
 
   ap = R1;
-  
+
   Words = StgAP_STACK_size(ap);
 
-  /* 
-   * Check for stack overflow.  IMPORTANT: use a _NP check here,
+  /*
+   * Check for stack overflow.  IMPORTANT: use a _ENTER check here,
    * because if the check fails, we might end up blackholing this very
    * closure, in which case we must enter the blackhole on return rather
    * than continuing to evaluate the now-defunct closure.
    */
-  STK_CHK_NP(WDS(Words) + SIZEOF_StgUpdateFrame + WDS(AP_STACK_SPLIM));
+  STK_CHK_ENTER(WDS(Words) + SIZEOF_StgUpdateFrame + WDS(AP_STACK_SPLIM), R1);
   /* ensure there is at least AP_STACK_SPLIM words of headroom available
    * after unpacking the AP_STACK. See bug #1466 */
 
@@ -328,9 +324,59 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK")
 
   TICK_ENT_AP();
   LDV_ENTER(ap);
+  ENTER_CCS_THUNK(ap);
+
+  // Reload the stack
+  W_ i;
+  W_ p;
+  p = ap + SIZEOF_StgHeader + OFFSET_StgAP_STACK_payload;
+  i = 0;
+for:
+  if (i < Words) {
+    Sp(i) = W_[p];
+    p = p + WDS(1);
+    i = i + 1;
+    goto for;
+  }
+
+  // Off we go!
+  TICK_ENT_VIA_NODE();
+
+  R1 = StgAP_STACK_fun(ap);
+
+  ENTER_R1();
+}
+
+/* -----------------------------------------------------------------------------
+   AP_STACK_NOUPD - exactly like AP_STACK, but doesn't push an update frame.
+   -------------------------------------------------------------------------- */
+
+INFO_TABLE(stg_AP_STACK_NOUPD,/*special layout*/0,0,AP_STACK,
+                                        "AP_STACK_NOUPD","AP_STACK_NOUPD")
+   /* no args => explicit stack */
+{
+  W_ Words;
+  W_ ap;
 
-  // Enter PAP cost centre
-  ENTER_CCS_PAP_CL(ap);   // ToDo: ENTER_CC_AP_CL 
+  ap = R1;
+
+  Words = StgAP_STACK_size(ap);
+
+  /*
+   * Check for stack overflow.  IMPORTANT: use a _NP check here,
+   * because if the check fails, we might end up blackholing this very
+   * closure, in which case we must enter the blackhole on return rather
+   * than continuing to evaluate the now-defunct closure.
+   */
+  STK_CHK_ENTER(WDS(Words) + WDS(AP_STACK_SPLIM), R1);
+  /* ensure there is at least AP_STACK_SPLIM words of headroom available
+   * after unpacking the AP_STACK. See bug #1466 */
+
+  Sp = Sp - WDS(Words);
+
+  TICK_ENT_AP();
+  LDV_ENTER(ap);
+  ENTER_CCS_THUNK(ap);
 
   // Reload the stack
   W_ i;
@@ -350,5 +396,5 @@ for:
 
   R1 = StgAP_STACK_fun(ap);
 
-  ENTER();
+  ENTER_R1();
 }