Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 59aacc8

Browse files
update to the new StgPoint based ProgramPoint design
1 parent 65648db commit 59aacc8

File tree

1 file changed

+26
-20
lines changed

1 file changed

+26
-20
lines changed

‎external-stg-interpreter/lib/Stg/Interpreter.hs‎

Lines changed: 26 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -161,14 +161,14 @@ stackPushRestoreProgramPoint argCount = do
161161
buildCallGraph :: StaticOrigin -> Id -> M ()
162162
buildCallGraph so hoName = do
163163
progPoint <- gets ssCurrentProgramPoint
164-
addInterClosureCallGraphEdge so progPoint $PP_Closure hoName
165-
setProgramPoint $ PP_Closure hoName
164+
addInterClosureCallGraphEdge so progPoint .PP_StgPoint.SP_RhsClosureExpr. binderToStgId $ unId hoName
165+
setProgramPoint $ PP_StgPoint.SP_RhsClosureExpr. binderToStgId $ unId hoName
166166
-- connect call sites to parent closure
167167
currentClosure <- gets ssCurrentClosure
168168
case progPoint of
169169
PP_Global -> pure ()
170170
_ -> case currentClosure of
171-
Just cloId -> addIntraClosureCallGraphEdge (PP_Closure cloId) so progPoint
171+
Just cloId -> addIntraClosureCallGraphEdge (PP_StgPoint.SP_RhsClosureExpr. binderToStgId $ unId cloId) so progPoint
172172
_ -> pure ()
173173
-- write whole program path entry
174174
fuel <- gets ssDebugFuel
@@ -242,7 +242,7 @@ builtinStgEval so a@HeapPtr{} = do
242242
-- check breakpoints and region entering
243243
let closureName = binderUniqueName $ unId hoName
244244
markClosure closureName -- HINT: this list can be deleted by a debugger command, so this is not the same as `markExecutedId`
245-
Debugger.checkBreakpoint . BkpStgPoint $ SP_RhsClosureExpr hoName
245+
Debugger.checkBreakpoint . BkpStgPoint . SP_RhsClosureExpr. binderToStgId . unId $ hoName
246246
Debugger.checkRegion closureName
247247
GC.checkGC [a] -- HINT: add local env as GC root
248248

@@ -521,18 +521,14 @@ evalStackContinuation result = \case
521521
_ -> error $ "expected a single value: " ++ show result
522522
extendedEnv = addBinderToEnv SO_Scrut resultBinder v localEnv
523523
con <- readHeapCon v
524-
case getCutShowItem alts of
525-
d@(Alt AltDefault _ _) : al -> matchFirstCon resultId extendedEnv con $ al ++ [d]
526-
_ -> matchFirstCon resultId extendedEnv con $ getCutShowItem alts
524+
matchFirstCon resultId extendedEnv con $ getCutShowItem alts
527525

528526
PrimAlt _r -> do
529527
let lit = case result of
530528
[l] -> l
531529
_ -> error $ "expected a single value: " ++ show result
532530
extendedEnv = addBinderToEnv SO_Scrut resultBinder lit localEnv
533-
case getCutShowItem alts of
534-
d@(Alt AltDefault _ _) : al -> matchFirstLit resultId extendedEnv lit $ al ++ [d]
535-
_ -> matchFirstLit resultId extendedEnv lit $ getCutShowItem alts
531+
matchFirstLit resultId extendedEnv lit $ getCutShowItem alts
536532

537533
MultiValAlt n -> do -- unboxed tuple
538534
-- NOTE: result binder is not assigned
@@ -545,7 +541,7 @@ evalStackContinuation result = \case
545541
--unless (length altBinders == length result) $ do
546542
-- stgErrorM $ "evalStackContinuation - MultiValAlt - length mismatch: " ++ show (n, altBinders, result)
547543

548-
setProgramPoint $PP_Alt resultId altCon
544+
setProgramPoint .PP_StgPoint$SP_AltExpr (binderToStgId resultBinder) 0
549545
evalExpr extendedEnv altRHS
550546

551547
PolyAlt -> do
@@ -558,7 +554,7 @@ evalStackContinuation result = \case
558554
unless (length altBinders == length result) $ do
559555
stgErrorM $ "evalStackContinuation - PolyAlt - length mismatch: " ++ show (altBinders, result)
560556
-}
561-
setProgramPoint $PP_Alt resultId altCon
557+
setProgramPoint .PP_StgPoint$SP_AltExpr (binderToStgId resultBinder) 0
562558
evalExpr extendedEnv altRHS
563559

