diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index edd1d42dcf..a1e7a84cae 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -267,7 +267,9 @@ H{ } clone update-map set { "" "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 diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 16752d3085..99f69e2050 100644 --- a/core/continuations/continuations-docs.factor +++ b/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 -{ $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 +{ callcc0 continue callcc1 continue-with ifcc } 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." } ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 602efe9d94..5ec6eedae9 100644 --- a/core/continuations/continuations-tests.factor +++ b/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 diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 063b9e7419..82e86032ff 100644 --- a/core/continuations/continuations.factor +++ b/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-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 #! #! 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 -- ) - [ (callcc1) ] swap compose ifcc0 ; inline +: callcc0 ( quot -- ) [ drop ] ifcc ; inline -: callcc0 ( quot -- ) [ ] ifcc0 ; inline - -: callcc1 ( quot -- obj ) [ ] ifcc1 ; inline +: callcc1 ( quot -- obj ) [ ] ifcc ; inline : set-walker-hook ( quot -- ) 3 setenv ; inline @@ -76,29 +72,25 @@ C: continuation 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 ) (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 ) [ diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 79873b8fbd..214aafd75c 100644 --- a/core/generator/registers/registers.factor +++ b/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. [ diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 10c81e7a36..51c0c5f830 100644 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -568,9 +568,12 @@ t over set-effect-terminated? \ callstack>array { callstack } { array } "inferred-effect" set-word-prop \ callstack>array make-flushable -\ array>callstack { array } { callstack } "inferred-effect" set-word-prop -\ array>callstack make-flushable - \ (sleep) { integer } { } "inferred-effect" set-word-prop \ become { array array } { } "inferred-effect" set-word-prop + +\ innermost-frame-quot { callstack } { quotation } "inferred-effect" set-word-prop + +\ innermost-frame-scan { callstack } { fixnum } "inferred-effect" set-word-prop + +\ set-innermost-frame-quot { quotation callstack } { } "inferred-effect" set-word-prop diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index ce04af7756..a160feed24 100644 --- a/core/kernel/kernel-tests.factor +++ b/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 diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index a2444ec41d..ba054140c7 100644 --- a/core/kernel/kernel.factor +++ b/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 -- ... ) diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index d048f041b2..0c6bbe1ec4 100644 --- a/core/syntax/syntax.factor +++ b/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 ] parse-literal ] define-syntax -"CS{" [ \ } [ >array array>callstack ] parse-literal ] define-syntax "POSTPONE:" [ scan-word parsed ] define-syntax "\\" [ scan-word literalize parsed ] define-syntax diff --git a/extra/tools/interpreter/interpreter-docs.factor b/extra/tools/interpreter/interpreter-docs.factor index f102b2dcc8..c3b47e46a9 100644 --- a/extra/tools/interpreter/interpreter-docs.factor +++ b/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 abandon } ; +{ $subsection step-all } ; 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-impl" } ; +{ $subsection "meta-interp-travel" } ; 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 -{ $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 +HELP: 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 -{ $description "Snapshots the single stepper state and saves it in " { $link meta-history } "." } ; +HELP: save-interpreter +{ $description "Snapshots the single stepper state and saves it in " { $link history } "." } ; -HELP: restore-interp -{ $values { "ns" hashtable } } -{ $description "Restores the single stepper to a former state, which must have been saved by a call to " { $link save-interp } "." } ; - -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: restore-interpreter +{ $values { "ns" continuation } } +{ $description "Restores the single stepper to a former state, which must have been saved by a call to " { $link save-interpreter } "." } ; 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." } ; diff --git a/extra/tools/interpreter/interpreter-tests.factor b/extra/tools/interpreter/interpreter-tests.factor index 5e83157bb3..d973f050ad 100644 --- a/extra/tools/interpreter/interpreter-tests.factor +++ b/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 } ] -[ 3 [ "Hello world" print readln + ] 1 ] -unit-test +[ "Ooops" throw ] break-hook set -: run ( -- ) done? [ step-in run ] unless ; +: run-interpreter ( -- ) + interpreter get [ step-into run-interpreter ] when ; -: init-interpreter ( -- ) - V{ } clone V{ } clone V{ } clone namestack catchstack - f meta-interp set ; +: init-interpreter ( quot -- ) + [ + "out" set + [ f swap 2array restore "out" get continue ] callcc0 + ] swap [ datastack "datastack" set stop ] 3append callcc0 ; -: test-interpreter - init-interpreter (meta-call) run meta-d ; +: test-interpreter ( quot -- ) + 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 } ] -[ [ [ 3 throw ] catch 2 * ] test-interpreter ] unit-test +[ { 6 } ] +[ [ 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 - V{ } clone meta-history set - - V{ f } clone - V{ } clone - V{ [ 1 2 3 ] 0 3 } clone - V{ } clone - V{ } clone - f - meta-catch push - - [ ] [ [ 2 2 + throw ] (meta-call) ] unit-test - - [ ] [ step ] unit-test - - [ ] [ step ] unit-test - - [ V{ 2 2 } ] [ meta-d ] unit-test - - [ ] [ step ] unit-test - - [ V{ 4 } ] [ meta-d ] unit-test - [ 3 ] [ callframe-scan get ] unit-test - - [ ] [ step-back ] unit-test - [ 2 ] [ callframe-scan get ] unit-test - - [ V{ 2 2 } ] [ meta-d ] unit-test - - [ ] [ step ] unit-test - - [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test - - [ ] [ step ] unit-test - - [ [ 1 2 3 ] ] [ callframe get ] unit-test - [ ] [ step-back ] unit-test - - [ V{ 4 } ] [ meta-d ] unit-test - - [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test - - [ ] [ step ] unit-test - - [ [ 1 2 3 ] ] [ callframe get ] unit-test - -] with-scope +! [ +! init-interpreter +! V{ } clone meta-history set +! +! V{ f } clone +! V{ } clone +! V{ [ 1 2 3 ] 0 3 } clone +! V{ } clone +! V{ } clone +! f +! meta-catch push +! +! [ ] [ [ 2 2 + throw ] (meta-call) ] unit-test +! +! [ ] [ step ] unit-test +! +! [ ] [ step ] unit-test +! +! [ { 2 2 } ] [ meta-d ] unit-test +! +! [ ] [ step ] unit-test +! +! [ { 4 } ] [ meta-d ] unit-test +! [ 3 ] [ callframe-scan get ] unit-test +! +! [ ] [ step-back ] unit-test +! [ 2 ] [ callframe-scan get ] unit-test +! +! [ { 2 2 } ] [ meta-d ] unit-test +! +! [ ] [ step ] unit-test +! +! [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test +! +! [ ] [ step ] unit-test +! +! [ [ 1 2 3 ] ] [ callframe get ] unit-test +! [ ] [ step-back ] unit-test +! +! [ { 4 } ] [ meta-d ] unit-test +! +! [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test +! +! [ ] [ step ] unit-test +! +! [ [ 1 2 3 ] ] [ callframe get ] unit-test +! +! ] with-scope diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor index 4ac4958936..88e6a0b348 100644 --- a/extra/tools/interpreter/interpreter.factor +++ b/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 - [ continue-with ] [ break-hook get call ] if* ; + continuation callstack + over set-continuation-call + walker-hook [ continue-with ] [ break-hook get call ] if* ; -: remove-breaks \ break swap remove ; - -: up ( -- ) - pop-c first2 cut [ remove-breaks ] 2apply - >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) ; - -: ( quot scan -- seq ) - >r { } like r> 2array ; - -: (save-callframe) ( -- ) - callframe get callframe-scan get 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 ; +: with-interpreter-datastack ( quot -- ) + interpreter get continuation-data + swap with-datastack + interpreter get set-continuation-data ; inline GENERIC: restore ( obj -- ) M: continuation restore - clone meta-interp set - f push-d - meta-c empty? [ [ ] (meta-call) ] [ up ] if ; + clone interpreter set ; 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 ; -: ( break quot scan -- callframe ) - >r cut [ break ] swap 3append r> ; +: (step-into-call) \ break add* call ; -: step-to ( n -- ) - callframe get callframe-scan get push-c - [ set-walker-hook meta-interp get (continue) ] callcc1 - restore ; +: (step-into-if) ? (step-into-call) ; -! The interpreter loses object identity of the name and catch -! stacks -- they are copied after each step -- so we execute -! 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 +: (step-into-dispatch) + nth (step-into-call) ; -\ call [ pop-d meta-call ] "meta-word" set-word-prop -\ execute [ pop-d 1quotation meta-call ] "meta-word" set-word-prop -\ if [ pop-d pop-d pop-d [ nip ] [ drop ] if meta-call ] "meta-word" set-word-prop -\ 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 +: (step-into-execute) ( word -- ) + dup "step-into" word-prop [ + call ] [ - dup "no-meta-word" word-prop not over compound? and [ - advance word-def meta-call t + dup compound? [ + 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? - [ drop ] [ pop restore-interp ] if ; + history get dup empty? + [ 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 ( -- ) - [ "Single-stepping abandoned" throw ] meta-call step-all ; +: change-innermost-frame ( quot -- ) + 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) ; diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index efd54f0064..453ab08976 100644 --- a/extra/ui/tools/walker/walker.factor +++ b/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 -- ) - [ - dup second hilite-index set - dup first hilite-quotation set - 2 nesting-limit set - first pprint-elements - ] with-pprint ; - -: ( model -- gadget ) - [ quotation. ] - "Current quotation" ; - -TUPLE: walker-gadget model quot ns ; +TUPLE: walker-gadget model ns ; : update-stacks ( walker -- ) - meta-interp get - over walker-gadget-model set-model - callframe get callframe-scan get 2array - swap walker-gadget-quot set-model ; + interpreter get swap walker-gadget-model set-model ; : with-walker ( gadget quot -- ) - swap dup walker-gadget-ns - [ slip update-stacks ] bind ; inline + swap dup walker-gadget-ns [ slip update-stacks ] bind ; + 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 over set-walker-gadget-quot f 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 ; : ( -- gadget ) walker-gadget construct-empty dup init-walker-models [ toolbar, - g walker-gadget-quot 1/4 track, - g walker-gadget-model 3/4 track, + g walker-gadget-model 1 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 diff --git a/vm/callstack.c b/vm/callstack.c index 2c3328195f..4644a4e86a 100644 --- a/vm/callstack.c +++ b/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 +} diff --git a/vm/callstack.h b/vm/callstack.h index b7ddf36426..575c614342 100644 --- a/vm/callstack.h +++ b/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); diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 295fffa1a5..99be40a74e 100644 --- a/vm/cpu-ppc.S +++ b/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 */ diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 4331800cf9..7c9ab4e2cc 100644 --- a/vm/cpu-x86.S +++ b/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 diff --git a/vm/data_gc.h b/vm/data_gc.h index 69b8ff2aa7..cb0b6fbad3 100644 --- a/vm/data_gc.h +++ b/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); diff --git a/vm/primitives.c b/vm/primitives.c index bc28012680..6e7b67ba61 100644 --- a/vm/primitives.c +++ b/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, }; diff --git a/vm/quotations.c b/vm/quotations.c index 3390754fc8..ba9325f0dc 100644 --- a/vm/quotations.c +++ b/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; } diff --git a/vm/quotations.h b/vm/quotations.h index ff9edc8093..5757e10c97 100644 --- a/vm/quotations.h +++ b/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); diff --git a/vm/run.h b/vm/run.h index fe3dcce866..c959a7e007 100644 --- a/vm/run.h +++ b/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