New single stepper work in progress #2

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> 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
+: break ( -- )
-    set-interpreter-continuation ;
+    callstack [
+        over set-continuation-callstack
 
-M: continuation restore
+        interpreter-thread send-synchronous {
-    >r clone r> set-interpreter-continuation ;
+            { [ dup continuation? ] [ (continue) ] }
+            { [ dup quotation? ] [ call ] }
+            { [ dup not ] [ "Single stepping abandoned" throw ] }
+        } cond
+    ] curry callcc0 ;
 
-: with-interpreter-datastack ( quot interpreter -- )
+SYMBOL: +suspended+
-    interpreter-continuation [
+SYMBOL: +running+
-        continuation-data
+SYMBOL: +stopped+
-        swap with-datastack
-    ] keep set-continuation-data ; inline
 
-M: pair restore
+! Messages sent to interpreter thread
-    >r first2 r> [ restore ] keep
+SYMBOL: status
-    >r [ nip f ] curry r> with-interpreter-datastack ;
+
+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
 
 <PRIVATE
 
+! Thread locals
+SYMBOL: interpreter-running?
+SYMBOL: interpreter-stepping?
+SYMBOL: interpreter-continuation
+SYMBOL: interpreter-history
+
+: change-frame ( continuation quot -- continuation' )
+    #! Applies quot to innermost call frame of the
+    #! continuation.
+    over continuation-call clone
+    [
+        dup innermost-frame-scan 1+
+        swap innermost-frame-quot
+        rot call
+    ] keep
+    [ set-innermost-frame-quot ] keep
+    over set-continuation-call ; inline
+
+: step-msg ( continuation -- continuation' )
+    [
+        2dup nth \ break = [
+            nip
+        ] [
+            swap 1+ cut [ break ] swap 3append
+        ] if
+    ] change-frame ;
+
+: step-out-msg ( continuation -- continuation' )
+    [ nip \ break add ] change-frame ;
+
+GENERIC: (step-into) ( obj -- )
+
+M: wrapper (step-into) wrapped break ;
+M: object (step-into) break ;
+M: callable (step-into) \ break add* break ;
+
 : (step-into-if) ? walk ;
 
-: (step-into-dispatch)
+: (step-into-dispatch) nth walk ;
-    nth walk ;
 
 : (step-into-execute) ( word -- )
     dup "step-into" word-prop [
@@ -66,7 +112,8 @@ M: word (step-into) (step-into-execute) ;
 {
     >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
+: step-into-msg ( continuation -- continuation' )
-: 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 -- )
     [
         swap cut [
             swap % unclip literalize , \ (step-into) , %
         ] [ ] make
     ] (step) ;
 
-: step-all ( interpreter -- )
+: status-change ( symbol -- )
-    interpreter-continuation [ (continue) ] curry in-thread ;
+    +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 <model> interpreter-continuation tset
+            V{ } clone interpreter-history tset
+            interpreter-loop
+        ] curry
+    ] keep
+    "Interpreter for " over thread-name append spawn
+    dup rot set-thread-;