From efb02b428941021771c9b9b955bba3ec0214dbaf Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 3 May 2007 15:19:41 +0000 Subject: [PATCH] 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). --- compiler/main/InteractiveEval.hs | 41 ++++++++++++++++++++++---------------- compiler/prelude/primops.txt.pp | 4 ++++ rts/Interpreter.c | 19 ------------------ rts/PrimOps.cmm | 15 +++++++++----- 4 files changed, 38 insertions(+), 41 deletions(-) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 7ed6fac..b53e015 100644 --- 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 --- 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 --- 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 --- 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); } -- 1.7.10.4