Re-implemented single stepper for new evaluation model

core/bootstrap/primitives.factor

@@ -267,7 +267,9 @@ H{ } clone update-map set
     { "<tuple-boa>" "tuples.private" }
 	{ "class-hash" "kernel.private" }
     { "callstack>array" "kernel" }
-    { "array>callstack" "kernel" }
+    { "innermost-frame-quot" "kernel.private" }
+    { "innermost-frame-scan" "kernel.private" }
+    { "set-innermost-frame-quot" "kernel.private" }
 }
 dup length [ >r first2 r> make-primitive ] 2each
 

core/continuations/continuations-docs.factor

@@ -49,7 +49,6 @@ ARTICLE: "continuations.private" "Continuation implementation details"
 "The continuations implementation has hooks for single-steppers:"
 { $subsection walker-hook }
 { $subsection set-walker-hook }
-{ $subsection (continue) }
 { $subsection (continue-with) } ;
 
 ARTICLE: "continuations" "Continuations"
@@ -89,15 +88,11 @@ HELP: >continuation<
 { $values { "continuation" continuation } { "data" vector } { "retain" vector } { "call" vector } { "name" vector } { "catch" vector } { "c" array } }
 { $description "Takes a continuation apart into its constituents." } ;
 
-HELP: ifcc0
+HELP: ifcc
 { $values { "capture" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "restore" quotation } }
 { $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
 
-HELP: ifcc1
+{ callcc0 continue callcc1 continue-with ifcc } related-words
-{ $values { "capture" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "restore" quotation } }
-{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
-
-{ callcc0 continue callcc1 continue-with ifcc0 ifcc1 } related-words
 
 HELP: callcc0
 { $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } }
@@ -125,10 +120,6 @@ $nl
 "The walker hook must take appropriate action so that the callers of these words see the behavior that they expect." }
 { $notes "The single-stepper uses this hook to support single-stepping through code which makes use of continuations." } ;
 
-HELP: (continue)
-{ $values { "continuation" continuation } }
-{ $description "Resumes a continuation reified by " { $link callcc0 } " without invoking " { $link walker-hook } "." } ;
-
 HELP: (continue-with)
 { $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
 { $description "Resumes a continuation reified by " { $link callcc1 } " without invoking " { $link walker-hook } ". The object will be placed on the data stack when the continuation resumes." } ;

core/continuations/continuations-tests.factor

@@ -1,14 +1,8 @@
 USING: kernel math namespaces io tools.test sequences vectors
-continuations debugger parser memory arrays ;
+continuations debugger parser memory arrays words
+kernel.private ;
 IN: temporary
 
-! [ "hello" ] [
-!     [
-!         callstack [ set-callstack ] curry [ ] like -1 2array
-!         array>callstack set-callstack
-!     ] call "hello"
-! ] unit-test
-
 : (callcc1-test)
     swap 1- tuck swap ?push
     over 0 = [ "test-cc" get continue-with ] when
@@ -66,5 +60,14 @@ IN: temporary
 ! 
 ! : callstack-overflow callstack-overflow f ;
 ! [ callstack-overflow ] unit-test-fails
-! 
+
-! 
+: don't-compile-me { } [ ] each ;
+
+: foo callstack "c" set 3 don't-compile-me ;
+: bar 1 foo 2 ;
+
+[ 1 3 2 ] [ bar ] unit-test
+
+[ t ] [ \ bar word-def "c" get innermost-frame-quot = ] unit-test
+
+[ 1 ] [ "c" get innermost-frame-scan ] unit-test

core/continuations/continuations.factor

@@ -20,8 +20,6 @@ SYMBOL: restarts
 : (catch) ( quot -- newquot )
     [ swap >c call c> drop ] curry ; inline
 
-: (callcc1) 4 getenv f 4 setenv ; inline
-
 PRIVATE>
 
 : catchstack ( -- catchstack ) catchstack* clone ; inline
@@ -45,10 +43,10 @@ C: <continuation> continuation
         continuation-catch
     } get-slots ;
 
-: ifcc0 ( capture restore -- )
+: ifcc ( capture restore -- )
     #! After continuation is being captured, the stacks looks
     #! like:
-    #! ( continuation r:capture r:restore )
+    #! ( f continuation r:capture r:restore )
     #! so the 'capture' branch is taken.
     #!
     #! Note that the continuation itself is not captured as part
@@ -56,19 +54,17 @@ C: <continuation> continuation
     #!
     #! BUT...
     #!
-    #! After the continuation is resumed, (continue) pushes f,
+    #! After the continuation is resumed, (continue-with) pushes
+    #! the given value together with f,
     #! so now, the stacks looks like:
-    #! ( f r:capture r:restore )
+    #! ( value f r:capture r:restore )
     #! Execution begins right after the call to 'continuation'.
     #! The 'restore' branch is taken.
-    >r >r continuation r> r> if* ; inline
+    >r >r f continuation r> r> ?if ; inline
 
-: ifcc1 ( capture restore -- )
+: callcc0 ( quot -- ) [ drop ] ifcc ; inline
-    [ (callcc1) ] swap compose ifcc0 ; inline
 
-: callcc0 ( quot -- ) [ ] ifcc0 ; inline
+: callcc1 ( quot -- obj ) [ ] ifcc ; inline
-
-: callcc1 ( quot -- obj ) [ ] ifcc1 ; inline
 
 : set-walker-hook ( quot -- ) 3 setenv ; inline
 
@@ -76,29 +72,25 @@ C: <continuation> continuation
 
 <PRIVATE
 
-: (continue) ( continuation -- )
+: (continue-with) ( obj continuation -- )
+    swap 4 setenv
     >continuation<
     set-catchstack
     set-namestack
     set-retainstack
-    >r set-datastack f r>
+    >r set-datastack drop 4 getenv f r>
     set-callstack ;
 
