Linker: some extra debugging / logging
[ghc.git] / rts / HeapStackCheck.cmm
index fbceb76..69bff74 100644 (file)
@@ -12,6 +12,7 @@
 
 #include "Cmm.h"
 #include "Updates.h"
+#include "SMPClosureOps.h"
 
 #ifdef __PIC__
 import pthread_mutex_unlock;
@@ -72,10 +73,10 @@ import LeaveCriticalSection;
  * will either increase the size of our stack, or raise an exception if
  * the stack is already too big.
  */
-#define PRE_RETURN(why,what_next)                      \
-  StgTSO_what_next(CurrentTSO) = what_next::I16;       \
-  StgRegTable_rRet(BaseReg) = why;                     \
+
+#define PRE_RETURN(why,what_next)                       \
+  StgTSO_what_next(CurrentTSO) = what_next::I16;        \
+  StgRegTable_rRet(BaseReg) = why;                      \
   R1 = BaseReg;
 
 /* Remember that the return address is *removed* when returning to a
@@ -97,10 +98,17 @@ stg_gc_noregs
             && bdescr_link(CurrentNursery) != NULL) {
             HpAlloc = 0;
             CLOSE_NURSERY();
+            Capability_total_allocated(MyCapability()) =
+              Capability_total_allocated(MyCapability()) +
+              BYTES_TO_WDS(bdescr_free(CurrentNursery) -
+                           bdescr_start(CurrentNursery));
             CurrentNursery = bdescr_link(CurrentNursery);
+            bdescr_free(CurrentNursery) = bdescr_start(CurrentNursery);
             OPEN_NURSERY();
             if (Capability_context_switch(MyCapability()) != 0 :: CInt ||
-                Capability_interrupt(MyCapability())      != 0 :: CInt) {
+                Capability_interrupt(MyCapability())      != 0 :: CInt ||
+                (StgTSO_alloc_limit(CurrentTSO) `lt` (0::I64) &&
+                 (TO_W_(StgTSO_flags(CurrentTSO)) & TSO_ALLOC_LIMIT) != 0)) {
                 ret = ThreadYielding;
                 goto sched;
             } else {
@@ -122,24 +130,24 @@ stg_gc_noregs
     jump stg_returnToSched [R1];
 }
 
-#define HP_GENERIC                             \
+#define HP_GENERIC                              \
     PRE_RETURN(HeapOverflow, ThreadRunGHC)      \
     jump stg_returnToSched [R1];
 
-#define BLOCK_GENERIC                          \
+#define BLOCK_GENERIC                           \
     PRE_RETURN(ThreadBlocked,  ThreadRunGHC)    \
     jump stg_returnToSched [R1];
 
-#define YIELD_GENERIC                          \
+#define YIELD_GENERIC                           \
     PRE_RETURN(ThreadYielding, ThreadRunGHC)    \
     jump stg_returnToSched [R1];
 
-#define BLOCK_BUT_FIRST(c)                     \
+#define BLOCK_BUT_FIRST(c)                      \
     PRE_RETURN(ThreadBlocked, ThreadRunGHC)     \
     R2 = c;                                     \
     jump stg_returnToSchedButFirst [R1,R2,R3];
 
-#define YIELD_TO_INTERPRETER                   \
+#define YIELD_TO_INTERPRETER                    \
     PRE_RETURN(ThreadYielding, ThreadInterpret) \
     jump stg_returnToSchedNotPaused [R1];
 
@@ -172,38 +180,55 @@ __stg_gc_enter_1 (P_ node)
    code in a few common cases.
    -------------------------------------------------------------------------- */
 
-stg_gc_prim ()
+stg_gc_prim (W_ fun)
 {
-    W_ fun;
-    fun = R9;
     call stg_gc_noregs ();
     jump fun();
 }
 
-stg_gc_prim_p (P_ arg)
+stg_gc_prim_p (P_ arg, W_ fun)
 {
-    W_ fun;
-    fun = R9;
     call stg_gc_noregs ();
     jump fun(arg);
 }
 
-stg_gc_prim_pp (P_ arg1, P_ arg2)
+stg_gc_prim_pp (P_ arg1, P_ arg2, W_ fun)
 {
-    W_ fun;
-    fun = R9;
     call stg_gc_noregs ();
     jump fun(arg1,arg2);
 }
 
-stg_gc_prim_n (W_ arg)
+stg_gc_prim_n (W_ arg, W_ fun)
 {
-    W_ fun;
-    fun = R9;
     call stg_gc_noregs ();
     jump fun(arg);
 }
 
