- the invalid recursion form case needs to be fixed, for inlines too
- code gc
- compiled gc check slows things down
+- fix branch folding
+ misc:
\ slot [
dup slot@ [
{ { 0 "obj" } { value "slot" } } { "obj" } [
- node get slot@ "obj" get %fast-slot ,
+ node %get slot@ "obj" %get %fast-slot ,
] with-template
] [
{ { 0 "obj" } { 1 "n" } } { "obj" } [
- "obj" get %untag ,
- "n" get "obj" get %slot ,
+ "obj" %get %untag ,
+ "n" %get "obj" %get %slot ,
] with-template
] if
] "intrinsic" set-word-prop
\ set-slot [
dup slot@ [
{ { 0 "val" } { 1 "obj" } { value "slot" } } { } [
- "val" get "obj" get node get slot@ %fast-set-slot ,
+ "val" %get "obj" %get node %get slot@
+ %fast-set-slot ,
] with-template
] [
{ { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
- "obj" get %untag ,
- "val" get "obj" get "slot" get %set-slot ,
+ "obj" %get %untag ,
+ "val" %get "obj" %get "slot" %get %set-slot ,
] with-template
] if
end-basic-block
\ char-slot [
{ { 0 "n" } { 1 "str" } } { "str" } [
- "n" get "str" get %char-slot ,
+ "n" %get "str" %get %char-slot ,
] with-template
] "intrinsic" set-word-prop
\ set-char-slot [
{ { 0 "ch" } { 1 "n" } { 2 "str" } } { } [
- "ch" get "str" get "n" get %set-char-slot ,
+ "ch" %get "str" %get "n" %get %set-char-slot ,
] with-template
] "intrinsic" set-word-prop
\ type [
{ { any-reg "in" } } { "in" }
- [ end-basic-block "in" get %type , ] with-template
+ [ end-basic-block "in" %get %type , ] with-template
] "intrinsic" set-word-prop
\ tag [
- { { any-reg "in" } } { "in" } [ "in" get %tag , ] with-template
+ { { any-reg "in" } } { "in" } [ "in" %get %tag , ] with-template
] "intrinsic" set-word-prop
\ getenv [
{ { value "env" } } { "out" } [
T{ vreg f 0 } "out" set
- "env" get "out" get %getenv ,
+ "env" %get "out" %get %getenv ,
] with-template
] "intrinsic" set-word-prop
\ setenv [
{ { any-reg "value" } { value "env" } } { } [
- "value" get "env" get %setenv ,
+ "value" %get "env" %get %setenv ,
] with-template
] "intrinsic" set-word-prop
: (binary-op) ( node in -- )
{ "x" } [
- end-basic-block >r "y" get "x" get dup r> execute ,
+ end-basic-block >r "y" %get "x" %get dup r> execute ,
] with-template ; inline
: binary-op ( node op -- )
: binary-jump ( node label op -- )
rot { { any-reg "x" } { any-reg "y" } } { } [
- end-basic-block >r >r "y" get "x" get r> r> execute ,
+ end-basic-block >r >r "y" %get "x" %get r> r> execute ,
] with-template ; inline
{
{ { 0 "x" } { 1 "y" } } { "out" } [
end-basic-block
T{ vreg f 2 } "out" set
- "y" get "x" get "out" get %fixnum-mod ,
+ "y" %get "x" %get "out" %get %fixnum-mod ,
] with-template
] "intrinsic" set-word-prop
end-basic-block
T{ vreg f 0 } "quo" set
T{ vreg f 2 } "rem" set
- "y" get "x" get 2array
- "rem" get "quo" get 2array %fixnum/mod ,
+ "y" %get "x" %get 2array
+ "rem" %get "quo" %get 2array %fixnum/mod ,
] with-template
] "intrinsic" set-word-prop
\ fixnum-bitnot [
{ { 0 "x" } } { "x" } [
- "x" get dup %fixnum-bitnot ,
+ "x" %get dup %fixnum-bitnot ,
] with-template
] "intrinsic" set-word-prop
dup cell-bits neg <= [
drop
T{ vreg f 2 } "out" set
- "x" get "out" get %fixnum-sgn ,
+ "x" %get "out" %get %fixnum-sgn ,
] [
- "x" get "out" set
- neg "x" get "out" get %fixnum>> ,
+ "x" %get "out" set
+ neg "x" %get "out" %get %fixnum>> ,
] if
] with-template ;
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
USING: arrays generic hashtables inference
kernel math namespaces sequences words ;
+IN: compiler
-! On PowerPC and AMD64, we use a stack discipline whereby
-! stack frames are used to hold parameters. We need to compute
-! the stack frame size to compile the prologue on entry to a
-! word.
GENERIC: stack-reserve*
M: object stack-reserve* drop 0 ;
M: #call-label linearize* ( node -- next )
node-param renamed-label linearize-call ;
-: prepare-inputs ( values -- values templates )
+SYMBOL: live-d
+SYMBOL: live-r
+
+: value-dropped? ( value -- ? )
+ dup value?
+ over live-d get member? not
+ rot live-r get member? not and
+ or ;
+
+: shuffle-in-template ( values -- value template )
+ [ dup value-dropped? [ drop f ] when ] map
dup [ any-reg swap 2array ] map ;
-: do-inputs ( shuffle -- )
- dup shuffle-in-d prepare-inputs
- rot shuffle-in-r prepare-inputs
- template-inputs ;
+: shuffle-out-template ( instack outstack -- stack )
+ #! Avoid storing a value into its former position.
+ dup length [
+ pick ?nth dupd eq? [ <clean> ] when
+ ] 2map nip ;
+
+: linearize-shuffle ( shuffle -- )
+ dup shuffle-in-d over shuffle-out-d
+ shuffle-out-template live-d set
+ dup shuffle-in-r over shuffle-out-r
+ shuffle-out-template live-r set
+ dup shuffle-in-d shuffle-in-template
+ rot shuffle-in-r shuffle-in-template template-inputs
+ live-d get live-r get template-outputs ;
M: #shuffle linearize* ( #shuffle -- )
compute-free-vregs
- node-shuffle trim-shuffle dup do-inputs
- dup shuffle-out-d swap shuffle-out-r template-outputs
+ node-shuffle linearize-shuffle
iterate-next ;
: ?static-branch ( node -- n )
] [
dup { { 0 "flag" } } { } [
end-basic-block
- <label> dup "flag" get %jump-t ,
+ <label> dup "flag" %get %jump-t ,
] with-template linearize-if
] if* ;
#! Output the jump table insn and return a list of
#! label/branch pairs.
dup { { 0 "n" } } { }
- [ end-basic-block "n" get %dispatch , ] with-template
+ [ end-basic-block "n" %get %dispatch , ] with-template
node-children [ <label> dup %target-label , 2array ] map ;
: dispatch-body ( label/node -- )
! A call stack location.
TUPLE: cs-loc n ;
+! A marker for values which are already stored in this location
+TUPLE: clean ;
+
+C: clean [ set-delegate ] keep ;
+
TUPLE: phantom-stack height ;
C: phantom-stack ( -- stack )
M: object vreg>stack ( value loc -- )
%replace , ;
+M: clean vreg>stack ( value loc -- ) 2drop ;
+
: vregs>stack ( phantom -- )
dup dup phantom-locs* [ vreg>stack ] 2each
0 swap set-length ;
SYMBOL: free-vregs
: compute-free-vregs ( -- )
- phantom-d get [ vreg? ] subset
- phantom-r get [ vreg? ] subset append
- [ vreg-n ] map vregs length reverse diff
+ phantom-d get phantom-r get append
+ [ vreg? ] subset [ vreg-n ] map
+ vregs length reverse diff
>vector free-vregs set ;
: requested-vregs ( template -- n )
: (stack>vregs) ( values template locs -- inputs )
3array flip
- [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
+ [ first3 over [ stack>vreg <clean> ] [ 3drop f ] if ] map ;
+
+: ?clean ( obj -- obj )
+ dup clean? [ delegate ] when ;
+
+: %get ( obj -- value )
+ get ?clean dup value? [ value-literal ] when ;
: phantom-vregs ( values template -- )
- >r [ dup value? [ value-literal ] when ] map
- r> [ second set ] 2each ;
+ [ second set ] 2each ;
: stack>vregs ( values phantom template -- values )
[
swap dup value? [ 2drop f ] [ vreg-n = ] if ;
: compatible-values? ( value template -- ? )
- {
+ >r ?clean r> {
{ [ dup not ] [ 2drop t ] }
{ [ over not ] [ 2drop f ] }
{ [ dup any-reg eq? ] [ drop vreg? ] }
: drop-phantom ( -- )
end-basic-block -1 phantom-d get adjust-phantom ;
+: prep-output ( value -- value )
+ {
+ { [ dup value? ] [ ] }
+ { [ dup clean? ] [ delegate dup value? [ get ] unless ] }
+ { [ t ] [ get ?clean ] }
+ } cond ;
+
: template-output ( seq stack -- )
over length over adjust-phantom
- swap [ dup value? [ get ] unless ] map nappend ;
+ swap [ prep-output ] map nappend ;
: template-outputs ( stack stack -- )
phantom-r get template-output
[ shuffle-out-d clone ] keep
shuffle-out-r clone
<shuffle> ;
-
-SYMBOL: live-d
-SYMBOL: live-r
-
-: value-dropped? ( value -- ? )
- dup value?
- over live-d get member? not
- rot live-r get member? not and
- or ;
-
-: filter-dropped ( seq -- seq )
- [ dup value-dropped? [ drop f ] when ] map ;
-
-: live-stores ( instack outstack -- stack )
- #! Avoid storing a value into its former position.
- dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
-
-: trim-shuffle ( shuffle -- shuffle )
- dup shuffle-in-d over shuffle-out-d live-stores live-d set
- dup shuffle-in-r over shuffle-out-r live-stores live-r set
- dup shuffle-in-d filter-dropped
- swap shuffle-in-r filter-dropped
- live-d get live-r get <shuffle> ;
! Test literals in either side of a shuffle
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test
+
+: foo ;
+
+[ 4 4 ]
+[ 1/2 [ tag [ foo ] keep ] compile-1 ]
+unit-test
+
+[ 1 2 2 ]
+[ 1/2 [ dup 0 slot swap 1 slot [ foo ] keep ] compile-1 ]
+unit-test
0 > "a positive " "a negative " ? ;
M: integer summary
- dup sign-string over 2 mod zero? "even " "odd " ?
- rot class word-name append3 ;
+ dup zero? [
+ "a " "zero "
+ ] [
+ dup sign-string over 2 mod zero? "even " "odd " ?
+ ] if rot class word-name append3 ;
M: real summary
dup sign-string swap class word-name append ;