-: (continue-with) ( obj continuation -- )
-    swap 4 setenv (continue) ;
-
 PRIVATE>
 
-: continue ( continuation -- )
-    [
-        walker-hook [ (continue-with) ] [ (continue) ] if*
-    ] curry (throw) ;
-
 : continue-with ( obj continuation -- )
     [
         walker-hook [ >r 2array r> ] when* (continue-with)
     ] 2curry (throw) ;
 
+: continue ( continuation -- )
+    f swap continue-with ;
+
 GENERIC: compute-restarts ( error -- seq )
 
 <PRIVATE
@@ -117,11 +109,11 @@ PRIVATE>
     (catch) [ f ] compose callcc1 ; inline
 
 : recover ( try recovery -- )
-    >r (catch) r> ifcc1 ; inline
+    >r (catch) r> ifcc ; inline
 
 : cleanup ( try cleanup-always cleanup-error -- )
     >r [ compose (catch) ] keep r> compose
-    [ dip rethrow ] curry ifcc1 ; inline
+    [ dip rethrow ] curry ifcc ; inline
 
 : attempt-all ( seq quot -- obj )
     [

core/generator/registers/registers.factor

@@ -444,8 +444,6 @@ M: loc lazy-store
     #! shuffle inputs at once.
     T{ int-regs } free-vregs [ length ] 2apply <= ;
 
-USING: io prettyprint ;
-
 : finalize-locs ( -- )
     #! Perform any deferred stack shuffling.
     [

core/inference/known-words/known-words.factor

@@ -568,9 +568,12 @@ t over set-effect-terminated?
 \ callstack>array { callstack } { array } <effect> "inferred-effect" set-word-prop
 \ callstack>array make-flushable
 
-\ array>callstack { array } { callstack } <effect> "inferred-effect" set-word-prop
-\ array>callstack make-flushable
-
 \ (sleep) { integer } { } <effect> "inferred-effect" set-word-prop
 
 \ become { array array } { } <effect> "inferred-effect" set-word-prop
+
+\ innermost-frame-quot { callstack } { quotation } <effect> "inferred-effect" set-word-prop
+
+\ innermost-frame-scan { callstack } { fixnum } <effect> "inferred-effect" set-word-prop
+
+\ set-innermost-frame-quot { quotation callstack } { } <effect> "inferred-effect" set-word-prop

core/kernel/kernel-tests.factor

@@ -74,4 +74,3 @@ IN: temporary
 [ 6 2 ] [ 1 2 [ 5 + ] dip ] unit-test
 
 [ ] [ callstack set-callstack ] unit-test
-! [ ] [ callstack callstack>array array>callstack set-callstack ] unit-test

core/kernel/kernel.factor

@@ -106,6 +106,8 @@ GENERIC: clone ( obj -- cloned )
 
 M: object clone ;
 
+M: callstack clone (clone) ;
+
 ! Tuple construction
 
 GENERIC# get-slots 1 ( tuple slots -- ... )

core/syntax/syntax.factor

@@ -24,6 +24,14 @@ IN: bootstrap.syntax
 
 { "]" "}" ";" } [ define-delimiter ] each
 
+"PRIMITIVE:" [
+    "Primitive definition is not supported" throw
+] define-syntax
+
+"CS{" [
+    "Call stack literals are not supported" throw
+] define-syntax
+
 "!" [ lexer get next-line ] define-syntax
 
 "#!" [ POSTPONE: ! ] define-syntax
@@ -72,7 +80,6 @@ IN: bootstrap.syntax
 "C{" [ \ } [ first2 rect> ] parse-literal ] define-syntax
 "T{" [ \ } [ >tuple ] parse-literal ] define-syntax
 "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
-"CS{" [ \ } [ >array array>callstack ] parse-literal ] define-syntax
 
 "POSTPONE:" [ scan-word parsed ] define-syntax
 "\\" [ scan-word literalize parsed ] define-syntax

extra/tools/interpreter/interpreter-docs.factor

@@ -2,27 +2,6 @@ USING: help.markup help.syntax kernel generic
 math hashtables quotations classes continuations ;
 IN: tools.interpreter
 
-ARTICLE: "meta-interp-state" "Interpreter state"
-"The current interpreter state is stored in a number of variables:"
-{ $subsection meta-interp }
-{ $subsection callframe }
-{ $subsection callframe-scan }
-"A set of utility words for inspecting and modifying interpreter state is provided:"
-{ $subsection meta-d }
-{ $subsection push-d }
-{ $subsection pop-d }
-{ $subsection peek-d }
-{ $subsection meta-r }
-{ $subsection push-r }
-{ $subsection pop-r }
-{ $subsection peek-r }
-{ $subsection meta-c }
-{ $subsection push-c }
-{ $subsection pop-c }
-{ $subsection peek-c }
-"Calling a quotation in the meta-circular interpreter:"
-{ $subsection meta-call } ;
-
 ARTICLE: "meta-interp-step" "Single-stepping words"
 "Breakpoints can be inserted in user code:"
 { $subsection break }
@@ -30,150 +9,48 @@ ARTICLE: "meta-interp-step" "Single-stepping words"
 { $subsection break-hook }
 "Single stepping with the meta-circular interpreter:"
 { $subsection step }
-{ $subsection step-in }
+{ $subsection step-into }
 { $subsection step-out }
-{ $subsection step-all }
+{ $subsection step-all } ;
-{ $subsection abandon } ;
 
 ARTICLE: "meta-interp-travel" "Backwards time travel"
 "Backwards time travel is implemented by capturing the continuation after every step. Since this consumes additional memory, it must be explicitly enabled by storing an empty vector into a variable:"
-{ $subsection meta-history }
+{ $subsection history }
 "If this variable holds a vector, the interpreter state is automatically saved after every step. It can be saved at other points manually:"
-{ $subsection save-interp }
+{ $subsection save-interpreter }
 "You can also restore any prior state:"