+INFO_TABLE_RET(stg_gc_prim_p_ll, RET_SMALL, W_ info, P_ arg, W_ fun)
+    /* explicit stack */
+{
+    W_ fun;
+    P_ arg;
+    fun = Sp(2);
+    arg = Sp(1);
+    Sp_adj(3);
+    R1 = arg;
+    jump fun [R1];
+}
+
+stg_gc_prim_p_ll
+{
+    W_ fun;
+    P_ arg;
+    fun = R2;
+    arg = R1;
+    Sp_adj(-3);
+    Sp(2) = fun;
+    Sp(1) = arg;
+    Sp(0) = stg_gc_prim_p_ll_info;
+    jump stg_gc_noregs [];
+}
+
 /* -----------------------------------------------------------------------------
    stg_enter_checkbh is just like stg_enter, except that we also call
    checkBlockingQueues().  The point of this is that the GC can
@@ -339,7 +364,7 @@ stg_gc_pppp return (P_ arg1, P_ arg2, P_ arg3, P_ arg4)
    Generic function entry heap check code.
 
    At a function entry point, the arguments are as per the calling convention,
-   i.e. some in regs and some on the stack.  There may or may not be 
+   i.e. some in regs and some on the stack.  There may or may not be
    a pointer to the function closure in R1 - if there isn't, then the heap
    check failure code in the function will arrange to load it.
 
@@ -348,16 +373,16 @@ stg_gc_pppp return (P_ arg1, P_ arg2, P_ arg3, P_ arg4)
    registers and return to the scheduler.
 
    This code arranges the stack like this:
-        
+
          |        ....         |
          |        args         |
-        +---------------------+
+         +---------------------+
          |      f_closure      |
-        +---------------------+
+         +---------------------+
          |        size         |
-        +---------------------+
+         +---------------------+
          |   stg_gc_fun_info   |
-        +---------------------+
+         +---------------------+
 
    The size is the number of words of arguments on the stack, and is cached
    in the frame in order to simplify stack walking: otherwise the size of
@@ -376,21 +401,22 @@ __stg_gc_fun /* explicit stack */
     // cache the size
     type = TO_W_(StgFunInfoExtra_fun_type(info));
     if (type == ARG_GEN) {
-       size = BITMAP_SIZE(StgFunInfoExtra_bitmap(info));
-    } else { 
-       if (type == ARG_GEN_BIG) {
+        size = BITMAP_SIZE(StgFunInfoExtra_bitmap(info));
+    } else {
+        if (type == ARG_GEN_BIG) {
 #ifdef TABLES_NEXT_TO_CODE
             // bitmap field holds an offset
-            size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info)
-                                        + %GET_ENTRY(UNTAG(R1)) /* ### */ );
+            size = StgLargeBitmap_size(
+                      TO_W_(StgFunInfoExtraRev_bitmap_offset(info))
+                      + %GET_ENTRY(UNTAG(R1)) /* ### */ );
 #else
-           size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info) );
+            size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info) );
 #endif
-       } else {
-           size = BITMAP_SIZE(W_[stg_arg_bitmaps + WDS(type)]);
-       }
+        } else {
+            size = BITMAP_SIZE(W_[stg_arg_bitmaps + WDS(type)]);
+        }
     }
-    
+
 #ifdef NO_ARG_REGS
     // we don't have to save any registers away
     Sp_adj(-3);
@@ -410,9 +436,9 @@ __stg_gc_fun /* explicit stack */
         Sp(0) = stg_gc_fun_info;
         // DEBUG_ONLY(foreign "C" debugBelch("stg_fun_gc_gen(ARG_GEN)"););
         jump stg_gc_noregs [];
-    } else { 
+    } else {
         jump W_[stg_stack_save_entries + WDS(type)] [*]; // all regs live
-           // jumps to stg_gc_noregs after saving stuff
+            // jumps to stg_gc_noregs after saving stuff
     }
 #endif /* !NO_ARG_REGS */
 }
@@ -438,21 +464,21 @@ INFO_TABLE_RET ( stg_gc_fun, RET_FUN )
 #else
     W_ info;
     W_ type;
