Use a primop for getting the fields of the AP_STACK rather than an FFI call

This means we can avoid some StablePtrs, and also catch cases where
the AP_STACK has been evaluated (this can happen with :history, see
the hist001 test).

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 7ed6fac..b53e015 100644 (file)
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -58,6 +58,7 @@ import Module
 import Panic
 import UniqFM
 import Maybes
+import ErrUtils
 import Util
 import SrcLoc
 import BreakArray
@@ -431,8 +432,18 @@ bindLocalsAtBreakpoint hsc_env apStack info = do
                     | otherwise              = False
 
    let (ids, offsets) = unzip pointers
-   hValues <- mapM (getIdValFromApStack apStack) offsets
-   new_ids <- zipWithM mkNewId occs ids
+
+   -- It might be that getIdValFromApStack fails, because the AP_STACK
+   -- has been accidentally evaluated, or something else has gone wrong.
+   -- So that we don't fall over in a heap when this happens, just don't
+   -- bind any free variables instead, and we emit a warning.
+   mb_hValues <- mapM (getIdValFromApStack apStack) offsets
+   let filtered_ids = [ id | (id, Just _) <- zip ids mb_hValues ]
+   when (any isNothing mb_hValues) $
+      debugTraceMsg (hsc_dflags hsc_env) 1 $
+         text "Warning: _result has been evaluated, some bindings have been lost"
+
+   new_ids <- zipWithM mkNewId occs filtered_ids
    let names = map idName new_ids
 
    -- make an Id for _result.  We use the Unique of the FastString "_result";
@@ -460,7 +471,7 @@ bindLocalsAtBreakpoint hsc_env apStack info = do
    let   ictxt0 = hsc_IC hsc_env
          ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
 
-   Linker.extendLinkEnv (zip names hValues)
+   Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
    return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span)
   where
@@ -485,19 +496,15 @@ skolemiseTyVar :: TyVar -> TyVar
 skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar) 
                                  (SkolemTv RuntimeUnkSkol)
 
--- Todo: turn this into a primop, and provide special version(s) for
--- unboxed things
-foreign import ccall unsafe "rts_getApStackVal" 
-        getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
-
-getIdValFromApStack :: HValue -> Int -> IO HValue
-getIdValFromApStack apStack stackDepth = do
-     apSptr <- newStablePtr apStack
-     resultSptr <- getApStackVal apSptr (stackDepth - 1)
-     result <- deRefStablePtr resultSptr
-     freeStablePtr apSptr
-     freeStablePtr resultSptr 
-     return (unsafeCoerce# result)
+getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
+getIdValFromApStack apStack (I# stackDepth) = do
+   case getApStackVal# apStack (stackDepth +# 1#) of
+                                -- The +1 is magic!  I don't know where it comes
+                                -- from, but this makes things line up.  --SDM
+        (# ok, result #) ->
+            case ok of
+              0# -> return Nothing -- AP_STACK not found
+              _  -> return (Just (unsafeCoerce# result))
 
 pushResume :: HscEnv -> Resume -> HscEnv
 pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
@@ -549,7 +556,7 @@ consBL a (BL len bound left right)
 
 toListBL (BL _ _ left right) = left ++ reverse right
 
-lenBL (BL len _ _ _) = len
+-- lenBL (BL len _ _ _) = len
 
 -- -----------------------------------------------------------------------------
 -- | Set the interactive evaluation context.

diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 1d46095..89b0260 100644 (file)
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -1743,6 +1743,10 @@ primop  UnpackClosureOp "unpackClosure#" GenPrimOp
    with
    out_of_line = True
 
+primop  GetApStackValOp "getApStackVal#" GenPrimOp
+   a -> Int# -> (# Int#, b #)
+   with
+   out_of_line = True
 
 ------------------------------------------------------------------------
 section "Etc" 

diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index c40d894..fbbda9d 100644 (file)
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -1375,25 +1375,6 @@ 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 ((P_)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

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index bb9fadd..cd34846 100644 (file)
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -2165,13 +2165,18 @@ noDuplicatezh_fast
 
 getApStackValzh_fast
 {
-   W_ ap_stack, offset, val;
+   W_ ap_stack, offset, val, ok;
 
-   /* args: R1 = tso, R2 = offset */
+   /* args: R1 = AP_STACK, R2 = offset */
    ap_stack = R1;
    offset   = R2;
 
-   val = StgClosure_payload(ap_stack,offset); 
-
-   RET_P(val);
+   if (%INFO_PTR(ap_stack) == stg_AP_STACK_info) {
+        ok = 1;
+        val = StgAP_STACK_payload(ap_stack,offset); 
+   } else {
+        ok = 0;
+        val = R1;
+   }
+   RET_NP(ok,val);
 }