-{ $subsection restore-interp }
+{ $subsection restore-interpreter }
 "Or restore the most recently saved state:"
 { $subsection step-back } ;
 
-ARTICLE: "meta-interp-impl" "Interpreter implementation"
-"Custom single stepping behavior can be implemented by calling the common factor shared by " { $link step } " and " { $link step-in } ":"
-{ $subsection next }
-"The meta-circular interpreter executes most words much like the Factor interpreter; primitives are executed atomically and compound words are descended into. These semantics can be customized by setting the " { $snippet "\"meta-word\"" } " word property to a quotation. This quotation is run in the host interpreter and can make use of the words in " { $link "meta-interp-state" } "."
-$nl
-"Additionally, the " { $snippet "\"no-meta-word\"" } " word property can be set to " { $link t } " to instruct the meta-circular interpreter to always execute the word atomically, even if " { $link step-in } " is called." ;
-
 ARTICLE: "meta-interpreter" "Meta-circular interpreter"
 "The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "."
 $nl
 "On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section."
 $nl
 "Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary."
-{ $subsection "meta-interp-state" }
+$nl
+"The current interpreter state is stored in the " { $link interpreter } " variable."
 { $subsection "meta-interp-step" }
-{ $subsection "meta-interp-travel" }
+{ $subsection "meta-interp-travel" } ;
-{ $subsection "meta-interp-impl" } ;
 
 ABOUT: "meta-interpreter"
 
-HELP: meta-interp
+HELP: interpreter
 { $var-description "Variable holding a " { $link continuation } " instance for the single-stepper." } ;
 
-HELP: meta-d
-{ $values { "seq" "a sequence" } }
-{ $description "Pushes the data stack from the single stepper." } ;
-
-HELP: push-d
-{ $values { "obj" object } }
-{ $description "Pushes an object on the single stepper's data stack." } ;
-
-HELP: pop-d
-{ $values { "obj" object } }
-{ $description "Pops an object from the single stepper's data stack." }
-{ $errors "Throws an error if the single stepper's data stack is empty." } ;
-
-HELP: peek-d
-{ $values { "obj" object } }
-{ $description "Outputs the object at the top of the single stepper's data stack." }
-{ $errors "Throws an error if the single stepper's data stack is empty." } ;
-
-HELP: meta-r
-{ $values { "seq" "a sequence" } }
-{ $description "Pushes the retain stack from the single stepper." } ;
-
-HELP: push-r
-{ $values { "obj" object } }
-{ $description "Pushes an object on the single stepper's retain stack." } ;
-
-HELP: pop-r
-{ $values { "obj" object } }
-{ $description "Pops an object from the single stepper's retain stack." }
-{ $errors "Throws an error if the single stepper's retain stack is empty." } ;
-
-HELP: peek-r
-{ $values { "obj" object } }
-{ $description "Outputs the object at the top of the single stepper's retain stack." }
-{ $errors "Throws an error if the single stepper's retain stack is empty." } ;
-
-HELP: meta-c
-{ $values { "seq" "a sequence" } }
-{ $description "Pushes the call stack from the single stepper." } ;
-
-HELP: push-c
-{ $values { "obj" object } }
-{ $description "Pushes an object on the single stepper's call stack." } ;
-
-HELP: pop-c
-{ $values { "obj" object } }
-{ $description "Pops an object from the single stepper's call stack." }
-{ $errors "Throws an error if the single stepper's call stack is empty." } ;
-
-HELP: peek-c
-{ $values { "obj" object } }
-{ $description "Outputs the object at the top of the single stepper's call stack." }
-{ $errors "Throws an error if the single stepper's call stack is empty." } ;
-
-HELP: break-hook
-{ $var-description "A quotation called by the " { $link break } " word. The default value invokes the " { $link "ui-walker" } "." } ;
-
-HELP: callframe
-{ $var-description "The quotation currently being stepped through by the single stepper." } ;
-
-HELP: callframe-scan
-{ $var-description "The index of the next object to be evaluated by the single stepper." } ;
-
 HELP: break
 { $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;
 
-HELP: up
+HELP: history
-{ $description "Returns from the current quotation in the single stepper." } ;
-
-HELP: done-cf?
-{ $values { "?" "a boolean" } }
-{ $description "Outputs whether the current quotation has finished evaluating in the single stepper." } ;
-
-HELP: done?
-{ $values { "?" "a boolean" } }
-{ $description "Outputs whether the current continuation has finished evaluating in the single stepper." }
-;
-
-HELP: reset-interpreter
-{ $description "Resets the single stepper, discarding any prior state." } ;
-
-HELP: save-callframe
-{ $description "Saves the currently evaluating quotation on the single stepper's call stack." } ;
-
-HELP: meta-call
-{ $values { "quot" quotation } }
-{ $description "Begins evaluating a quotation in the single stepper, performing tail call optimization if the prior quotation has finished evaluating." } ;
-
-HELP: step-to
-{ $values { "n" integer } }
-{ $description "Evaluates the single stepper's continuation until the " { $snippet "n" } "th index in the current quotation." } ;
-
-HELP: meta-history
 { $var-description "A sequence of continuations, captured at every stage of single-stepping. Used by " { $link step-back } " to implement backwards time travel." } ;
 
-HELP: save-interp
+HELP: save-interpreter
-{ $description "Snapshots the single stepper state and saves it in " { $link meta-history } "." } ;
+{ $description "Snapshots the single stepper state and saves it in " { $link history } "." } ;
 
-HELP: restore-interp
+HELP: restore-interpreter
-{ $values { "ns" hashtable } }
+{ $values { "ns" continuation } }
-{ $description "Restores the single stepper to a former state, which must have been saved by a call to " { $link save-interp } "." } ;
+{ $description "Restores the single stepper to a former state, which must have been saved by a call to " { $link save-interpreter } "." } ;
-
-HELP: next
-{ $values { "quot" quotation } }
-{ $description "Applies the quotation to the next object evaluated by the single stepper. If the single stepper's current quotation has finished evaluating, this will return to the caller quotation." }
-{ $notes "This word is used to implement " { $link step } " and " { $link step-in } "." } ;
 
 HELP: step
 { $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
@@ -184,7 +61,7 @@ HELP: step
     }
 } ;
 
