Re-working of the breakpoint support

This is the result of Bernie Pope's internship work at MSR Cambridge,
with some subsequent improvements by me.  The main plan was to

 (a) Reduce the overhead for breakpoints, so we could enable 
     the feature by default without incurrent a significant penalty
 (b) Scatter more breakpoint sites throughout the code

Currently we can set a breakpoint on almost any subexpression, and the
overhead is around 1.5x slower than normal GHCi.  I hope to be able to
get this down further and/or allow breakpoints to be turned off.

This patch also fixes up :print following the recent changes to
constructor info tables.  (most of the :print tests now pass)

We now support single-stepping, which just enables all breakpoints.

  :step <expr>     executes <expr> with single-stepping turned on
  :step            single-steps from the current breakpoint

The mechanism is quite different to the previous implementation.  We
share code with the HPC (haskell program coverage) implementation now.
The coverage pass annotates source code with "tick" locations which
are tracked by the coverage tool.  In GHCi, each "tick" becomes a
potential breakpoint location.

Previously breakpoints were compiled into code that magically invoked
a nested instance of GHCi.  Now, a breakpoint causes the current
thread to block and control is returned to GHCi.

See the wiki page for more details and the current ToDo list:

  http://hackage.haskell.org/trac/ghc/wiki/NewGhciDebugger

6 files changed, 266 insertions, 26 deletions

diff --git a/rts/Disassembler.c b/rts/Disassembler.c
index 4407c77f3b..0620e99967 100644
--- a/rts/Disassembler.c
+++ b/rts/Disassembler.c
@@ -43,6 +43,11 @@ disInstr ( StgBCO *bco, int pc )
 
    instr = instrs[pc++];
    switch (instr) {
+      case bci_BRK_FUN:
+         debugBelch ("BRK_FUN  " );  printPtr( ptrs[instrs[pc]] ); 
+         debugBelch (" %d ", instrs[pc+1]); printPtr( ptrs[instrs[pc+2]] ); debugBelch("\n" );
+         pc += 3;
+         break;
       case bci_SWIZZLE:
          debugBelch("SWIZZLE stkoff %d by %d\n",
                          instrs[pc], (signed int)instrs[pc+1]);
diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index 62fd2c2ef2..188693ccb6 100644
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -83,6 +83,7 @@ allocate_NONUPD (int n_words)
     return allocate(stg_max(sizeofW(StgHeader)+MIN_PAYLOAD_SIZE, n_words));
 }
 
+rtsBool stop_next_breakpoint = rtsFalse;
 
 #ifdef INTERP_STATS
 
@@ -103,6 +104,7 @@ int it_ofreq[27];
 int it_oofreq[27][27];
 int it_lastopc;
 
+
 #define INTERP_TICK(n) (n)++
 
 void interp_startup ( void )
@@ -175,6 +177,9 @@ static StgWord app_ptrs_itbl[] = {
     (W_)&stg_ap_pppppp_info,
 };
 
+HsStablePtr breakPointIOAction; // points to the IO action which is executed on a breakpoint
+                                // it is set in main/GHC.hs:runStmt
+
 Capability *
 interpretBCO (Capability* cap)
 {
@@ -198,8 +203,8 @@ interpretBCO (Capability* cap)
     //      	+---------------+
     //       
     if (Sp[0] == (W_)&stg_enter_info) {
-	Sp++;
-	goto eval;
+       Sp++;
+       goto eval;
     }
 
     // ------------------------------------------------------------------------
@@ -284,8 +289,10 @@ eval_obj:
 	break;
 	
     case BCO:
+    {
 	ASSERT(((StgBCO *)obj)->arity > 0);
 	break;
+    }
 
     case AP:	/* Copied from stg_AP_entry. */
     {
@@ -672,6 +679,7 @@ do_apply:
     // Sadly we have three different kinds of stack/heap/cswitch check
     // to do:
 
+
 run_BCO_return:
     // Heap check
     if (doYouWantToGC()) {
@@ -680,6 +688,7 @@ run_BCO_return:
     }
     // Stack checks aren't necessary at return points, the stack use
     // is aggregated into the enclosing function entry point.
+
     goto run_BCO;
     
 run_BCO_return_unboxed:
@@ -689,6 +698,7 @@ run_BCO_return_unboxed:
     }
     // Stack checks aren't necessary at return points, the stack use
     // is aggregated into the enclosing function entry point.
+
     goto run_BCO;
     
 run_BCO_fun:
@@ -715,6 +725,7 @@ run_BCO_fun:
 	Sp[0] = (W_)&stg_apply_interp_info; // placeholder, really
 	RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
     }
+
     goto run_BCO;
     
     // Now, actually interpret the BCO... (no returning to the
@@ -723,7 +734,7 @@ run_BCO:
     INTERP_TICK(it_BCO_entries);
     {
 	register int       bciPtr     = 1; /* instruction pointer */
-    register StgWord16 bci;
+        register StgWord16 bci;
 	register StgBCO*   bco        = (StgBCO*)obj;
 	register StgWord16* instrs    = (StgWord16*)(bco->instrs->payload);
 	register StgWord*  literals   = (StgWord*)(&bco->literals->payload[0]);
@@ -753,6 +764,7 @@ run_BCO:
 		 //if (do_print_stack) checkStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
 	    );
 
+
 	INTERP_TICK(it_insns);
 
 #ifdef INTERP_STATS
@@ -769,6 +781,88 @@ run_BCO:
 
     switch (bci & 0xFF) {
 
+        /* check for a breakpoint on the beginning of a let binding */
+        case bci_BRK_FUN: 
+        {
+            int arg1_brk_array, arg2_array_index, arg3_freeVars;
+            StgArrWords *breakPoints;
+            int returning_from_break;     /* are we resuming execution from a breakpoint?
+                                          **   if yes, then don't break this time around */
+            StgClosure *ioAction;         // the io action to run at a breakpoint
+
+            StgAP_STACK *new_aps;         // a closure to save the top stack frame on the heap
+            int i;
+            int size_words;
+
+            arg1_brk_array      = BCO_NEXT;  /* first argument of break instruction */
+            arg2_array_index    = BCO_NEXT;  /* second dargument of break instruction */
+            arg3_freeVars       = BCO_NEXT;  /* third argument of break instruction */
+
+            // check if we are returning from a breakpoint - this info is stored in
+            // the flags field of the current TSO
+            returning_from_break = cap->r.rCurrentTSO->flags & TSO_STOPPED_ON_BREAKPOINT; 
+
+            // if we are returning from a break then skip this section and continue executing
+            if (!returning_from_break)
+            {
+               breakPoints = (StgArrWords *) BCO_PTR(arg1_brk_array);
+
+               // stop the current thread if either the "stop_next_breakpoint" flag is true
+               // OR if the breakpoint flag for this particular expression is true
+               if (stop_next_breakpoint == rtsTrue || breakPoints->payload[arg2_array_index] == rtsTrue)
+               {
+                  stop_next_breakpoint = rtsFalse; // make sure we don't automatically stop at the next breakpoint
+
+                  // allocate memory for a new AP_STACK, enough to store the top stack frame
+                  // plus an stg_apply_interp_info pointer and a pointer to the BCO
+                  size_words = BCO_BITMAP_SIZE(obj) + 2;
+                  new_aps = (StgAP_STACK *) allocate (AP_STACK_sizeW(size_words));
+                  SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM); 
+                  new_aps->size = size_words;
+                  // we should never enter new_aps->fun, so it is assigned to a dummy value
+                  // ToDo: fixme to something that explodes with an error if you enter it 
+                  new_aps->fun = &stg_dummy_ret_closure; 
+
+                  // fill in the payload of the AP_STACK 
+                  new_aps->payload[0] = (W_)&stg_apply_interp_info;
+                  new_aps->payload[1] = (W_)obj;
+
+                  // copy the contents of the top stack frame into the AP_STACK
+                  for (i = 2; i < size_words; i++)
+                  {
+                     new_aps->payload[i] = (W_)Sp[i-2];
+                  }
+
+                  // prepare the stack so that we can call the breakPointIOAction
+                  // and ensure that the stack is in a reasonable state for the GC
+                  // and so that execution of this BCO can continue when we resume
+                  ioAction = (StgClosure *) deRefStablePtr (breakPointIOAction);
+                  Sp -= 7;
+                  Sp[6] = (W_)obj;   
+                  Sp[5] = (W_)&stg_apply_interp_info;
+                  Sp[4] = (W_)new_aps;                 /* the AP_STACK */
+                  Sp[3] = (W_)BCO_PTR(arg3_freeVars);  /* the info about local vars of the breakpoint */
+                  Sp[2] = (W_)&stg_ap_ppv_info;
+                  Sp[1] = (W_)ioAction;                /* apply the IO action to its two arguments above */
+                  Sp[0] = (W_)&stg_enter_info;         /* get ready to run the IO action */
+
+                  // set the flag in the TSO to say that we are now stopping at a breakpoint
+                  // so that when we resume we don't stop on the same breakpoint that we already
+                  // stopped at just now 
+                  cap->r.rCurrentTSO->flags |= TSO_STOPPED_ON_BREAKPOINT;
+
+                  // stop this thread and return to the scheduler - eventually we will come back
+                  // and the IO action on the top of the stack will be executed
+                  RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
+               }
+            }
+            // record that this thread is not stopped at a breakpoint anymore
+            cap->r.rCurrentTSO->flags &= ~TSO_STOPPED_ON_BREAKPOINT;
+
+            // continue normal execution of the byte code instructions
+	    goto nextInsn;
+        }
+
 	case bci_STKCHECK: {
 	    // Explicit stack check at the beginning of a function
 	    // *only* (stack checks in case alternatives are
@@ -1256,7 +1350,7 @@ run_BCO:
 	    bciPtr     = nextpc;
 	    goto nextInsn;
 	}
-
+ 
 	case bci_CASEFAIL:
 	    barf("interpretBCO: hit a CASEFAIL");
 	    
@@ -1271,3 +1365,32 @@ run_BCO:
 
     barf("interpretBCO: fell off end of the interpreter");
 }
+
+/* temporary code for peeking inside a AP_STACK and pulling out values
+   based on their stack offset - used in the debugger for inspecting
+   the local values of a breakpoint
+*/
+HsStablePtr rts_getApStackVal (HsStablePtr, int);
+HsStablePtr rts_getApStackVal (HsStablePtr apStackSptr, int offset)
+{
+   HsStablePtr resultSptr;
+   StgAP_STACK *apStack;
+   StgClosure **payload;
+   StgClosure *val;
+
+   apStack = (StgAP_STACK *) deRefStablePtr (apStackSptr);
+   payload = apStack->payload;
+   val = (StgClosure *) payload[offset+2];
+   resultSptr = getStablePtr (val); 
+   return resultSptr;
+}
+
+/* set the single step flag for the debugger to True -
+   it gets set back to false in the interpreter everytime
+   we hit a breakpoint
+*/
+void rts_setStepFlag (void);
+void rts_setStepFlag (void)
+{
+   stop_next_breakpoint = rtsTrue;
+}
diff --git a/rts/Linker.c b/rts/Linker.c
index 4ab84eddcd..58ee9392c6 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -525,8 +525,8 @@ typedef struct _RtsSymbolVal {
       SymX(hs_free_stable_ptr)			\
       SymX(hs_free_fun_ptr)			\
       SymX(initLinker)				\
-      SymX(infoPtrzh_fast)                      \
-      SymX(closurePayloadzh_fast)               \
+      SymX(unpackClosurezh_fast)                \
+      SymX(getApStackValzh_fast)                \
       SymX(int2Integerzh_fast)			\
       SymX(integer2Intzh_fast)			\
       SymX(integer2Wordzh_fast)			\
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 31f58d1f12..bb9faddef5 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -1823,6 +1823,7 @@ newBCOzh_fast
     W_ bco, bitmap_arr, bytes, words;
     
     bitmap_arr = R5;
+
     words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
     bytes = WDS(words);
 
@@ -1876,34 +1877,48 @@ mkApUpd0zh_fast
     RET_P(ap);
 }
 
