From 74fecb134bd12b783ce6acf3c1a68672cc8d58cc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 19 Feb 2008 23:26:07 -0600 Subject: [PATCH] New single stepper work in progress #2 --- extra/tools/interpreter/interpreter.factor | 234 +++++++++++++++------ 1 file changed, 172 insertions(+), 62 deletions(-) diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor index 3be832aec8..ed640918cb 100755 --- a/extra/tools/interpreter/interpreter.factor +++ b/extra/tools/interpreter/interpreter.factor @@ -1,42 +1,88 @@ -! Copyright (C) 2004, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs classes combinators sequences.private -continuations continuations.private generic hashtables io kernel -kernel.private math namespaces namespaces.private prettyprint -quotations sequences splitting strings threads -vectors words ; -IN: tools.interpreter - : walk ( quot -- ) \ break add* call ; -TUPLE: interpreter continuation ; +SYMBOL: walker-hook -: interpreter construct-empty ; +! Thread local +SYMBOL: interpreter-thread -GENERIC# restore 1 ( obj interpreter -- ) +: get-interpreter-thread ( -- thread ) + interpreter-thread tget dup [ + walker-hook get + [ "No walker hook" throw ] or + interpreter-thread + ] unless* ; -M: f restore - set-interpreter-continuation ; +: break ( -- ) + callstack [ + over set-continuation-callstack -M: continuation restore - >r clone r> set-interpreter-continuation ; + interpreter-thread send-synchronous { + { [ dup continuation? ] [ (continue) ] } + { [ dup quotation? ] [ call ] } + { [ dup not ] [ "Single stepping abandoned" throw ] } + } cond + ] curry callcc0 ; -: with-interpreter-datastack ( quot interpreter -- ) - interpreter-continuation [ - continuation-data - swap with-datastack - ] keep set-continuation-data ; inline +SYMBOL: +suspended+ +SYMBOL: +running+ +SYMBOL: +stopped+ -M: pair restore - >r first2 r> [ restore ] keep - >r [ nip f ] curry r> with-interpreter-datastack ; +! Messages sent to interpreter thread +SYMBOL: status + +SYMBOL: step +SYMBOL: step-out +SYMBOL: step-into +SYMBOL: step-all +SYMBOL: step-back +SYMBOL: detach +SYMBOL: abandon +SYMBOL: call-in + +SYMBOL: get-thread +SYMBOL: get-continuation n ndrop >c c> continue continue-with - (continue-with) stop + (continue-with) stop yield suspend sleep (spawn) + suspend } [ dup [ execute break ] curry "step-into" set-word-prop @@ -74,44 +121,107 @@ M: word (step-into) (step-into-execute) ; \ break [ break ] "step-into" set-word-prop -! Stepping -: change-innermost-frame ( quot interpreter -- ) - interpreter-continuation [ - continuation-call clone - [ - dup innermost-frame-scan 1+ - swap innermost-frame-quot - rot call - ] keep - [ set-innermost-frame-quot ] keep - ] keep set-continuation-call ; inline - -: (step) ( interpreter quot -- ) - swap - [ change-innermost-frame ] keep - [ interpreter-continuation with-walker-hook ] keep - restore ; - -PRIVATE> - -: step ( interpreter -- ) - [ - 2dup nth \ break = [ - nip - ] [ - swap 1+ cut [ break ] swap 3append - ] if - ] (step) ; - -: step-out ( interpreter -- ) - [ nip \ break add ] (step) ; - -: step-into ( interpreter -- ) +: step-into-msg ( continuation -- continuation' ) [ swap cut [ swap % unclip literalize , \ (step-into) , % ] [ ] make ] (step) ; -: step-all ( interpreter -- ) - interpreter-continuation [ (continue) ] curry in-thread ; +: status-change ( symbol -- ) + +running+ interpreter-status tget set-model ; + +: detach-msg ( -- f ) + +detached+ status-change + f interpreter-stepping? tset + f interpreter-running? tset + f ; + +: continuation-msg ( -- continuation ) + interpreter-thread tget thread-continuation box-value ; + +: keep-running f interpreter-stepping? tset ; + +: save-continuation ( continuation -- ) + dup interpreter-continuation tget set-model + interpreter-history tget push ; + +: handle-command ( continuation -- continuation' ) + t interpreter-stepping? tset + [ interpreter-stepping? tget ] [ + [ + { + ! These are sent by the walker tool. We reply and + ! keep cycling. + { status [ +suspended+ ] } + { detach [ detach-msg ] } + { get-thread [ interpreter-thread tget ] } + { get-continuation [ dup ] } + ! These change the state of the thread being + ! interpreted, so we modify the continuation and + ! output f. + { step [ (step) keep-running ] } + { step-out [ (step-out) keep-running ] } + { step-into [ (step-into) keep-running ] } + { step-all [ keep-running ] } + { abandon [ drop f keep-running ] } + ! Pass quotation to debugged thread + { call-in [ nip keep-running ] } + ! Pass previous continuation to debugged thread + { step-back [ drop interpreter-history tget pop f ] } + } case + ] handle-synchronous + ] [ ] while + dup continuation? [ dup save-continuation ] when ; + +: interpreter-stopped ( -- ) + [ + { + { detach [ detach-msg ] } + { status [ +stopped+ ] } + { get-thread [ interpreter-thread tget ] } + { get-continuation [ f ] } + [ drop f ] + } case + ] handle-synchronous + interpreter-stopped ; + +: interpreter-loop ( -- ) + [ interpreter-running? tget ] [ + [ + status-change + { + { detach [ detach-msg ] } + { get-thread [ interpreter-thread tget ] } + { get-continuation [ f ] } + ! ignore these commands while the thread is + ! running + { step [ f ] } + { step-out [ f ] } + { step-into [ f ] } + { step-all [ f ] } + { step-back [ f ] } + ! thread has exited so we exit the monitor too + { f [ interpreter-stopped ] } + ! thread hit a breakpoint and sent us the + ! continuation, so we modify it and send it back. + [ handle-command ] + } case + ] handle-synchronous + ] [ ] while; + +PRIVATE> + +: start-interpreter-thread ( thread -- thread' ) + [ + [ + interpreter-thread tset + t interpreter-running tset + f interpreter-stepping tset + f interpreter-continuation tset + V{ } clone interpreter-history tset + interpreter-loop + ] curry + ] keep + "Interpreter for " over thread-name append spawn + dup rot set-thread-;