diff --git a/.gitignore b/.gitignore index a3f5d94252..6a748023af 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,7 @@ Factor/factor *.image *.dylib factor +*#*# +.DS_Store +.gdb_history +*.*.marks diff --git a/Makefile b/Makefile index c5db03896e..11563a0698 100644 --- a/Makefile +++ b/Makefile @@ -23,7 +23,7 @@ ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/alien.o \ vm/bignum.o \ - vm/compiler.o \ + vm/code_heap.o \ vm/debug.o \ vm/factor.o \ vm/ffi_test.o \ @@ -34,10 +34,11 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/code_gc.o \ vm/primitives.o \ vm/run.o \ - vm/stack.o \ + vm/callstack.o \ vm/types.o \ - vm/jit.o \ - vm/utilities.o + vm/quotations.o \ + vm/utilities.o \ + vm/errors.o EXE_OBJS = $(PLAF_EXE_OBJS) @@ -130,9 +131,6 @@ factor: $(DLL_OBJS) $(EXE_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) -pull: - darcs pull http://factorcode.org/repos/ - clean: rm -f vm/*.o diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 0adc5f08ef..ca475bf80a 100644 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -56,3 +56,11 @@ cell 8 = [ ] when [ "ALIEN: 1234" ] [ 1234 unparse ] unit-test + +[ ] [ 0 B{ 1 2 3 } drop ] unit-test +[ ] [ 0 F{ 1 2 3 } drop ] unit-test +[ ] [ 0 ?{ t f t } drop ] unit-test + +[ 0 B{ 1 2 3 } alien-address ] unit-test-fails + +[ 1 1 ] unit-test-fails diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 5af9e9ff98..564efd72df 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -4,12 +4,22 @@ IN: alien USING: assocs kernel math namespaces sequences system byte-arrays bit-arrays float-arrays kernel.private tuples ; +! Some predicate classes used by the compiler for optimization +! purposes PREDICATE: alien simple-alien underlying-alien not ; UNION: simple-c-ptr simple-alien byte-array bit-array float-array POSTPONE: f ; +DEFER: pinned-c-ptr? + +PREDICATE: alien pinned-alien + underlying-alien pinned-c-ptr? ; + +UNION: pinned-c-ptr + alien POSTPONE: f ; + UNION: c-ptr alien bit-array byte-array float-array POSTPONE: f ; diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index b63a110d85..aa46271fed 100644 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -62,6 +62,25 @@ GENERIC: alien-node-abi ( node -- str ) call f set-stack-frame ; inline +GENERIC: reg-size ( register-class -- n ) + +M: int-regs reg-size drop cell ; + +M: float-regs reg-size float-regs-size ; + +GENERIC: inc-reg-class ( register-class -- ) + +: (inc-reg-class) + dup class inc + fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ; + +M: int-regs inc-reg-class + (inc-reg-class) ; + +M: float-regs inc-reg-class + dup (inc-reg-class) + fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ; + : reg-class-full? ( class -- ? ) dup class get swap param-regs length >= ; @@ -206,7 +225,7 @@ M: alien-invoke-error summary pop-literal nip over set-alien-invoke-library pop-literal nip over set-alien-invoke-return ! Quotation which coerces parameters to required types - dup make-prep-quot infer-quot + dup make-prep-quot recursive-state get infer-quot ! If symbol doesn't resolve, no stack effect, no compile dup alien-invoke-dlsym 2drop ! Add node to IR @@ -243,7 +262,7 @@ M: alien-indirect-error summary pop-parameters over set-alien-indirect-parameters pop-literal nip over set-alien-indirect-return ! Quotation which coerces parameters to required types - dup make-prep-quot 1 make-dip infer-quot + dup make-prep-quot [ dip ] curry recursive-state get infer-quot ! Add node to IR dup node, ! Magic #: consume the function pointer, too @@ -282,7 +301,8 @@ M: alien-callback-error summary drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ; : callback-bottom ( node -- ) - alien-callback-xt [ word-xt ] curry infer-quot ; + alien-callback-xt [ word-xt ] curry + recursive-state get infer-quot ; \ alien-callback [ 4 ensure-values diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index c550923907..39e85dcb21 100644 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -3,7 +3,7 @@ parser kernel kernel.private classes classes.private arrays hashtables vectors tuples sbufs inference.dataflow hashtables.private sequences.private math tuples.private growable namespaces.private alien.remote-control assocs -words generator command-line vocabs io prettyprint ; +words generator command-line vocabs io prettyprint libc ; "bootstrap.math" vocab [ "cpu." cpu append require @@ -44,6 +44,8 @@ words generator command-line vocabs io prettyprint ; new nth push pop peek hashcode* = get set . lines + + malloc free memcpy } [ compile ] each [ recompile ] parse-hook set-global 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/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 731b12b0b4..4cea78bc97 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -5,7 +5,6 @@ IN: combinators ARTICLE: "combinators-quot" "Quotation construction utilities" "Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:" -{ $subsection make-dip } { $subsection cond>quot } { $subsection case>quot } { $subsection alist>quot } @@ -27,13 +26,6 @@ ARTICLE: "combinators" "Additional combinators" ABOUT: "combinators" -HELP: make-dip -{ $values { "quot" "a quotation" } { "n" "a non-negative integer" } { "newquot" "a new quotation" } } -{ $description "Constructs a quotation which retains the top " { $snippet "n" } " stack items, and applies " { $snippet "quot" } " to what is underneath." } -{ $examples - { $example "USE: quotations" "[ 3 + ] 2 make-dip ." "[ >r >r 3 + r> r> ]" } -} ; - HELP: alist>quot { $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } } { $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." } diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index edb5de0940..518a8cd119 100644 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -145,6 +145,16 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test +! Make sure XT doesn't get clobbered in stack frame + +: ffi_test_31 + "void" + f "ffi_test_31" + { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } + alien-invoke code-gc 3 ; + +[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test + FUNCTION: longlong ffi_test_21 long x long y ; [ 121932631112635269 ] diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 23e94a7974..d86018475c 100644 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -357,26 +357,31 @@ cell 8 = [ [ 3 ] [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-1 ] unit-test [ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test +[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test [ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test +[ t ] [ "b" get >boolean ] unit-test -[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ "b" get [ { simple-alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test -[ 3 ] [ "b" get 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test +"b" get [ + [ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test + [ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test + [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test + [ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test -[ ] [ "b" get free ] unit-test + [ ] [ "b" get free ] unit-test +] when [ ] [ "hello world" malloc-char-string "s" set ] unit-test -[ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test -[ "hello world" ] [ "s" get [ { simple-c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test +"s" get [ + [ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test + [ "hello world" ] [ "s" get [ { c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test -[ ] [ "s" get free ] unit-test + [ ] [ "s" get free ] unit-test +] when -[ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-alien } declare ] compile-1 *void* ] unit-test -[ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-c-ptr } declare ] compile-1 *void* ] unit-test +[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare ] compile-1 *void* ] unit-test +[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare ] compile-1 *void* ] unit-test [ f ] [ f [ { POSTPONE: f } declare ] compile-1 *void* ] unit-test [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test @@ -411,3 +416,17 @@ cell 8 = [ [ t ] [ pi [ { byte-array } declare *float ] compile-1 pi - abs 0.001 < ] unit-test [ t ] [ pi 8 [ [ { float byte-array } declare 0 set-alien-double ] compile-1 ] keep *double pi = ] unit-test + +[ 4 ] [ + 2 B{ 1 2 3 4 5 6 } [ + { alien } declare 1 alien-unsigned-1 + ] compile-1 +] unit-test + +[ + B{ 0 0 0 0 } [ { byte-array } declare ] compile-1 +] unit-test-fails + +[ + B{ 0 0 0 0 } [ { c-ptr } declare ] compile-1 +] unit-test-fails diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace.factor index ee94f0c9a2..4c47ca8a12 100644 --- a/core/compiler/test/stack-trace.factor +++ b/core/compiler/test/stack-trace.factor @@ -1,25 +1,28 @@ IN: temporary USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private -words ; +words splitting ; : symbolic-stack-trace ( -- newseq ) - error-continuation get continuation-call callstack>array ; + error-continuation get continuation-call callstack>array + 2 group flip first ; : foo 3 throw 7 ; : bar foo 4 ; : baz bar 5 ; \ baz compile [ 3 ] [ [ baz ] catch ] unit-test -[ { baz bar foo throw } ] [ - symbolic-stack-trace [ word? ] subset +[ t ] [ + symbolic-stack-trace + [ word? ] subset + { baz bar foo throw } tail? ] unit-test : bleh [ 3 + ] map [ 0 > ] subset ; \ bleh compile : stack-trace-contains? symbolic-stack-trace memq? ; - + [ t ] [ [ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains? ] unit-test diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor index 5f6ece5d68..ae7cf12502 100644 --- a/core/compiler/test/templates-early.factor +++ b/core/compiler/test/templates-early.factor @@ -1,14 +1,17 @@ ! Testing templates machinery without compiling anything IN: temporary -USING: compiler generator generator.registers tools.test -namespaces sequences words kernel math effects ; +USING: compiler generator generator.registers +generator.registers.private tools.test namespaces sequences +words kernel math effects ; + +: ( n -- vreg ) T{ int-regs } ; [ [ ] [ init-templates ] unit-test [ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test - [ ] [ 0 phantom-d get phantom-push ] unit-test + [ ] [ 0 phantom-push ] unit-test [ ] [ compute-free-vregs ] unit-test @@ -17,7 +20,7 @@ namespaces sequences words kernel math effects ; [ f ] [ [ copy-templates - 1 phantom-d get phantom-push + 1 phantom-push compute-free-vregs 1 T{ int-regs } free-vregs member? ] with-scope @@ -57,8 +60,6 @@ namespaces sequences words kernel math effects ; { +input+ { { f "x" } } } } clone [ [ 1 0 ] [ +input+ get { } { } guess-vregs ] unit-test - [ ] [ 1 0 ensure-vregs ] unit-test - ! [ t ] [ +input+ get phantom-d get compatible? ] unit-test [ ] [ finalize-contents ] unit-test [ ] [ [ template-inputs ] { } make drop ] unit-test ] bind @@ -118,14 +119,71 @@ SYMBOL: template-chosen ! This is not empty since a load instruction is emitted [ f ] [ - [ { { f "x" } } fast-input ] { } make empty? + [ { { f "x" } } +input+ set load-inputs ] { } make + empty? ] unit-test ! This is empty since we already loaded the value [ t ] [ - [ { { f "x" } } fast-input ] { } make empty? + [ { { f "x" } } +input+ set load-inputs ] { } make + empty? ] unit-test ! This is empty since we didn't change the stack [ t ] [ [ end-basic-block ] { } make empty? ] unit-test ] with-scope + +! Regression +[ + [ ] [ init-templates ] unit-test + + ! >r r> + [ ] [ + 1 phantom->r + 1 phantom-r> + ] unit-test + + ! This is empty since we didn't change the stack + [ t ] [ [ end-basic-block ] { } make empty? ] unit-test + + ! >r r> + [ ] [ + 1 phantom->r + 1 phantom-r> + ] unit-test + + [ ] [ { object } set-operand-classes ] unit-test + + ! This is empty since we didn't change the stack + [ t ] [ [ end-basic-block ] { } make empty? ] unit-test +] with-scope + +! Regression +[ + [ ] [ init-templates ] unit-test + + [ ] [ { object object } set-operand-classes ] unit-test + + ! 2dup + [ ] [ + T{ effect f { "x" "y" } { "x" "y" "x" "y" } } + phantom-shuffle + ] unit-test + + [ ] [ + 2 phantom-d get phantom-input + [ { { f "a" } { f "b" } } lazy-load ] { } make drop + ] unit-test + + [ t ] [ + phantom-d get [ cached? ] all? + ] unit-test + + ! >r + [ ] [ + 1 phantom->r + ] unit-test + + ! This should not fail + [ ] [ [ end-basic-block ] { } make drop ] unit-test +] with-scope diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates.factor index 8877126902..aa2690da7b 100644 --- a/core/compiler/test/templates.factor +++ b/core/compiler/test/templates.factor @@ -1,9 +1,9 @@ -! Black box testing of templater optimization +! Black box testing of templating optimization USING: arrays compiler kernel kernel.private math hashtables.private math.private math.ratios.private namespaces sequences sequences.private tools.test namespaces.private -slots.private combinators.private ; +slots.private combinators.private byte-arrays alien layouts ; IN: temporary ! Oops! @@ -185,3 +185,36 @@ TUPLE: my-tuple ; [ 4 ] [ T{ my-tuple } foox ] unit-test [ 5 ] [ "hi" foox ] unit-test + +! Making sure we don't needlessly unbox/rebox +[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-1 ] unit-test + +[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-1 >r eq? r> ] unit-test + +[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-1 nip eq? ] unit-test + +[ 1 B{ 1 2 3 4 } ] [ + B{ 1 2 3 4 } [ + { byte-array } declare + [ 0 alien-unsigned-1 ] keep + ] compile-1 +] unit-test + +[ 1 t ] [ + B{ 1 2 3 4 } [ + { c-ptr } declare + [ 0 alien-unsigned-1 ] keep type + ] compile-1 byte-array type-number = +] unit-test + +[ t ] [ + B{ 1 2 3 4 } [ + { c-ptr } declare + 0 alien-cell type + ] compile-1 alien type-number = +] unit-test + +[ 2 1 ] [ + 2 1 + [ 2dup fixnum< [ >r die r> ] when ] compile-1 +] unit-test diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 16752d3085..eb6afbf51e 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 -- )" } } } @@ -107,28 +102,6 @@ HELP: callcc1 { $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } } { $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ; -HELP: set-walker-hook -{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } ", or " { $link f } } } -{ $description "Sets a quotation to be called when a continuation is resumed." } -{ $notes "The single-stepper uses this hook to support single-stepping through code which makes use of continuations." } ; - -HELP: walker-hook -{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } ", or " { $link f } } } -{ $description "Outputs a quotation to be called when a continuation is resumed, or " { $link f } " if no hook is set. If a hook was set prior to this word being called, it will be reset to " { $link f } "." -$nl -"The following words do not perform their usual action and instead just call the walker hook if one is set:" - { $list - { { $link callcc0 } " will call the hook, passing it the continuation to resume." } - { { $link callcc1 } " will call the hook, passing it a " { $snippet "{ obj continuation }" } " pair." } - { { $link stop } " will call the hook, passing it " { $link f } "." } - } -"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." } ; @@ -223,3 +196,6 @@ $low-level-note ; HELP: init-error-handler { $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ; + +HELP: break +{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ; 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..5d23cd734b 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -20,7 +20,12 @@ SYMBOL: restarts : (catch) ( quot -- newquot ) [ swap >c call c> drop ] curry ; inline -: (callcc1) 4 getenv f 4 setenv ; inline +: dummy ( -- obj ) + #! Optimizing compiler assumes stack won't be messed with + #! in-transit. To ensure that a value is actually reified + #! on the stack, we put it in a non-inline word together + #! with a declaration. + f { object } declare ; PRIVATE> @@ -45,10 +50,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,23 +61,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 dummy 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 - -: set-walker-hook ( quot -- ) 3 setenv ; inline - -: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline +: callcc1 ( quot -- obj ) [ ] ifcc ; inline continuation set-catchstack set-namestack set-retainstack - >r set-datastack f r> + >r set-datastack r> set-callstack ; : (continue-with) ( obj continuation -- ) - swap 4 setenv (continue) ; + swap 4 setenv + >continuation< + set-catchstack + set-namestack + set-retainstack + >r set-datastack drop 4 getenv f r> + set-callstack ; PRIVATE> -: continue ( continuation -- ) - [ - walker-hook [ (continue-with) ] [ (continue) ] if* - ] curry (throw) ; +: set-walker-hook ( quot -- ) 3 setenv ; inline + +: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline : 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 ) [ @@ -174,3 +181,19 @@ M: condition compute-restarts "kernel-error" 6 setenv ; PRIVATE> + +! Debugging support +: with-walker-hook ( continuation -- ) + [ swap set-walker-hook (continue) ] curry callcc1 ; + +SYMBOL: break-hook + +: break ( -- ) + continuation callstack + over set-continuation-call + walker-hook [ (continue-with) ] [ break-hook get call ] if* ; + +GENERIC: (step-into) ( obj -- ) + +M: wrapper (step-into) wrapped break ; +M: object (step-into) break ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index e501d548b3..22efad5c4d 100644 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -79,17 +79,14 @@ HOOK: %inc-d compiler-backend ( n -- ) HOOK: %inc-r compiler-backend ( n -- ) ! Load stack into vreg -GENERIC: (%peek) ( vreg loc reg-class -- ) -: %peek ( vreg loc -- ) over (%peek) ; +HOOK: %peek compiler-backend ( vreg loc -- ) ! Store vreg to stack -GENERIC: (%replace) ( vreg loc reg-class -- ) -: %replace ( vreg loc -- ) over (%replace) ; +HOOK: %replace compiler-backend ( vreg loc -- ) -! Move one vreg to another -HOOK: %move-int>int compiler-backend ( dst src -- ) -HOOK: %move-int>float compiler-backend ( dst src -- ) -HOOK: %move-float>int compiler-backend ( dst src -- ) +! Box and unbox floats +HOOK: %unbox-float compiler-backend ( dst src -- ) +HOOK: %box-float compiler-backend ( dst src -- ) ! FFI stuff @@ -183,24 +180,15 @@ PREDICATE: integer inline-array 32 < ; ] if-small-struct ; ! Alien accessors -HOOK: %unbox-byte-array compiler-backend ( quot src -- ) inline +HOOK: %unbox-byte-array compiler-backend ( dst src -- ) -HOOK: %unbox-alien compiler-backend ( quot src -- ) inline +HOOK: %unbox-alien compiler-backend ( dst src -- ) -HOOK: %unbox-f compiler-backend ( quot src -- ) inline +HOOK: %unbox-f compiler-backend ( dst src -- ) -HOOK: %complex-alien-accessor compiler-backend ( quot src -- ) -inline +HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- ) -: %alien-accessor ( quot src class -- ) - { - { [ dup \ f class< ] [ drop %unbox-f ] } - { [ dup simple-alien class< ] [ drop %unbox-alien ] } - { [ dup byte-array class< ] [ drop %unbox-byte-array ] } - { [ dup bit-array class< ] [ drop %unbox-byte-array ] } - { [ dup float-array class< ] [ drop %unbox-byte-array ] } - { [ t ] [ drop %complex-alien-accessor ] } - } cond ; inline +HOOK: %box-alien compiler-backend ( dst src -- ) : operand ( var -- op ) get v>operand ; inline diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor index a31e4b7836..66b03c6018 100644 --- a/core/cpu/ppc/allot/allot.factor +++ b/core/cpu/ppc/allot/allot.factor @@ -32,12 +32,7 @@ IN: cpu.ppc.allot 12 11 float tag-number ORI f fresh-object ; -M: float-regs (%replace) - drop - swap v>operand %allot-float - 12 swap loc>operand STW ; - -M: ppc-backend %move-float>int ( dst src -- ) +M: ppc-backend %box-float ( dst src -- ) [ v>operand ] 2apply %allot-float 12 MR ; : %allot-bignum ( #digits -- ) @@ -83,22 +78,21 @@ M: ppc-backend %move-float>int ( dst src -- ) "end" resolve-label ] with-scope ; -: %allot-alien ( ptr -- ) - "temp" set - "f" define-label - "end" define-label - 0 "temp" operand 0 CMPI +M: ppc-backend %box-alien ( dst src -- ) + { "end" "f" } [ define-label ] each + 0 over v>operand 0 CMPI "f" get BEQ alien 4 cells %allot - "temp" operand 11 3 cells STW - f v>operand "temp" operand LI + ! Store offset + v>operand 11 3 cells STW + f v>operand 12 LI ! Store expired slot - "temp" operand 11 1 cells STW + 12 11 1 cells STW ! Store underlying-alien slot - "temp" operand 11 2 cells STW + 12 11 2 cells STW ! Store tagged ptr in reg - "temp" get object %store-tagged + dup object %store-tagged "end" get B "f" resolve-label - f v>operand "temp" operand LI + f v>operand swap v>operand LI "end" resolve-label ; diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index d12139c550..6142b1e49f 100644 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -9,17 +9,16 @@ IN: cpu.ppc.architecture TUPLE: ppc-backend ; ! PowerPC register assignments -! r3-r10, r17-r31: integer vregs +! r3-r10, r16-r31: integer vregs ! f0-f13: float vregs ! r11, r12: scratch ! r14: data stack ! r15: retain stack -! For stack frame layout, see vm/os-{macosx,linux}-ppc.h. +! For stack frame layout, see vm/cpu-ppc.h. : ds-reg 14 ; : rs-reg 15 ; -: stack-chain-reg 16 ; : reserved-area-size os { @@ -37,13 +36,17 @@ TUPLE: ppc-backend ; : param-save-size 8 cells ; foldable -: xt-save reserved-area-size param-save-size + 2 cells + ; foldable +: local@ ( n -- x ) + reserved-area-size param-save-size + + ; inline -: local-area-start xt-save cell + ; foldable +: factor-area-size 4 cells ; -: local@ ( n -- x ) local-area-start + ; inline +: next-save ( n -- i ) cell - ; -M: ppc-backend stack-frame ( n -- i ) local@ 4 cells align ; +: xt-save ( n -- i ) 2 cells - ; + +M: ppc-backend stack-frame ( n -- i ) + local@ factor-area-size + 4 cells align ; M: temp-reg v>operand drop 11 ; @@ -85,17 +88,19 @@ M: ppc-backend %save-xt ( -- ) M: ppc-backend %prologue ( n -- ) 0 MFLR - 1 1 pick stack-frame neg STWU - 11 1 xt-save STW - 0 1 rot stack-frame lr-save + STW ; + 1 1 pick neg ADDI + 11 1 pick xt-save STW + dup 11 LI + 11 1 pick next-save STW + 0 1 rot lr-save + STW ; M: ppc-backend %epilogue ( n -- ) #! At the end of each word that calls a subroutine, we store #! the previous link register value in r0 by popping it off #! the stack, set the link register to the contents of r0, #! and jump to the link register. - 0 1 pick stack-frame lr-save + LWZ - 1 1 rot stack-frame ADDI + 0 1 pick lr-save + LWZ + 1 1 rot ADDI 0 MTLR ; : %load-dlsym ( symbol dll register -- ) @@ -156,21 +161,13 @@ M: ppc-backend %return ( -- ) %epilogue-later BLR ; M: ppc-backend %unwind drop %return ; -M: int-regs (%peek) - drop >r v>operand r> loc>operand LWZ ; +M: ppc-backend %peek ( vreg loc -- ) + >r v>operand r> loc>operand LWZ ; -M: float-regs (%peek) - drop - 11 swap loc>operand LWZ - v>operand 11 float-offset LFD ; +M: ppc-backend %replace + >r v>operand r> loc>operand STW ; -M: int-regs (%replace) - drop >r v>operand r> loc>operand STW ; - -M: ppc-backend %move-int>int ( dst src -- ) - [ v>operand ] 2apply MR ; - -M: ppc-backend %move-int>float ( dst src -- ) +M: ppc-backend %unbox-float ( dst src -- ) [ v>operand ] 2apply float-offset LFD ; M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ; @@ -244,7 +241,7 @@ M: ppc-backend %box-long-long ( n func -- ) 4 1 rot cell + local@ LWZ ] when* r> f %alien-invoke ; -: temp@ stack-frame* swap - ; +: temp@ stack-frame* factor-area-size - swap - ; : struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ; @@ -277,7 +274,7 @@ M: ppc-backend %alien-invoke ( symbol dll -- ) 11 %load-dlsym (%call) ; M: ppc-backend %alien-callback ( quot -- ) - 0 load-literal "c_to_factor" f %alien-invoke ; + 3 load-indirect "c_to_factor" f %alien-invoke ; M: ppc-backend %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke @@ -323,35 +320,43 @@ M: ppc-backend %unbox-small-struct drop "No small structs" throw ; ! Alien intrinsics -M: ppc-backend %unbox-byte-array ( quot src -- ) - "address" operand "alien" operand "offset" operand ADD - "address" operand byte-array-offset - roll call ; +M: ppc-backend %unbox-byte-array ( dst src -- ) + [ v>operand ] 2apply byte-array-offset ADDI ; -M: ppc-backend %unbox-alien ( quot src -- ) - "address" operand "alien" operand alien-offset LWZ - "address" operand dup "offset" operand ADD - "address" operand 0 - roll call ; +M: ppc-backend %unbox-alien ( dst src -- ) + [ v>operand ] 2apply alien-offset LWZ ; -M: ppc-backend %unbox-f ( quot src -- ) - "offset" operand 0 - roll call ; +M: ppc-backend %unbox-f ( dst src -- ) + drop 0 swap v>operand LI ; -M: ppc-backend %complex-alien-accessor ( quot src -- ) - "is-f" define-label - "is-alien" define-label - "end" define-label - 0 "alien" operand f v>operand CMPI - "is-f" get BEQ - "address" operand "alien" operand header-offset LWZ - 0 "address" operand alien type-number tag-header CMPI - "is-alien" get BEQ - [ %unbox-byte-array ] 2keep - "end" get B - "is-alien" resolve-label - [ %unbox-alien ] 2keep - "end" get B - "is-f" resolve-label - %unbox-f - "end" resolve-label ; +M: ppc-backend %unbox-any-c-ptr ( dst src -- ) + { "is-byte-array" "end" "start" } [ define-label ] each + ! Address is computed in R12 + 0 12 LI + ! Load object into R11 + 11 swap v>operand MR + ! We come back here with displaced aliens + "start" resolve-label + ! Is the object f? + 0 11 f v>operand CMPI + ! If so, done + "end" get BEQ + ! Is the object an alien? + 0 11 header-offset LWZ + 0 0 alien type-number tag-header CMPI + "is-byte-array" get BNE + ! If so, load the offset + 0 11 alien-offset LWZ + ! Add it to address being computed + 12 12 0 ADD + ! Now recurse on the underlying alien + 11 11 underlying-alien-offset LWZ + "start" get B + "is-byte-array" resolve-label + ! Add byte array address to address being computed + 12 12 11 ADD + ! Add an offset to start of byte array's data area + 12 12 byte-array-offset ADDI + "end" resolve-label + ! Done, store address in destination register + v>operand 12 MR ; diff --git a/core/cpu/ppc/bootstrap.factor b/core/cpu/ppc/bootstrap.factor index 7caaabc16a..d8644e24a6 100644 --- a/core/cpu/ppc/bootstrap.factor +++ b/core/cpu/ppc/bootstrap.factor @@ -17,85 +17,85 @@ big-endian on : temp-reg 6 ; : xt-reg 11 ; -: param-save-size 8 bootstrap-cells ; - -: local@ - bootstrap-cells reserved-area-size param-save-size + + ; - -: array-save 0 local@ ; -: scan-save 1 local@ ; -: xt-save 2 local@ ; +: factor-area-size 4 bootstrap-cells ; : stack-frame - 3 local@ 4 bootstrap-cells align ; + factor-area-size c-area-size + 4 bootstrap-cells align ; + +: next-save stack-frame bootstrap-cell - ; +: xt-save stack-frame 2 bootstrap-cells - ; +: array-save stack-frame 3 bootstrap-cells - ; +: scan-save stack-frame 4 bootstrap-cells - ; [ - temp-reg quot-reg quot-array@ LWZ ! load array - scan-reg temp-reg scan@ ADDI ! initialize scan pointer + temp-reg quot-reg quot-array@ LWZ ! load array + scan-reg temp-reg scan@ ADDI ! initialize scan pointer ] { } make jit-setup set [ - 1 1 stack-frame neg STWU ! store back link - 0 MFLR ! load return address into r0 - temp-reg 1 array-save STW ! save array - xt-reg 1 xt-save STW ! save XT - 0 1 lr-save stack-frame + STW ! save return address + 0 MFLR + 1 1 stack-frame neg ADDI + xt-reg 1 xt-save STW ! save XT + stack-frame xt-reg LI + xt-reg 1 next-save STW ! save frame size + temp-reg 1 array-save STW ! save array + 0 1 lr-save stack-frame + STW ! save return address ] { } make jit-prolog set [ - temp-reg scan-reg 4 LWZU ! load literal and advance - temp-reg ds-reg 4 STWU ! push literal + temp-reg scan-reg 4 LWZU ! load literal and advance + temp-reg ds-reg 4 STWU ! push literal ] { } make jit-push-literal set [ - temp-reg scan-reg 4 LWZU ! load wrapper and advance - temp-reg dup wrapper@ LWZ ! load wrapped object - temp-reg ds-reg 4 STWU ! push wrapped object + temp-reg scan-reg 4 LWZU ! load wrapper and advance + temp-reg dup wrapper@ LWZ ! load wrapped object + temp-reg ds-reg 4 STWU ! push wrapped object ] { } make jit-push-wrapper set [ - 4 1 MR ! pass stack pointer to primitive + 4 1 MR ! pass stack pointer to primitive ] { } make jit-word-primitive-jump set [ - 4 1 MR ! pass stack pointer to primitive + 4 1 MR ! pass stack pointer to primitive ] { } make jit-word-primitive-call set : load-xt ( -- ) xt-reg word-reg word-xt@ LWZ ; : jit-call - scan-reg 1 scan-save STW ! save scan pointer - xt-reg MTLR ! pass XT to callee - BLRL ! call - scan-reg 1 scan-save LWZ ! restore scan pointer + scan-reg 1 scan-save STW ! save scan pointer + xt-reg MTLR ! pass XT to callee + BLRL ! call + scan-reg 1 scan-save LWZ ! restore scan pointer ; : jit-jump xt-reg MTCTR BCTR ; [ - word-reg scan-reg 4 LWZU ! load word and advance + word-reg scan-reg 4 LWZU ! load word and advance load-xt jit-call ] { } make jit-word-call set [ - word-reg scan-reg 4 LWZ ! load word - load-xt ! jump to word XT + word-reg scan-reg 4 LWZ ! load word + load-xt ! jump to word XT jit-jump ] { } make jit-word-jump set : load-branch - temp-reg ds-reg 0 LWZ ! load boolean - 0 temp-reg \ f tag-number CMPI ! compare it with f - quot-reg scan-reg MR ! point quot-reg at false branch - 2 BNE ! skip next insn if its not f - quot-reg dup 4 ADDI ! point quot-reg at true branch - quot-reg dup 4 LWZ ! load the branch - ds-reg dup 4 SUBI ! pop boolean - scan-reg dup 12 ADDI ! advance scan pointer - xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt + temp-reg ds-reg 0 LWZ ! load boolean + 0 temp-reg \ f tag-number CMPI ! compare it with f + quot-reg scan-reg MR ! point quot-reg at false branch + 2 BNE ! skip next insn if its not f + quot-reg dup 4 ADDI ! point quot-reg at true branch + quot-reg dup 4 LWZ ! load the branch + ds-reg dup 4 SUBI ! pop boolean + scan-reg dup 12 ADDI ! advance scan pointer + xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt ; [ @@ -107,20 +107,20 @@ big-endian on ] { } make jit-if-call set [ - temp-reg ds-reg 0 LWZ ! load index - temp-reg dup 1 SRAWI ! turn it into an array offset - ds-reg dup 4 SUBI ! pop index - scan-reg dup 4 LWZ ! load array - temp-reg dup scan-reg ADD ! compute quotation location - quot-reg temp-reg array-start LWZ ! load quotation - xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt - jit-jump ! execute quotation + temp-reg ds-reg 0 LWZ ! load index + temp-reg dup 1 SRAWI ! turn it into an array offset + ds-reg dup 4 SUBI ! pop index + scan-reg dup 4 LWZ ! load array + temp-reg dup scan-reg ADD ! compute quotation location + quot-reg temp-reg array-start LWZ ! load quotation + xt-reg quot-reg quot-xt@ LWZ ! load quotation-xt + jit-jump ! execute quotation ] { } make jit-dispatch set [ - 0 1 lr-save stack-frame + LWZ ! load return address - 1 1 stack-frame ADDI ! pop stack frame - 0 MTLR ! get ready to return + 0 1 lr-save stack-frame + LWZ ! load return address + 1 1 stack-frame ADDI ! pop stack frame + 0 MTLR ! get ready to return ] { } make jit-epilog set [ BLR ] { } make jit-return set diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 97d866d883..ede213dc52 100644 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -15,7 +15,7 @@ IN: cpu.ppc.intrinsics "val" operand "obj" operand "n" get cells - "obj" operand-tag - ; + "obj" get operand-tag - ; : %slot-literal-any-tag "obj" operand "scratch" operand %untag @@ -58,7 +58,7 @@ IN: cpu.ppc.intrinsics "cards_offset" f pick %load-dlsym dup 0 LWZ ; : %write-barrier ( -- ) - "val" operand-immediate? "obj" get fresh-object? or [ + "val" get operand-immediate? "obj" get fresh-object? or [ "obj" operand "scratch" operand card-bits SRWI "val" operand load-cards-offset "scratch" operand dup "val" operand ADD @@ -601,41 +601,42 @@ IN: cpu.ppc.intrinsics } define-intrinsic ! Alien intrinsics +: %alien-accessor ( quot -- ) + "offset" operand dup %untag-fixnum + "offset" operand dup "alien" operand ADD + "value" operand "offset" operand 0 roll call ; inline + : alien-integer-get-template H{ { +input+ { - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } - { +scratch+ { { f "output" } } } - { +output+ { "output" } } + { +scratch+ { { f "value" } } } + { +output+ { "value" } } { +clobber+ { "offset" } } } ; -: %alien-get ( quot -- ) - "output" get "address" set - "offset" operand dup %untag-fixnum - "output" operand "alien" operand-class %alien-accessor ; - : %alien-integer-get ( quot -- ) - %alien-get - "output" operand dup %tag-fixnum ; inline - -: %alien-integer-set ( quot -- ) - { "offset" "value" } %untag-fixnums - "value" operand "alien" operand-class %alien-accessor ; inline + %alien-accessor + "value" operand dup %tag-fixnum ; inline : alien-integer-set-template H{ { +input+ { { f "value" fixnum } - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } - { +scratch+ { { f "address" } } } { +clobber+ { "value" "offset" } } } ; +: %alien-integer-set ( quot -- ) + "offset" get "value" get = [ + "value" operand dup %untag-fixnum + ] unless + %alien-accessor ; inline + : define-alien-integer-intrinsics ( word get-quot word set-quot -- ) [ %alien-integer-set ] curry alien-integer-set-template @@ -660,41 +661,55 @@ define-alien-integer-intrinsics \ set-alien-signed-2 [ STH ] define-alien-integer-intrinsics -: %alien-float-get ( quot -- ) - "offset" operand dup %untag-fixnum - "output" operand "alien" operand-class %alien-accessor ; inline +\ alien-cell [ + [ LWZ ] %alien-accessor +] H{ + { +input+ { + { unboxed-c-ptr "alien" c-ptr } + { f "offset" fixnum } + } } + { +scratch+ { { unboxed-alien "value" } } } + { +output+ { "value" } } + { +clobber+ { "offset" } } +} define-intrinsic + +\ set-alien-cell [ + [ STW ] %alien-accessor +] H{ + { +input+ { + { unboxed-c-ptr "value" pinned-c-ptr } + { unboxed-c-ptr "alien" c-ptr } + { f "offset" fixnum } + } } + { +clobber+ { "offset" } } +} define-intrinsic : alien-float-get-template H{ { +input+ { - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } - { +scratch+ { { float "output" } { f "address" } } } - { +output+ { "output" } } + { +scratch+ { { float "value" } } } + { +output+ { "value" } } { +clobber+ { "offset" } } } ; -: %alien-float-set ( quot -- ) - "offset" operand dup %untag-fixnum - "value" operand "alien" operand-class %alien-accessor ; inline - : alien-float-set-template H{ { +input+ { { float "value" float } - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } - { +scratch+ { { f "address" } } } { +clobber+ { "offset" } } } ; : define-alien-float-intrinsics ( word get-quot word set-quot -- ) - [ %alien-float-set ] curry + [ %alien-accessor ] curry alien-float-set-template define-intrinsic - [ %alien-float-get ] curry + [ %alien-accessor ] curry alien-float-get-template define-intrinsic ; @@ -705,8 +720,3 @@ define-alien-float-intrinsics \ alien-float [ LFS ] \ set-alien-float [ STFS ] define-alien-float-intrinsics - -\ alien-cell [ - [ LWZ ] %alien-get - "output" get %allot-alien -] alien-integer-get-template define-intrinsic diff --git a/core/cpu/ppc/linux/bootstrap.factor b/core/cpu/ppc/linux/bootstrap.factor index 32491f90a2..a84bff5141 100644 --- a/core/cpu/ppc/linux/bootstrap.factor +++ b/core/cpu/ppc/linux/bootstrap.factor @@ -3,7 +3,7 @@ USING: parser layouts system ; IN: bootstrap.ppc -: reserved-area-size 2 bootstrap-cells ; +: c-area-size 10 bootstrap-cells ; : lr-save bootstrap-cell ; "resource:core/cpu/ppc/bootstrap.factor" run-file diff --git a/core/cpu/ppc/macosx/bootstrap.factor b/core/cpu/ppc/macosx/bootstrap.factor index 4909c8649c..016e445522 100644 --- a/core/cpu/ppc/macosx/bootstrap.factor +++ b/core/cpu/ppc/macosx/bootstrap.factor @@ -3,7 +3,7 @@ USING: parser layouts system ; IN: bootstrap.ppc -: reserved-area-size 6 bootstrap-cells ; +: c-area-size 14 bootstrap-cells ; : lr-save 2 bootstrap-cells ; "resource:core/cpu/ppc/bootstrap.factor" run-file diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor index c6989615b2..49ca17c36d 100644 --- a/core/cpu/x86/allot/allot.factor +++ b/core/cpu/x86/allot/allot.factor @@ -6,38 +6,47 @@ math.functions sequences generic arrays generator generator.fixup generator.registers system layouts alien ; IN: cpu.x86.allot -: (object@) ( n -- operand ) temp-reg v>operand swap [+] ; +: allot-reg + #! We temporarily use the datastack register, since it won't + #! be accessed inside the quotation given to %allot in any + #! case. + ds-reg ; + +: (object@) ( n -- operand ) allot-reg swap [+] ; : object@ ( n -- operand ) cells (object@) ; : load-zone-ptr ( -- ) #! Load pointer to start of zone array - "nursery" f %alien-global ; + "nursery" f allot-reg %alien-global ; : load-allot-ptr ( -- ) load-zone-ptr - temp-reg v>operand dup cell [+] MOV ; + allot-reg PUSH + allot-reg dup cell [+] MOV ; : inc-allot-ptr ( n -- ) - load-zone-ptr - temp-reg v>operand cell [+] swap 8 align ADD ; + allot-reg POP + allot-reg cell [+] swap 8 align ADD ; : store-header ( header -- ) 0 object@ swap type-number tag-header MOV ; : %allot ( header size quot -- ) + allot-reg PUSH swap >r >r load-allot-ptr store-header r> call - r> inc-allot-ptr ; inline + r> inc-allot-ptr + allot-reg POP ; inline : %store-tagged ( reg tag -- ) >r dup fresh-object v>operand r> - temp-reg v>operand swap tag-number OR - temp-reg v>operand MOV ; + allot-reg swap tag-number OR + allot-reg MOV ; -M: x86-backend %move-float>int ( dst src -- ) +M: x86-backend %box-float ( dst src -- ) #! Only called by pentium4 backend, uses SSE2 instruction #! dest is a loc or a vreg float 16 [ @@ -77,21 +86,21 @@ M: x86-backend %move-float>int ( dst src -- ) "end" resolve-label ] with-scope ; -: %allot-alien ( ptr -- ) +M: x86-backend %box-alien ( dst src -- ) [ - "temp" set { "end" "f" } [ define-label ] each - "temp" operand 0 CMP + dup v>operand 0 CMP "f" get JE alien 4 cells [ 1 object@ f v>operand MOV 2 object@ f v>operand MOV - 3 object@ "temp" operand MOV - ! Store tagged ptr in reg - "temp" get object %store-tagged + ! Store src in alien-offset slot + 3 object@ swap v>operand MOV + ! Store tagged ptr in dst + dup object %store-tagged ] %allot "end" get JMP "f" resolve-label - "temp" operand f v>operand MOV + f [ v>operand ] 2apply MOV "end" resolve-label ] with-scope ; diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 91e8bf1460..0309df052b 100644 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -47,31 +47,31 @@ M: x86-backend stack-frame ( n -- i ) M: x86-backend %save-xt ( -- ) xt-reg compiling-label get MOV ; +: factor-area-size 4 cells ; + M: x86-backend %prologue ( n -- ) + dup cell + PUSH xt-reg PUSH - xt-reg stack-reg pick stack-frame 4 cells + neg [+] LEA - xt-reg PUSH - stack-reg swap stack-frame 2 cells - SUB ; + stack-reg swap 2 cells - SUB ; M: x86-backend %epilogue ( n -- ) - stack-reg swap stack-frame ADD ; + stack-reg swap ADD ; -: %alien-global ( symbol dll -- ) - temp-reg v>operand 0 MOV rc-absolute-cell rel-dlsym - temp-reg v>operand dup [] MOV ; +: %alien-global ( symbol dll register -- ) + [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ; M: x86-backend %prepare-alien-invoke #! Save Factor stack pointers in case the C code calls a #! callback which does a GC, which must reliably trace #! all roots. - "stack_chain" f %alien-global + "stack_chain" f temp-reg v>operand %alien-global temp-reg v>operand [] stack-reg MOV temp-reg v>operand 2 cells [+] ds-reg MOV temp-reg v>operand 3 cells [+] rs-reg MOV ; M: x86-backend %profiler-prologue ( word -- ) "end" define-label - "profiling" f %alien-global + "profiling" f temp-reg v>operand %alien-global temp-reg v>operand 0 CMP "end" get JE temp-reg load-literal @@ -121,15 +121,12 @@ M: x86-backend %call-dispatch ( word-table# -- ) M: x86-backend %jump-dispatch ( word-table# -- ) [ %epilogue-later JMP ] dispatch-template ; -M: x86-backend %move-int>int ( dst src -- ) - [ v>operand ] 2apply MOV ; - -M: x86-backend %move-int>float ( dst src -- ) +M: x86-backend %unbox-float ( dst src -- ) [ v>operand ] 2apply float-offset [+] MOVSD ; -M: int-regs (%peek) drop %move-int>int ; +M: x86-backend %peek [ v>operand ] 2apply MOV ; -M: int-regs (%replace) drop swap %move-int>int ; +M: x86-backend %replace swap %peek ; : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; @@ -177,30 +174,45 @@ M: x86-backend struct-small-enough? ( size -- ? ) M: x86-backend %return ( -- ) 0 %unwind ; ! Alien intrinsics -M: x86-backend %unbox-byte-array ( quot src -- ) - "alien" operand "offset" operand ADD - "alien" operand byte-array-offset [+] - rot call ; +M: x86-backend %unbox-byte-array ( dst src -- ) + [ v>operand ] 2apply byte-array-offset [+] LEA ; -M: x86-backend %unbox-alien ( quot src -- ) - "alien" operand dup alien-offset [+] MOV - "alien" operand "offset" operand [+] - rot call ; +M: x86-backend %unbox-alien ( dst src -- ) + [ v>operand ] 2apply alien-offset [+] MOV ; -M: x86-backend %unbox-f ( quot src -- ) - "offset" operand rot call ; +M: x86-backend %unbox-f ( dst src -- ) + drop v>operand 0 MOV ; -M: x86-backend %complex-alien-accessor ( quot src -- ) - { "is-f" "is-alien" "end" } [ define-label ] each - "alien" operand f v>operand CMP - "is-f" get JE - "alien" operand header-offset [+] alien type-number tag-header CMP - "is-alien" get JE - [ %unbox-byte-array ] 2keep - "end" get JMP - "is-alien" resolve-label - [ %unbox-alien ] 2keep - "end" get JMP - "is-f" resolve-label - %unbox-f - "end" resolve-label ; +M: x86-backend %unbox-any-c-ptr ( dst src -- ) + { "is-byte-array" "end" "start" } [ define-label ] each + ! Address is computed in ds-reg + ds-reg PUSH + ds-reg 0 MOV + ! Object is stored in ds-reg + rs-reg PUSH + rs-reg swap v>operand MOV + ! We come back here with displaced aliens + "start" resolve-label + ! Is the object f? + rs-reg f v>operand CMP + "end" get JE + ! Is the object an alien? + rs-reg header-offset [+] alien type-number tag-header CMP + "is-byte-array" get JNE + ! If so, load the offset and add it to the address + ds-reg rs-reg alien-offset [+] ADD + ! Now recurse on the underlying alien + rs-reg rs-reg underlying-alien-offset [+] MOV + "start" get JMP + "is-byte-array" resolve-label + ! Add byte array address to address being computed + ds-reg rs-reg ADD + ! Add an offset to start of byte array's data + ds-reg byte-array-offset ADD + "end" resolve-label + ! Done, store address in destination register + v>operand ds-reg MOV + ! Restore rs-reg + rs-reg POP + ! Restore ds-reg + ds-reg POP ; diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index 67156d8300..a8c1b9a8f2 100644 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -10,15 +10,16 @@ big-endian off : scan-save stack-reg 3 bootstrap-cells [+] ; +: stack-frame-size 8 bootstrap-cells ; + [ arg0 arg0 quot-array@ [+] MOV ! load array scan-reg arg0 scan@ [+] LEA ! initialize scan pointer ] { } make jit-setup set - -[ + +[ + stack-frame-size PUSH ! save stack frame size xt-reg PUSH ! save XT - xt-reg stack-reg next-frame@ [+] LEA ! compute forward chain pointer - xt-reg PUSH ! save forward chain pointer arg0 PUSH ! save array stack-reg 4 bootstrap-cells SUB ! reserve space for scan-save ] { } make jit-prolog set @@ -31,7 +32,7 @@ big-endian off arg0 scan-reg [] MOV ! load literal ds-reg [] arg0 MOV ! store literal on datastack ] { } make jit-push-literal set - + [ advance-scan ds-reg bootstrap-cell ADD ! increment datastack pointer @@ -94,7 +95,7 @@ big-endian off ] { } make jit-dispatch set [ - stack-reg 7 bootstrap-cells ADD ! unwind stack frame + stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame ] { } make jit-epilog set [ 0 RET ] { } make jit-return set diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 0228848a33..c828474742 100644 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -74,7 +74,7 @@ IN: cpu.x86.intrinsics : %slot-literal-known-tag "obj" operand "n" get cells - "obj" operand-tag - [+] ; + "obj" get operand-tag - [+] ; : %slot-literal-any-tag "obj" operand %untag @@ -88,9 +88,10 @@ IN: cpu.x86.intrinsics \ slot { ! Slot number is literal and the tag is known { - [ "obj" operand %slot-literal-known-tag MOV ] H{ + [ "val" operand %slot-literal-known-tag MOV ] H{ { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } } - { +output+ { "obj" } } + { +scratch+ { { f "val" } } } + { +output+ { "val" } } } } ! Slot number is literal @@ -112,9 +113,9 @@ IN: cpu.x86.intrinsics : generate-write-barrier ( -- ) #! Mark the card pointed to by vreg. - "val" operand-immediate? "obj" get fresh-object? or [ + "val" get operand-immediate? "obj" get fresh-object? or [ "obj" operand card-bits SHR - "cards_offset" f %alien-global + "cards_offset" f temp-reg v>operand %alien-global temp-reg v>operand "obj" operand [+] card-mark OR ] unless ; @@ -498,22 +499,27 @@ IN: cpu.x86.intrinsics } define-intrinsic ! Alien intrinsics +: %alien-accessor ( quot -- ) + "offset" operand %untag-fixnum + "offset" operand "alien" operand ADD + "offset" operand [] swap call ; inline + : %alien-integer-get ( quot reg -- ) small-reg PUSH - "offset" operand %untag-fixnum - "alien" operand-class %alien-accessor - "offset" operand small-reg MOV - "offset" operand %tag-fixnum + swap %alien-accessor + "value" operand small-reg MOV + "value" operand %tag-fixnum small-reg POP ; inline : alien-integer-get-template H{ { +input+ { - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } - { +output+ { "offset" } } - { +clobber+ { "alien" "offset" } } + { +scratch+ { { f "value" } } } + { +output+ { "value" } } + { +clobber+ { "offset" } } } ; : define-getter @@ -529,19 +535,21 @@ IN: cpu.x86.intrinsics : %alien-integer-set ( quot reg -- ) small-reg PUSH - { "offset" "value" } %untag-fixnums + "offset" get "value" get = [ + "value" operand %untag-fixnum + ] unless small-reg "value" operand MOV - "alien" operand-class %alien-accessor + swap %alien-accessor small-reg POP ; inline : alien-integer-set-template H{ { +input+ { { f "value" fixnum } - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } - { +clobber+ { "value" "alien" "offset" } } + { +clobber+ { "value" "offset" } } } ; : define-setter @@ -563,12 +571,24 @@ IN: cpu.x86.intrinsics \ set-alien-signed-2 small-reg-16 define-setter \ alien-cell [ - "offset" operand %untag-fixnum + "value" operand [ MOV ] %alien-accessor +] H{ + { +input+ { + { unboxed-c-ptr "alien" c-ptr } + { f "offset" fixnum } + } } + { +scratch+ { { unboxed-alien "value" } } } + { +output+ { "value" } } + { +clobber+ { "offset" } } +} define-intrinsic - [ MOV ] - "offset" operand - "alien" operand-class - %alien-accessor - - "offset" get %allot-alien -] alien-integer-get-template define-intrinsic +\ set-alien-cell [ + "value" operand [ swap MOV ] %alien-accessor +] H{ + { +input+ { + { unboxed-c-ptr "value" c-ptr } + { unboxed-c-ptr "alien" c-ptr } + { f "offset" fixnum } + } } + { +clobber+ { "offset" } } +} define-intrinsic diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor index 3fa83a4ed7..cb8c87ed8d 100644 --- a/core/cpu/x86/sse2/sse2.factor +++ b/core/cpu/x86/sse2/sse2.factor @@ -1,18 +1,12 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays cpu.x86.assembler cpu.x86.architecture -generic kernel kernel.private math math.private memory -namespaces sequences words generator generator.registers -cpu.architecture math.floats.private layouts quotations ; +cpu.x86.intrinsics generic kernel kernel.private math +math.private memory namespaces sequences words generator +generator.registers cpu.architecture math.floats.private layouts +quotations ; IN: cpu.x86.sse2 -M: float-regs (%peek) - drop - temp-reg swap %move-int>int - temp-reg %move-int>float ; - -M: float-regs (%replace) drop swap %move-float>int ; - : define-float-op ( word op -- ) [ "x" operand "y" operand ] swap add H{ { +input+ { { float "x" } { float "y" } } } @@ -61,42 +55,32 @@ M: float-regs (%replace) drop swap %move-float>int ; { +clobber+ { "in" } } } define-intrinsic -: %alien-float-get ( quot -- ) - "offset" operand %untag-fixnum - "output" operand "alien" operand-class %alien-accessor ; - inline - : alien-float-get-template H{ { +input+ { - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } - { +scratch+ { { float "output" } } } - { +output+ { "output" } } - { +clobber+ { "alien" "offset" } } + { +scratch+ { { float "value" } } } + { +output+ { "value" } } + { +clobber+ { "offset" } } } ; -: %alien-float-set ( quot -- ) - "offset" operand %untag-fixnum - "value" operand "alien" operand-class %alien-accessor ; - inline - : alien-float-set-template H{ { +input+ { { float "value" float } - { f "alien" simple-c-ptr } + { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } - { +clobber+ { "value" "alien" "offset" } } + { +clobber+ { "offset" } } } ; : define-alien-float-intrinsics ( word get-quot word set-quot -- ) - [ %alien-float-set ] curry + [ "value" operand swap %alien-accessor ] curry alien-float-set-template define-intrinsic - [ %alien-float-get ] curry + [ "value" operand swap %alien-accessor ] curry alien-float-get-template define-intrinsic ; diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 62d6afc393..d881184508 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -51,3 +51,18 @@ M: integer (stack-picture) drop "object" ; M: effect clone [ effect-in clone ] keep effect-out clone ; + +: split-shuffle ( stack shuffle -- stack1 stack2 ) + effect-in length swap cut* ; + +: load-shuffle ( stack shuffle -- ) + effect-in [ set ] 2each ; + +: shuffled-values ( shuffle -- values ) + effect-out [ get ] map ; + +: shuffle* ( stack shuffle -- newstack ) + [ [ load-shuffle ] keep shuffled-values ] with-scope ; + +: shuffle ( stack shuffle -- newstack ) + [ split-shuffle ] keep shuffle* append ; diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index a339f950b4..b45f463bbe 100644 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -35,7 +35,8 @@ M: label fixup* : resolve-label ( label/name -- ) dup label? [ get ] unless , ; : if-stack-frame ( frame-size quot -- ) - over no-stack-frame = [ 2drop ] [ call ] if ; inline + swap dup no-stack-frame = + [ 2drop ] [ stack-frame swap call ] if ; inline M: word fixup* { diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 3b1ea07f0f..30295b722e 100644 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables -inference inference.backend inference.dataflow inference.stack -io kernel kernel.private layouts math namespaces optimizer -prettyprint quotations sequences system threads words ; +inference inference.backend inference.dataflow io kernel +kernel.private layouts math namespaces optimizer prettyprint +quotations sequences system threads words ; IN: generator SYMBOL: compiled-xts @@ -73,10 +73,9 @@ SYMBOL: profiler-prologues : word-dataflow ( word -- dataflow ) [ dup "no-effect" word-prop [ no-effect ] when - dup dup add-recursive-state - [ specialized-def (dataflow) ] keep - finish-word drop - ] with-infer ; + dup specialized-def over dup 2array 1array infer-quot + finish-word + ] with-infer nip ; SYMBOL: compiler-hook @@ -229,7 +228,7 @@ M: #dispatch generate-node "true" resolve-label t "if-scratch" get load-literal "end" resolve-label - "if-scratch" get phantom-d get phantom-push ; inline + "if-scratch" get phantom-push ; inline : define-if>boolean-intrinsics ( word intrinsics -- ) [ @@ -247,10 +246,8 @@ M: #dispatch generate-node : define-if-intrinsic ( word quot inputs -- ) 2array 1array define-if-intrinsics ; -: do-intrinsic ( pair -- ) first2 with-template ; - : do-if-intrinsic ( #call pair -- next ) -