-infoPtrzh_fast
-{
-/* args: R1 = closure to analyze */
-   
-  MAYBE_GC(R1_PTR, infoPtrzh_fast);
-
-  W_ info;
-  info = %GET_STD_INFO(R1);
-  RET_N(info);
-}
-
-closurePayloadzh_fast
+unpackClosurezh_fast
 {
 /* args: R1 = closure to analyze */
 // TODO: Consider the absence of ptrs or nonptrs as a special case ?
 
-    MAYBE_GC(R1_PTR, closurePayloadzh_fast);
-
     W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
     info  = %GET_STD_INFO(R1);
     ptrs  = TO_W_(%INFO_PTRS(info)); 
     nptrs = TO_W_(%INFO_NPTRS(info));
-    p = 0;
 
-    ALLOC_PRIM (SIZEOF_StgMutArrPtrs + WDS(ptrs), R1_PTR, closurePayloadzh_fast);
-    ptrs_arr = Hp - SIZEOF_StgMutArrPtrs - WDS(ptrs) + WDS(1);
+    // Some closures have non-standard layout, so we omit those here.
+    W_ type;
+    type = TO_W_(%INFO_TYPE(info));
+    switch [0 .. N_CLOSURE_TYPES] type {
+    case THUNK_SELECTOR : {
+        ptrs = 1;
+        nptrs = 0;
+        goto out;
+    }
+    case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, 
+         THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : {
+        ptrs = 0;
+        nptrs = 0;
+        goto out;
+    }
+    default: {
+        goto out;
+    }}
+out:
+
+    W_ ptrs_arr_sz, nptrs_arr_sz;
+    nptrs_arr_sz = SIZEOF_StgArrWords   + WDS(nptrs);
+    ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs);
+
+    ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, unpackClosurezh_fast);
+
+    ptrs_arr  = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
+    nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
+
     SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, W_[CCCS]);
     StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
+    p = 0;
 for:
     if(p < ptrs) {
     	 W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(R1,p);
@@ -1911,8 +1926,6 @@ for:
 	 goto for;
     }
     
-    ALLOC_PRIM (SIZEOF_StgArrWords + WDS(nptrs), R1_PTR, closurePayloadzh_fast);
-    nptrs_arr = Hp - SIZEOF_StgArrWords - WDS(nptrs) + WDS(1);
     SET_HDR(nptrs_arr, stg_ARR_WORDS_info, W_[CCCS]);
     StgArrWords_words(nptrs_arr) = nptrs;
     p = 0;
@@ -1922,7 +1935,7 @@ for2:
     	 p = p + 1;
 	 goto for2;
     }
-    RET_PP(ptrs_arr, nptrs_arr);
+    RET_NPP(info, ptrs_arr, nptrs_arr);
 }
 
 /* -----------------------------------------------------------------------------
@@ -2149,3 +2162,16 @@ noDuplicatezh_fast
         jump %ENTRY_CODE(Sp(0));
     }
 }
+
+getApStackValzh_fast
+{
+   W_ ap_stack, offset, val;
+
+   /* args: R1 = tso, R2 = offset */
+   ap_stack = R1;
+   offset   = R2;
+
+   val = StgClosure_payload(ap_stack,offset); 
+
+   RET_P(val);
+}
diff --git a/rts/Printer.c b/rts/Printer.c
index 6da32fc6f8..28cdd0d4ab 100644
--- a/rts/Printer.c
+++ b/rts/Printer.c
@@ -136,6 +136,7 @@ printClosure( StgClosure *obj )
     case CONSTR_NOCAF_STATIC:
         {
             StgWord i, j;
+
 #ifdef PROFILING
 	    debugBelch("%s(", info->prof.closure_desc);
 	    debugBelch("%s", obj->header.prof.ccs->cc->label);
@@ -1105,6 +1106,88 @@ findPtr(P_ p, int follow)
   }
 }
 