564560
s@(RestoreExMask oldMask blockAsyncEx isInterruptible) -> do
@@ -709,7 +705,7 @@ evalExpr localEnv = \case
709705
Just curClosure <- gets ssCurrentClosure
710706
curClosureAddr <- gets ssCurrentClosureAddr
711707
stackPush (CaseOf curClosureAddr curClosure localEnv (Id scrutineeResult) (CutShow altType) $ CutShow alts)
712-
setProgramPoint . PP_Scrutinee$Id scrutineeResult
708+
setProgramPoint . PP_StgPoint.SP_CaseScrutineeExpr$ binderToStgId scrutineeResult
713709
evalExpr localEnv e
714710

715711
StgOpApp (StgPrimOp op) l t tc -> do
@@ -770,11 +766,16 @@ evalExpr localEnv = \case
770766

771767
matchFirstLit :: HasCallStack => Id -> Env -> Atom -> [Alt] -> M [Atom]
772768
matchFirstLit resultId localEnv a [Alt AltDefault _ rhs] = do
773-
setProgramPoint $PP_AltresultIdAltDefault
769+
setProgramPoint .PP_StgPoint$SP_AltExpr (binderToStgId $ unId resultId) 0
774770
evalExpr localEnv rhs
775-
matchFirstLit resultId localEnv atom alts = case head $ [a | a@Alt{..} <- alts, matchLit atom altCon] ++ (error $ "no lit match" ++ show (resultId, atom, map altCon alts)) of
776-
Alt{..} -> do
777-
setProgramPoint $ PP_Alt resultId altCon
771+
matchFirstLit resultId localEnv atom alts
772+
| indexedAlts <- zip [0..] alts
773+
, indexedAltsWithDefault <- case indexedAlts of
774+
d@(_, Alt AltDefault _ _) : xs -> xs ++ [d]
775+
xs -> xs
776+
= case head $ [a | a@(_idx, Alt{..}) <- indexedAltsWithDefault, matchLit atom altCon] ++ (error $ "no lit match" ++ show (resultId, atom, map altCon alts)) of
777+
(idx, Alt{..}) -> do
778+
setProgramPoint . PP_StgPoint $ SP_AltExpr (binderToStgId $ unId resultId) idx
778779
evalExpr localEnv altRHS
779780

780781
matchLit :: HasCallStack => Atom -> AltCon -> Bool
@@ -804,15 +805,20 @@ convertAltLit lit = case lit of
804805
l -> error $ "unsupported: " ++ show l
805806

806807
matchFirstCon :: HasCallStack => Id -> Env -> HeapObject -> [Alt] -> M [Atom]
807-
matchFirstCon resultId localEnv (Con _ (DC dc) args) alts = case [a | a@Alt{..} <- alts, matchCon dc altCon] of
808+
matchFirstCon resultId localEnv (Con _ (DC dc) args) alts
809+
| indexedAlts <- zip [0..] alts
810+
, indexedAltsWithDefault <- case indexedAlts of
811+
d@(_, Alt AltDefault _ _) : xs -> xs ++ [d]
812+
xs -> xs
813+
= case [a | a@(_idx, Alt{..}) <- indexedAltsWithDefault, matchCon dc altCon] of
808814
[] -> stgErrorM $ "no matching alts for: " ++ show resultId
809-
Alt{..} : _ -> do
815+
(idx, Alt{..}) : _ -> do
810816
let extendedEnv = case altCon of
811817
AltDataCon{} -> addManyBindersToEnv SO_AltArg altBinders args localEnv
812818
_ -> localEnv
813819
--unless (length altBinders == length args) $ do
814820
-- stgErrorM $ "matchFirstCon length mismatch: " ++ show (DC dc, altBinders, args, resultId)
815-
setProgramPoint $PP_AltresultId altCon
821+
setProgramPoint .PP_StgPoint$SP_AltExpr (binderToStgId $ unId resultId) idx
816822
evalExpr extendedEnv altRHS
817823

818824
matchCon :: HasCallStack => DataCon -> AltCon -> Bool

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /