Re-implemented single stepper for new evaluation model
Slava Pestov
parent
e9868aecc7
commit
fab1453bfc
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
[ (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
|
|||
|
||||
<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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -106,6 +106,8 @@ GENERIC: clone ( obj -- cloned )
|
|||
|
||||
M: object clone ;
|
||||
|
||||
M: callstack clone (clone) ;
|
||||
|
||||
! Tuple construction
|
||||
|
||||
GENERIC# get-slots 1 ( tuple slots -- ... )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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 <breakpoint> ]
|
||||
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 <continuation> 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 <continuation>
|
||||
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 <continuation>
|
||||
! 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
|
||||
|
|
|
|||
|
|
@ -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) ;
|
||||
|
||||
: <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 ;
|
||||
: 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 ;
|
||||
|
||||
: <breakpoint> ( break quot scan -- callframe )
|
||||
>r cut [ break ] swap 3append r> <callframe> ;
|
||||
: (step-into-call) \ break add* call ;
|
||||
|
||||
: step-to ( n -- )
|
||||
callframe get callframe-scan get <breakpoint> 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) ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <quotation-display> ( model -- gadget )
|
||||
[ quotation. ] <pane-control>
|
||||
"Current quotation" <labelled-scroller> ;
|
||||
|
||||
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 <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> 3/4 track,
|
||||
g walker-gadget-model <traceback-gadget> 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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
};
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
Loading…
Reference in New Issue