+/* prettyPrintClosure() is for printing out a closure using the data constructor
+   names found in the info tables. Closures are printed in a fashion that resembles
+   their Haskell representation. Useful during debugging.
+
+   Todo: support for more closure types, and support for non pointer fields in the
+   payload.
+*/ 
+
+void prettyPrintClosure_ (StgClosure *);
+
+void prettyPrintClosure (StgClosure *obj)
+{
+   prettyPrintClosure_ (obj);
+   debugBelch ("\n");
+}
+
+void prettyPrintClosure_ (StgClosure *obj)
+{
+    StgInfoTable *info;
+    StgConInfoTable *con_info;
+
+    /* collapse any indirections */
+    unsigned int type;
+    type = get_itbl(obj)->type;
+           
+    while (type == IND ||
+           type == IND_STATIC ||
+           type == IND_OLDGEN ||
+           type == IND_PERM ||
+           type == IND_OLDGEN_PERM) 
+    {
+      obj = ((StgInd *)obj)->indirectee;
+      type = get_itbl(obj)->type;
+    }
+
+    /* find the info table for this object */
+    info = get_itbl(obj);
+
+    /* determine what kind of object we have */
+    switch (info->type) 
+    {
+        /* full applications of data constructors */
+        case CONSTR:
+        case CONSTR_1_0: 
+        case CONSTR_0_1:
+        case CONSTR_1_1: 
+        case CONSTR_0_2: 
+        case CONSTR_2_0:
+        case CONSTR_STATIC:
+        case CONSTR_NOCAF_STATIC: 
+        {
+           int i; 
+           char *descriptor;
+
+           /* find the con_info for the constructor */
+           con_info = get_con_itbl (obj);
+
+           /* obtain the name of the constructor */
+           descriptor = con_info->con_desc;
+
+           debugBelch ("(%s", descriptor);
+
+           /* process the payload of the closure */
+           /* we don't handle non pointers at the moment */
+           for (i = 0; i < info->layout.payload.ptrs; i++)
+           {
+              debugBelch (" ");
+              prettyPrintClosure_ ((StgClosure *) obj->payload[i]);
+           }
+           debugBelch (")");
+           break;
+        }
+
+        /* if it isn't a constructor then just print the closure type */
+        default:
+        {
+           debugBelch ("<%s>", info_type(obj));
+           break;
+        }
+    }
+}
+
 #else /* DEBUG */
 void printPtr( StgPtr p )
 {
@@ -1115,4 +1198,6 @@ void printObj( StgClosure *obj )
 {
     debugBelch("obj 0x%p (enable -DDEBUG for more info) " , obj );
 }
+
+
 #endif /* DEBUG */
diff --git a/rts/Printer.h b/rts/Printer.h
index 54bf611250..689c2f8d4a 100644
--- a/rts/Printer.h
+++ b/rts/Printer.h
@@ -13,6 +13,7 @@ extern void   	   printPtr        ( StgPtr p );
 extern void   	   printObj        ( StgClosure *obj );
 
 #ifdef DEBUG
+extern void        prettyPrintClosure (StgClosure *obj);
 extern void   	   printClosure    ( StgClosure *obj );
 extern StgStackPtr printStackObj   ( StgStackPtr sp );
 extern void        printStackChunk ( StgStackPtr sp, StgStackPtr spLim );