-    
+
     info = %GET_FUN_INFO(UNTAG(R1));
     type = TO_W_(StgFunInfoExtra_fun_type(info));
     if (type == ARG_GEN || type == ARG_GEN_BIG) {
         jump StgFunInfoExtra_slow_apply(info) [R1];
-    } else { 
-       if (type == ARG_BCO) {
-           // cover this case just to be on the safe side
-           Sp_adj(-2);
-           Sp(1) = R1;
-           Sp(0) = stg_apply_interp_info;
+    } else {
+        if (type == ARG_BCO) {
+            // cover this case just to be on the safe side
+            Sp_adj(-2);
+            Sp(1) = R1;
+            Sp(0) = stg_apply_interp_info;
             jump stg_yield_to_interpreter [];
-       } else {
+        } else {
             jump W_[stg_ap_stack_entries + WDS(type)] [R1];
-       }
+        }
     }
 #endif
 }
@@ -487,21 +513,21 @@ stg_block_noregs
 /* -----------------------------------------------------------------------------
  * takeMVar/putMVar-specific blocks
  *
- * Stack layout for a thread blocked in takeMVar:
- *      
+ * Stack layout for a thread blocked in takeMVar/readMVar:
+ *
  *       ret. addr
  *       ptr to MVar   (R1)
- *       stg_block_takemvar_info
+ *       stg_block_takemvar_info (or stg_block_readmvar_info)
  *
  * Stack layout for a thread blocked in putMVar:
- *      
+ *
  *       ret. addr
  *       ptr to Value  (R2)
  *       ptr to MVar   (R1)
  *       stg_block_putmvar_info
  *
  * See PrimOps.hc for a description of the workings of take/putMVar.
- * 
+ *
  * -------------------------------------------------------------------------- */
 
 INFO_TABLE_RET ( stg_block_takemvar, RET_SMALL, W_ info_ptr, P_ mvar )
@@ -531,6 +557,33 @@ stg_block_takemvar /* mvar passed in R1 */
     BLOCK_BUT_FIRST(stg_block_takemvar_finally);
 }
 
+INFO_TABLE_RET ( stg_block_readmvar, RET_SMALL, W_ info_ptr, P_ mvar )
+    return ()
+{
+    jump stg_readMVarzh(mvar);
+}
+
+// code fragment executed just before we return to the scheduler
+stg_block_readmvar_finally
+{
+    W_ r1, r3;
+    r1 = R1;
+    r3 = R3;
+    unlockClosure(R3, stg_MVAR_DIRTY_info);
+    R1 = r1;
+    R3 = r3;
+    jump StgReturn [R1];
+}
+
+stg_block_readmvar /* mvar passed in R1 */
+{
+    Sp_adj(-2);
+    Sp(1) = R1;
+    Sp(0) = stg_block_readmvar_info;
+    R3 = R1; // mvar communicated to stg_block_readmvar_finally in R3
+    BLOCK_BUT_FIRST(stg_block_readmvar_finally);
+}
+
 INFO_TABLE_RET( stg_block_putmvar, RET_SMALL, W_ info_ptr,
                 P_ mvar, P_ val )
     return ()
@@ -558,10 +611,10 @@ stg_block_putmvar (P_ mvar, P_ val)
    }
 }
 
-stg_block_blackhole
+stg_block_blackhole (P_ node)
 {
     Sp_adj(-2);
-    Sp(1) = R1;
+    Sp(1) = node;
     Sp(0) = stg_enter_info;
     BLOCK_GENERIC;
 }
@@ -637,13 +690,24 @@ stg_block_async_void
    STM-specific waiting
    -------------------------------------------------------------------------- */
 
-stg_block_stmwait_finally
-{
-    ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr");
-    jump StgReturn [R1];
-}
-
 stg_block_stmwait
 {
-    BLOCK_BUT_FIRST(stg_block_stmwait_finally);
+    // When blocking on an MVar we have to be careful to only release
+    // the lock on the MVar at the very last moment (using
+    // BLOCK_BUT_FIRST()), since when we release the lock another
+    // Capability can wake up the thread, which modifies its stack and
+    // other state.  This is not a problem for STM, because STM
+    // wakeups are non-destructive; the waker simply calls
+    // tryWakeupThread() which sends a message to the owner
+    // Capability.  So the moment we release this lock we might start
+    // getting wakeup messages, but that's perfectly harmless.
+    //
+    // Furthermore, we *must* release these locks, just in case an
+    // exception is raised in this thread by
+    // maybePerformBlockedException() while exiting to the scheduler,
+    // which will abort the transaction, which needs to obtain a lock
+    // on all the TVars to remove the thread from the queues.
+    //
+    ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr");
+    BLOCK_GENERIC;
 }