-HELP: step-in
+HELP: step-into
 { $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
     { $list
         { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" }
@@ -198,10 +75,7 @@ HELP: step-out
 { $description "Evaluates the remainder of the current quotation in the single stepper." } ;
 
 HELP: step-back
-{ $description "Steps back to the most recently saved snapshot of the single stepper continuation in " { $link meta-history } "." } ;
+{ $description "Steps back to the most recently saved snapshot of the single stepper continuation in " { $link history } "." } ;
 
 HELP: step-all
 { $description "Executes the remainder of the single stepper's continuation. This effectively ends single stepping unless the continuation invokes " { $link break } " at a later point in time." } ;
-
-HELP: abandon
-{ $description "Raises an error in the single stepper's continuation then executes the remainder of the continuation starting from the error handler." } ;

extra/tools/interpreter/interpreter-tests.factor

@@ -1,157 +1,161 @@
 USING: tools.interpreter io io.streams.string kernel math
 math.private namespaces prettyprint sequences tools.test
-continuations math.parser ;
+continuations math.parser threads arrays ;
 IN: temporary
 
-[ V{ [ "Hello world" print readln break + ] 1 5 } ]
+[ "Ooops" throw ] break-hook set
-[ 3 [ "Hello world" print readln + ] 1 <breakpoint> ]
-unit-test
 
-: run ( -- ) done? [ step-in run ] unless ;
+: run-interpreter ( -- )
+    interpreter get [ step-into run-interpreter ] when ;
 
-: init-interpreter ( -- )
+: init-interpreter ( quot -- )
-    V{ } clone V{ } clone V{ } clone namestack catchstack
+    [
-    f <continuation> meta-interp set ;
+        "out" set
+        [ f swap 2array restore "out" get continue ] callcc0
+    ] swap [ datastack "datastack" set stop ] 3append callcc0 ;
 
-: test-interpreter
+: test-interpreter ( quot -- )
-    init-interpreter (meta-call) run meta-d ;
+    init-interpreter run-interpreter "datastack" get ;
 
-[ V{ } ] [
+[ { } ] [
     [ ] test-interpreter
 ] unit-test
 
-[ V{ 1 } ] [
+[ { 1 } ] [
     [ 1 ] test-interpreter
 ] unit-test
 
-[ V{ 1 2 3 } ] [
+[ { 1 2 3 } ] [
     [ 1 2 3 ] test-interpreter
 ] unit-test
 
-[ V{ "Yo" 2 } ] [
+[ { "Yo" 2 } ] [
     [ 2 >r "Yo" r> ] test-interpreter
 ] unit-test
 
-[ V{ 2 } ] [
+[ { 2 } ] [
     [ t [ 2 ] [ "hi" ] if ] test-interpreter
 ] unit-test
 
-[ V{ "hi" } ] [
+[ { "hi" } ] [
     [ f [ 2 ] [ "hi" ] if ] test-interpreter
 ] unit-test
 
-[ V{ 4 } ] [
+[ { 4 } ] [
     [ 2 2 fixnum+ ] test-interpreter
 ] unit-test
 
 : foo 2 2 fixnum+ ;
 
-[ V{ 8 } ] [
+[ { 8 } ] [
     [ foo 4 fixnum+ ] test-interpreter
 ] unit-test
 
-[ V{ C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [
+[ { C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [
     [ C{ 1 1.5 } { } 2dup ] test-interpreter
 ] unit-test
 
-[ V{ t } ] [
+[ { t } ] [
     [ 5 5 number= ] test-interpreter
 ] unit-test
 
-[ V{ f } ] [
+[ { f } ] [
     [ 5 6 number= ] test-interpreter
 ] unit-test
 
-[ V{ f } ] [
+[ { f } ] [
     [ "XYZ" "XYZ" mismatch ] test-interpreter
 ] unit-test
 
-[ V{ t } ] [
+[ { t } ] [
     [ "XYZ" "XYZ" sequence= ] test-interpreter
 ] unit-test
 
-[ V{ t } ] [
+[ { t } ] [
     [ "XYZ" "XYZ" = ] test-interpreter
 ] unit-test
 
-[ V{ f } ] [
+[ { f } ] [
     [ "XYZ" "XuZ" = ] test-interpreter
 ] unit-test
 
-[ V{ 4 } ] [
+[ { 4 } ] [
     [ 2 2 + ] test-interpreter
 ] unit-test
 
-[ V{ } 2 ] [
+[ { } 2 ] [
     2 "x" set [ [ 3 "x" set ] with-scope ] test-interpreter "x" get
 ] unit-test
 
-[ V{ 3 } ] [
+[ { 3 } ] [
     [ 3 "x" set "x" get ] test-interpreter
 ] unit-test
 
-[ V{ "hi\n" } ] [
+[ { "hi\n" } ] [
     [ [ "hi" print ] string-out ] test-interpreter
 ] unit-test
 
-[ V{ "4\n" } ] [
+[ { "4\n" } ] [
     [ [ 2 2 + number>string print ] string-out ] test-interpreter
 ] unit-test
 
-[ V{ 6 } ]
+[ { 6 } ]
-[ [ [ 3 throw ] catch 2 * ] test-interpreter ] unit-test
+[ [ 3 [ nip continue ] callcc0 2 * ] test-interpreter ] unit-test
 
-[ V{ 6 } ]
+[ { 6 } ]
 [ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test
 
-: meta-catch meta-interp get continuation-catch ;
+[ { 6 } ]
+[ [ [ 3 throw ] catch 2 * ] test-interpreter ] unit-test
+
+: meta-catch interpreter get continuation-catch ;
 
 ! Step back test
-[
+! [
-    init-interpreter
+!     init-interpreter
-    V{ } clone meta-history set
+!     V{ } clone meta-history set
-
+! 
-    V{ f } clone
+!     V{ f } clone
-    V{ } clone
+!     V{ } clone
-    V{ [ 1 2 3 ] 0 3 } clone
+!     V{ [ 1 2 3 ] 0 3 } clone
-    V{ } clone
+!     V{ } clone
-    V{ } clone
+!     V{ } clone
-    f <continuation>
+!     f <continuation>
-    meta-catch push
+!     meta-catch push
-
+! 
-    [ ] [ [ 2 2 + throw ] (meta-call) ] unit-test
+!     [ ] [ [ 2 2 + throw ] (meta-call) ] unit-test
-
+! 
-    [ ] [ step ] unit-test
+!     [ ] [ step ] unit-test
-
+! 
-    [ ] [ step ] unit-test
+!     [ ] [ step ] unit-test
-    
+!     
-    [ V{ 2 2 } ] [ meta-d ] unit-test
+!     [ { 2 2 } ] [ meta-d ] unit-test
-
+! 
-    [ ] [ step ] unit-test
+!     [ ] [ step ] unit-test
-    
+!     
-    [ V{ 4 } ] [ meta-d ] unit-test
+!     [ { 4 } ] [ meta-d ] unit-test
-    [ 3 ] [ callframe-scan get ] unit-test
+!     [ 3 ] [ callframe-scan get ] unit-test
-    
+!     
-    [ ] [ step-back ] unit-test
+!     [ ] [ step-back ] unit-test
-    [ 2 ] [ callframe-scan get ] unit-test
+!     [ 2 ] [ callframe-scan get ] unit-test
-    
+!     
-    [ V{ 2 2 } ] [ meta-d ] unit-test
+!     [ { 2 2 } ] [ meta-d ] unit-test
-    
+!     
-    [ ] [ step ] unit-test
+!     [ ] [ step ] unit-test
-    
+!     
-    [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
+!     [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
-
+! 
-    [ ] [ step ] unit-test
+!     [ ] [ step ] unit-test
-    
+!     
-    [ [ 1 2 3 ] ] [ callframe get ] unit-test
+!     [ [ 1 2 3 ] ] [ callframe get ] unit-test
-    [ ] [ step-back ] unit-test
+!     [ ] [ step-back ] unit-test
-    
+!     
-    [ V{ 4 } ] [ meta-d ] unit-test
+!     [ { 4 } ] [ meta-d ] unit-test
-    
+!     
-    [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
+!     [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
-
+! 
-    [ ] [ step ] unit-test
+!     [ ] [ step ] unit-test
-    
+!     
-    [ [ 1 2 3 ] ] [ callframe get ] unit-test
+!     [ [ 1 2 3 ] ] [ callframe get ] unit-test
-
+! 
-] with-scope
+! ] with-scope

extra/tools/interpreter/interpreter.factor

@@ -6,185 +6,129 @@ kernel.private math namespaces namespaces.private prettyprint
 quotations sequences splitting strings threads vectors words ;
 IN: tools.interpreter
 
-SYMBOL: meta-interp
+SYMBOL: interpreter
 
-SYMBOL: callframe
-SYMBOL: callframe-scan
-
-! Meta-stacks;
-: meta-d ( -- seq )
-    meta-interp get continuation-data ;
-
-: set-meta-d ( seq -- )
-    meta-interp get set-continuation-data ;
-
-: unclip-last ( seq -- last seq' ) dup peek swap 1 head* ;
-
-: push-d ( obj -- ) meta-d swap add set-meta-d ;
-: pop-d  ( -- obj ) meta-d unclip-last set-meta-d ;
-: peek-d ( -- obj ) meta-d peek ;
-
-: meta-r ( -- seq )
-    meta-interp get continuation-retain ;
-
-: set-meta-r ( seq -- )
-    meta-interp get set-continuation-retain ;
-
-: push-r ( obj -- ) meta-r swap add set-meta-r ;
-: pop-r  ( -- obj ) meta-r unclip-last set-meta-r ;
-: peek-r ( -- obj ) meta-r peek ;
-
-: meta-c ( -- seq )
-    meta-interp get continuation-call callstack>array ;
-
-: set-meta-c ( seq -- )
-    array>callstack meta-interp get set-continuation-call ;
-
-: push-c ( obj -- ) meta-c swap append set-meta-c ;
-: pop-c  ( -- obj ) meta-c 2 swap cut* swap set-meta-c ;
-: peek-c ( -- obj ) meta-c 2 tail* ;
-
-! Hook
 SYMBOL: break-hook
 
-: (meta-call) ( quot -- )
-    callframe set 0 callframe-scan set ;
-
-! Callframe.
-
 : break ( -- )
-    continuation walker-hook
+    continuation callstack
-    [ continue-with ] [ break-hook get call ] if* ;
+    over set-continuation-call
+    walker-hook [ continue-with ] [ break-hook get call ] if* ;
 
-: remove-breaks \ break swap remove ;
+: with-interpreter-datastack ( quot -- )
-
+    interpreter get continuation-data
-: up ( -- )
+    swap with-datastack
-    pop-c first2 cut [ remove-breaks ] 2apply
+    interpreter get set-continuation-data ; inline
-    >r dup length callframe-scan set r> append
-    callframe set ;
-
-: done-cf? ( -- ? ) callframe-scan get callframe get length >= ;
-
-: done? ( -- ? ) done-cf? meta-c empty? and ;
-
-: reset-interpreter ( -- )
-    meta-interp off [ ] (meta-call) ;
-
-: <callframe> ( quot scan -- seq )
-    >r { } like r> 2array ;
-
-: (save-callframe) ( -- )
-    callframe get callframe-scan get <callframe> push-c ;
-
-: save-callframe ( -- )
-    done-cf? [ (save-callframe) ] unless ;
-
-GENERIC: meta-call ( quot -- )
-
-M: quotation meta-call save-callframe (meta-call) ;
-
-M: curry meta-call
-    dup curry-obj push-d curry-quot meta-call ;
-
-: meta-swap ( -- )
-    meta-d 2 cut* reverse append set-meta-d ;
 
 GENERIC: restore ( obj -- )
 
 M: continuation restore
-    clone meta-interp set
+    clone interpreter set ;
-    f push-d
-    meta-c empty? [ [ ] (meta-call) ] [ up ] if ;
 
 M: pair restore
-    first2 restore push-d meta-swap ;
+    first2 clone interpreter set
+    [ nip f ] curry with-interpreter-datastack ;
 
 M: f restore
-    drop reset-interpreter ;
+    drop interpreter off ;
 
-: <breakpoint> ( break quot scan -- callframe )
+: (step-into-call) \ break add* call ;
-    >r cut [ break ] swap 3append r> <callframe> ;
 
-: step-to ( n -- )
+: (step-into-if) ? (step-into-call) ;
-    callframe get callframe-scan get <breakpoint> push-c
-    [ set-walker-hook meta-interp get (continue) ] callcc1
-    restore ;
 
-! The interpreter loses object identity of the name and catch
+: (step-into-dispatch)
-! stacks -- they are copied after each step -- so we execute
+    nth (step-into-call) ;
-! these atomically and don't allow stepping into these words
-{ >n >c c> rethrow continue continue-with continuation
-(continue) (continue-with) }
-[ t "no-meta-word" set-word-prop ] each
 
-\ call [ pop-d meta-call ] "meta-word" set-word-prop
+: (step-into-execute) ( word -- )
-\ execute [ pop-d 1quotation meta-call ] "meta-word" set-word-prop
+    dup "step-into" word-prop [
-\ if [ pop-d pop-d pop-d [ nip ] [ drop ] if meta-call ] "meta-word" set-word-prop
+        call
-\ dispatch [ pop-d pop-d swap nth meta-call ] "meta-word" set-word-prop
-\ (callcc1) [ ] "meta-word" set-word-prop
-
-! Time travel
-SYMBOL: meta-history
-
-: save-interp ( -- )
-    meta-history get [
-        [
-            callframe [ ] change
-            callframe-scan [ ] change
-            meta-interp [ clone ] change
-        ] H{ } make-assoc swap push
-    ] when* ;
-
-: restore-interp ( ns -- )
-    callframe over at callframe set
-    callframe-scan over at callframe-scan set
-    meta-interp swap at clone meta-interp set ;
-
-: advance ( -- ) callframe-scan inc ;
-
-: (next) callframe-scan get callframe get nth ;
-
-: next ( quot -- )
-    save-interp {
-        { [ done? ] [ drop [ ] (meta-call) ] }
-        { [ done-cf? ] [ drop up ] }
-        { [ >r (next) r> call ] [ ] }
-        { [ t ] [ callframe-scan get 1+ step-to ] }
-    } cond ; inline
-
-GENERIC: (step) ( obj -- ? )
-
-M: wrapper (step) advance wrapped push-d t ;
-
-M: object (step) advance push-d t ;
-
-M: word (step) drop f ;
-
-: step ( -- ) [ (step) ] next ;
-
-: (step-in) ( word -- ? )
-    dup "meta-word" word-prop [
-        advance call t
     ] [
-        dup "no-meta-word" word-prop not over compound? and [
+        dup compound? [
-            advance word-def meta-call t
+            word-def (step-into-call)
         ] [
-            drop f
+            execute break
         ] if
     ] ?if ;
 
-: step-in ( -- )
+{
-    [ dup word? [ (step-in) ] [ (step) ] if ] next ;
+    { call [ (step-into-call) ] }
+    { (throw) [ (step-into-call) ] }
+    { execute [ (step-into-execute) ] }
+    { if [ (step-into-if) ] }
+    { dispatch [ (step-into-dispatch) ] }
+} [ "step-into" set-word-prop ] assoc-each
 
-: step-out ( -- )
+{
-    save-interp callframe get length step-to ;
+    >n ndrop >c c>
+    continuation continue continue-with
+    (continue-with) stop break
+} [
+    dup [ execute break ] curry
+    "step-into" set-word-prop
+] each
+
+! Time travel
+SYMBOL: history
+
+: save-interpreter ( -- )
+    history get [ interpreter get clone swap push ] when* ;
+
+: restore-interpreter ( interp -- )
+    clone interpreter set ;
 
 : step-back ( -- )
-    meta-history get dup empty?
+    history get dup empty?
-    [ drop ] [ pop restore-interp ] if ;
+    [ drop ] [ pop restore-interpreter ] if ;
 
+: (continue) ( continuation -- )
+    >continuation<
+    set-catchstack
+    set-namestack
+    set-retainstack
+    >r set-datastack r>
+    set-callstack ;
+
+! Stepping
 : step-all ( -- )
-    save-callframe meta-interp get schedule-thread ;
+    [ interpreter get (continue) ] in-thread ;
 
-: abandon ( -- )
+: change-innermost-frame ( quot -- )
-    [ "Single-stepping abandoned" throw ] meta-call step-all ;
+    interpreter get continuation-call clone
+    [
+        dup innermost-frame-scan 1+
+        swap innermost-frame-quot
+        rot call
+    ] keep
+    [ set-innermost-frame-quot ] keep
+    interpreter get set-continuation-call ; inline
+
+: (step) ( quot -- )
+    save-interpreter
+    change-innermost-frame
+    [ set-walker-hook interpreter get (continue) ] callcc1
+    restore ;
+
+: step ( n -- )
+    [
+        2dup nth \ break = [
+            nip
+        ] [
+            >r 1+ r> cut [ break ] swap 3append
+        ] if
+    ] (step) ;
+
+: step-out ( -- )
+    [ nip \ break add ] (step) ;
+
+GENERIC: (step-into) ( obj -- )
+
+M: word (step-into) (step-into-execute) ;
+M: wrapper (step-into) wrapped break ;
+M: object (step-into) break ;
+
+: step-into ( -- )
+    [
+        cut [
+            swap % unclip literalize , \ (step-into) , %
+        ] [ ] make
+    ] (step) ;

extra/ui/tools/walker/walker.factor

@@ -8,56 +8,39 @@ ui.gestures ui.gadgets.buttons ui.gadgets.panes
 prettyprint.config prettyprint.backend ;
 IN: ui.tools.walker
 
-: quotation. ( callframe -- )
+TUPLE: walker-gadget model ns ;
-    [
-        dup second hilite-index set
-        dup first hilite-quotation set
-        2 nesting-limit set
-        first pprint-elements
-    ] with-pprint ;
-
-: <quotation-display> ( model -- gadget )
-    [ quotation. ] <pane-control>
-    "Current quotation" <labelled-scroller> ;
-
-TUPLE: walker-gadget model quot ns ;
 
 : update-stacks ( walker -- )
-    meta-interp get
+    interpreter get swap walker-gadget-model set-model ;
-    over walker-gadget-model set-model
-    callframe get callframe-scan get 2array
-    swap walker-gadget-quot set-model ;
 
 : with-walker ( gadget quot -- )
-    swap dup walker-gadget-ns
+    swap dup walker-gadget-ns [ slip update-stacks ] bind ;
-    [ slip update-stacks ] bind ; inline
+    inline
 
 : walker-active? ( walker -- ? )
-    meta-interp swap walker-gadget-ns key? ;
+    interpreter swap walker-gadget-ns key? ;
 
 : walker-command ( gadget quot -- )
     over walker-active? [ with-walker ] [ 2drop ] if ; inline
 
 : com-step [ step ] walker-command ;
-: com-into [ step-in ] walker-command ;
+: com-into [ step-into ] walker-command ;
 : com-out [ step-out ] walker-command ;
 : com-back [ step-back ] walker-command ;
 
 : init-walker-models ( walker -- )
-    f <model> over set-walker-gadget-quot
     f <model> over set-walker-gadget-model
     H{ } clone swap set-walker-gadget-ns ;
 
 : reset-walker ( walker -- )
     dup walker-gadget-ns clear-assoc
-    [ V{ } clone meta-history set ] with-walker ;
+    [ V{ } clone history set ] with-walker ;
 
 : <walker-gadget> ( -- gadget )
     walker-gadget construct-empty
     dup init-walker-models [
         toolbar,
-        g walker-gadget-quot <quotation-display> 1/4 track,
+        g walker-gadget-model <traceback-gadget> 1 track,
-        g walker-gadget-model <traceback-gadget> 3/4 track,
     ] { 0 1 } build-track
     dup reset-walker ;
 
@@ -66,7 +49,7 @@ M: walker-gadget call-tool* ( continuation walker -- )
 
 : com-inspect ( walker -- )
     dup walker-active? [
-        meta-interp swap walker-gadget-ns at
+        interpreter swap walker-gadget-ns at
         [ inspect ] curry call-listener
     ] [
         drop
@@ -75,9 +58,6 @@ M: walker-gadget call-tool* ( continuation walker -- )
 : com-continue ( walker -- )
     dup [ step-all ] walker-command reset-walker ;
 
-: com-abandon ( walker -- )
-    dup [ abandon ] walker-command reset-walker ;
-
 : walker-help "ui-walker" help-window ;
 
 \ walker-help H{ { +nullary+ t } } define-command
@@ -92,7 +72,6 @@ walker-gadget "toolbar" f {
 } define-command-map
 
 walker-gadget "other" f {
-    { T{ key-down f { A+ } "a" } com-abandon }
     { T{ key-down f { A+ } "n" } com-inspect }
 } define-command-map
 

vm/callstack.c

@@ -140,20 +140,21 @@ CELL frame_executing(F_STACK_FRAME *frame)
 	return get(literal_start);
 }
 
+CELL frame_scan(F_STACK_FRAME *frame)
+{
+	if(frame_type(frame) == QUOTATION_TYPE)
+		return tag_fixnum(UNAREF(UNTAG(frame->array),frame->scan));
+	else
+		return F;
+}
+
 void stack_frame_to_array(F_STACK_FRAME *frame)
 {
-	CELL offset;
-
-	if(frame_type(frame) == QUOTATION_TYPE)
-		offset = tag_fixnum(UNAREF(UNTAG(frame->array),frame->scan));
-	else
-		offset = F;
-
 #ifdef CALLSTACK_UP_P
 	set_array_nth(array,frame_index++,frame_executing(frame));
-	set_array_nth(array,frame_index++,offset);
+	set_array_nth(array,frame_index++,frame_scan(frame));
 #else
-	set_array_nth(array,frame_index--,offset);
+	set_array_nth(array,frame_index--,frame_scan(frame));
 	set_array_nth(array,frame_index--,frame_executing(frame));
 #endif
 }
@@ -181,3 +182,58 @@ DEFINE_PRIMITIVE(callstack_to_array)
 
 	dpush(tag_object(array));
 }
+
+/* Some primitives implementing a limited form of callstack mutation.
+Used by the single stepper. */
+DEFINE_PRIMITIVE(innermost_stack_frame_quot)
+{
+	F_STACK_FRAME *inner = FIRST_STACK_FRAME(
+		untag_callstack(dpop()));
+	type_check(QUOTATION_TYPE,frame_executing(inner));
+
+	dpush(frame_executing(inner));
+}
+
+DEFINE_PRIMITIVE(innermost_stack_frame_scan)
+{
+	F_STACK_FRAME *inner = FIRST_STACK_FRAME(
+		untag_callstack(dpop()));
+	type_check(QUOTATION_TYPE,frame_executing(inner));
+
+	dpush(frame_scan(inner));
+}
+
+DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
+{
+	CELL callstack = dpop();
+
+	REGISTER_ROOT(callstack);
+	F_QUOTATION *quot = untag_quotation(dpop());
+	REGISTER_UNTAGGED(quot);
+
+	if(quot->compiled == F)
+		jit_compile(quot);
+
+	UNREGISTER_UNTAGGED(quot);
+	UNREGISTER_ROOT(callstack);
+
+	F_STACK_FRAME *inner = FIRST_STACK_FRAME(
+		untag_callstack(callstack));
+	type_check(QUOTATION_TYPE,frame_executing(inner));
+
+
+	CELL scan = inner->scan - inner->array;
+	CELL offset = inner->return_address - inner->xt;
+
+	inner->array = quot->array;
+	inner->scan = quot->array + scan;
+
+	inner->xt = quot->xt;
+
+#ifdef CALLSTACK_UP_P
+	F_STACK_FRAME *next = REBASE_FRAME_SUCCESSOR(frame,delta);
+	*(XT *)(next + 1) = quot->xt + offset;
+#else
+	inner->return_address = quot->xt + offset;
+#endif
+}

vm/callstack.h

@@ -16,3 +16,6 @@ DECLARE_PRIMITIVE(set_datastack);
 DECLARE_PRIMITIVE(set_retainstack);
 DECLARE_PRIMITIVE(set_callstack);
 DECLARE_PRIMITIVE(callstack_to_array);
+DECLARE_PRIMITIVE(innermost_stack_frame_quot);
+DECLARE_PRIMITIVE(innermost_stack_frame_scan);
+DECLARE_PRIMITIVE(set_innermost_stack_frame_quot);

vm/cpu-ppc.S

@@ -173,7 +173,7 @@ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
 DEF(void,lazy_jit_compile,(CELL quot)):
 	mr r4,r1           /* save stack pointer */
 	PROLOGUE
-	bl MANGLE(jit_compile)
+	bl MANGLE(primitive_jit_compile)
 	EPILOGUE
         JUMP_QUOT          /* call the quotation */
 

vm/cpu-x86.S

@@ -57,7 +57,7 @@ DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
 	push XT_REG                  /* Alignment */
 	push XT_REG
 	push XT_REG
-	call MANGLE(jit_compile)
+	call MANGLE(primitive_jit_compile)
 	mov RETURN_REG,ARG0          /* No-op on 32-bit */
 	pop XT_REG                   /* OK to clobber XT_REG here */
 	pop XT_REG

vm/data_gc.h

@@ -1,12 +1,6 @@
 /* Set by the -S command line argument */
 bool secure_gc;
 
-typedef struct {
-	CELL start;
-	CELL size;
-	CELL end;
-} F_SEGMENT;
-
 /* set up guard pages to check for under/overflow.
 size must be a multiple of the page size */
 F_SEGMENT *alloc_segment(CELL size);

vm/primitives.c

@@ -190,4 +190,7 @@ void *primitives[] = {
 	primitive_tuple_boa,
 	primitive_class_hash,
 	primitive_callstack_to_array,
+	primitive_innermost_stack_frame_quot,
+	primitive_innermost_stack_frame_scan,
+	primitive_set_innermost_stack_frame_quot,
 };

vm/quotations.c

@@ -1,5 +1,8 @@
 #include "master.h"
 
+/* Simple JIT compiler. This is one of the two compilers implementing Factor;
+the second one is written in Factor and performs a lot of optimizations.
+See core/compiler/compiler.factor */
 bool jit_fast_if_p(F_ARRAY *array, CELL i)
 {
 	return (i + 3) <= array_capacity(array)
@@ -34,13 +37,8 @@ bool jit_stack_frame_p(F_ARRAY *array)
 	return false;
 }
 
-F_FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack)
+void jit_compile(F_QUOTATION *quot)
 {
-	stack_chain->callstack_top = stack;
-
-	REGISTER_ROOT(tagged);
-
-	F_QUOTATION *quot = untag_quotation(tagged);
 	F_ARRAY *array = untag_object(quot->array);
 
 	REGISTER_UNTAGGED(quot);
@@ -156,7 +154,13 @@ F_FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack)
 	UNREGISTER_UNTAGGED(quot);
 	quot->xt = xt;
 	quot->compiled = T;
+}
 
+F_FASTCALL CELL primitive_jit_compile(CELL tagged, F_STACK_FRAME *stack)
+{
+	stack_chain->callstack_top = stack;
+	REGISTER_ROOT(tagged);
+	jit_compile(untag_quotation(tagged));
 	UNREGISTER_ROOT(tagged);
 	return tagged;
 }

vm/quotations.h

@@ -1,6 +1,7 @@
-DLLEXPORT F_FASTCALL CELL jit_compile(CELL tagged, F_STACK_FRAME *stack);
+void jit_compile(F_QUOTATION *quot);
+F_FASTCALL CELL primitive_jit_compile(CELL tagged, F_STACK_FRAME *stack);
 XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset);
-
+void uncurry(CELL obj);
 DECLARE_PRIMITIVE(curry);
 DECLARE_PRIMITIVE(array_to_quotation);
 DECLARE_PRIMITIVE(quotation_xt);

vm/run.h

@@ -145,6 +145,12 @@ INLINE CELL type_of(CELL tagged)
 DEFPUSHPOP(d,ds)
 DEFPUSHPOP(r,rs)
 
+typedef struct {
+	CELL start;
+	CELL size;
+	CELL end;
+} F_SEGMENT;
+
 /* Assembly code makes assumptions about the layout of this struct:
    - callstack_top field is 0
    - callstack_bottom field is 1