"/library/compiler/vops.factor"
"/library/compiler/templates.factor"
"/library/compiler/linearizer.factor"
+ "/library/compiler/stack.factor"
"/library/compiler/xt.factor"
"/library/compiler/intrinsics.factor"
"/library/compiler/generator.factor"
namespaces sequences words ;
\ slot [
- drop
{ { any-reg "obj" } { any-reg "n" } } { "obj" } [
- "obj" %get %untag ,
- "n" %get "obj" %get %slot ,
+ "obj" get %untag ,
+ "n" get "obj" get %slot ,
] with-template
] "intrinsic" set-word-prop
\ set-slot [
- drop
{ { any-reg "val" } { any-reg "obj" } { any-reg "slot" } }
{ } [
- "obj" %get %untag ,
- "val" %get "obj" %get "slot" %get %set-slot ,
+ "obj" get %untag ,
+ "val" get "obj" get "slot" get %set-slot ,
end-basic-block
"obj" get %write-barrier ,
] with-template
] "intrinsic" set-word-prop
\ char-slot [
- drop
{ { any-reg "n" } { any-reg "str" } } { "str" } [
- "n" %get "str" %get %char-slot ,
+ "n" get "str" get %char-slot ,
] with-template
] "intrinsic" set-word-prop
\ set-char-slot [
- drop
{ { any-reg "ch" } { any-reg "n" } { any-reg "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 [
- drop
{ { 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 [
- drop
- { { any-reg "in" } } { "in" } [ "in" %get %tag , ] with-template
+ { { any-reg "in" } } { "in" }
+ [ "in" get %tag , ] with-template
] "intrinsic" set-word-prop
: binary-op ( op -- )
{ { 0 "x" } { 1 "y" } } { "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
{
{ fixnum/i %fixnum/i }
{ fixnum* %fixnum* }
} [
- first2 [ binary-op drop ] curry
+ first2 [ binary-op ] curry
"intrinsic" set-word-prop
] each
: binary-jump ( label op -- )
{ { 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
{
{ fixnum> %jump-fixnum> }
{ eq? %jump-eq? }
} [
- first2 [ binary-jump drop ] curry
+ first2 [ binary-jump ] curry
"if-intrinsic" set-word-prop
] each
\ fixnum-mod [
- drop
! This is not clever. Because of x86, %fixnum-mod is
! hard-coded to put its output in vreg 2, which happends to
! be EDX there.
{ { 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
\ fixnum/mod [
- drop
! See the remark on fixnum-mod for vreg usage
{ { 0 "x" } { 1 "y" } } { "quo" "rem" } [
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 [
- drop
{ { any-reg "x" } } { "x" } [
- "x" %get dup %fixnum-bitnot ,
+ "x" get dup %fixnum-bitnot ,
] with-template
] "intrinsic" set-word-prop
M: #call linearize* ( node -- next )
dup if-intrinsic [
- >r <label> 2dup r> call
+ >r <label> dup r> call
>r node-successor r> linearize-if node-successor
] [
dup intrinsic
- [ call iterate-next ] [ node-param linearize-call ] if*
+ [ call iterate-next ] [ node-param linearize-call ] ?if
] if* ;
M: #call-label linearize* ( node -- next )
node-param renamed-label linearize-call ;
-SYMBOL: live-d
-SYMBOL: live-r
-
-: value-dropped? ( value -- ? )
- dup live-d get member? not
- swap live-r get member? not and ;
-
-: shuffle-in-template ( values -- template )
- [
- dup value-dropped? [ drop f ] when any-reg swap 2array
- ] map ;
-
-: shuffle-out-template ( instack outstack -- stack )
- #! Avoid storing a value into its former position.
- dup length [
- pick ?nth dupd ( eq? ) 2drop f [ <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
- swap shuffle-in-r shuffle-in-template template-inputs
- live-d get live-r get template-outputs ;
-
-M: #shuffle linearize* ( #shuffle -- )
- node-shuffle linearize-shuffle iterate-next ;
-
: ensure-vregs ( n -- )
sufficient-vregs?
[ end-basic-block compute-free-vregs ] unless ;
M: #if linearize* ( node -- next )
{ { 0 "flag" } } { } [
end-basic-block
- <label> dup "flag" %get %jump-t ,
+ <label> dup "flag" get %jump-t ,
] with-template linearize-if ;
: dispatch-head ( node -- label/node )
#! Output the jump table insn and return a list of
#! label/branch pairs.
{ { 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 -- )
--- /dev/null
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler
+USING: arrays generic inference io kernel math
+namespaces prettyprint sequences vectors words ;
+
+: phantom-shuffle-input ( n phantom -- seq )
+ 2dup length <= [
+ cut-phantom
+ ] [
+ [ phantom-locs ] keep [ length swap tail-slice ] keep
+ append
+ ] if ;
+
+: phantom-shuffle-inputs ( shuffle -- locs locs )
+ dup shuffle-in-d length phantom-d get phantom-shuffle-input
+ swap shuffle-in-r length phantom-r get phantom-shuffle-input ;
+
+: adjust-shuffle ( shuffle -- )
+ dup shuffle-in-d length neg phantom-d get adjust-phantom
+ shuffle-in-r length neg phantom-r get adjust-phantom ;
+
+: sufficient-shuffle-vregs? ( shuffle -- ? )
+ dup shuffle-in-d length phantom-d get length - 0 max
+ over shuffle-in-r length phantom-r get length - 0 max +
+ free-vregs get length <= ;
+
+: phantom-shuffle ( shuffle -- )
+ ! compute-free-vregs sufficient-shuffle-vregs? [
+ end-basic-block compute-free-vregs
+ ! ] unless
+ [ phantom-shuffle-inputs ] keep
+ [ shuffle* ] keep adjust-shuffle
+ (template-outputs) ;
+
+M: #shuffle linearize* ( #shuffle -- )
+ node-shuffle phantom-shuffle iterate-next ;
USING: arrays generic inference io kernel math
namespaces prettyprint sequences vectors words ;
+SYMBOL: free-vregs
+
! A data stack location.
TUPLE: ds-loc n ;
! 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 )
: load-literal ( obj dest -- )
over immediate? [ %immediate ] [ %indirect ] if , ;
-: vreg>stack ( value loc -- )
- {
- { [ over not ] [ 2drop ] }
- { [ over clean? ] [ 2drop ] }
- { [ t ] [ %replace , ] }
- } cond ;
+: finalize-heights ( -- )
+ phantom-d get finalize-height
+ phantom-r get finalize-height ;
+
+: alloc-reg ( -- n ) free-vregs get pop ;
-: vregs>stack ( phantom -- )
- dup dup phantom-locs* [ vreg>stack ] 2each
- 0 swap set-length ;
+: lazy-load ( value loc -- value )
+ over ds-loc? pick cs-loc? or [
+ dupd = [
+ drop f
+ ] [
+ >r alloc-reg <vreg> dup r> %peek ,
+ ] if
+ ] [
+ drop
+ ] if ;
-: finalize-phantom ( phantom -- )
- dup finalize-height vregs>stack ;
+: vregs>stack ( values locs -- )
+ [ over [ %replace , ] [ 2drop ] if ] 2each ;
+
+: finalize-contents ( -- )
+ phantom-d get phantom-r get 2dup
+ [ dup phantom-locs* [ [ lazy-load ] 2map ] keep ] 2apply
+ vregs>stack vregs>stack
+ [ 0 swap set-length ] 2apply ;
: end-basic-block ( -- )
- phantom-d get finalize-phantom
- phantom-r get finalize-phantom ;
+ finalize-contents finalize-heights ;
: stack>vreg ( vreg loc -- operand )
- over [ >r <vreg> dup r> %peek , ] [ 2drop f ] if ;
+ >r <vreg> dup r> %peek , ;
SYMBOL: any-reg
-SYMBOL: free-vregs
+: used-vregs ( -- seq )
+ phantom-d get phantom-r get append
+ [ vreg? ] subset [ vreg-n ] map ;
: compute-free-vregs ( -- )
- phantom-d get phantom-r get append
- [ vreg? ] subset [ vreg-n ] map
- vregs length reverse diff
+ used-vregs vregs length reverse diff
>vector free-vregs set ;
: requested-vregs ( template -- n )
[ requested-vregs ] 2apply + ;
: alloc-regs ( template -- template )
- free-vregs get swap [
- dup any-reg eq? [ drop pop ] [ nip ] if
- ] map-with ;
+ [ dup any-reg eq? [ drop alloc-reg ] when ] map ;
: alloc-reg# ( n -- regs )
free-vregs [ cut ] change ;
-: ?clean ( obj -- obj )
- dup clean? [ delegate ] when ;
-
-: %get ( obj -- value )
- get ?clean dup value? [ value-literal ] when ;
-
-: phantom-vregs ( values template -- ) [ second set ] 2each ;
+: phantom-vregs ( values template -- )
+ [ >r f lazy-load r> second set ] 2each ;
: stack>vregs ( phantom template -- values )
[
] 2keep length neg swap adjust-phantom ;
: compatible-values? ( value template -- ? )
- >r ?clean r> {
+ {
+ { [ over ds-loc? ] [ 2drop t ] }
+ { [ over cs-loc? ] [ 2drop t ] }
{ [ dup not ] [ 2drop t ] }
{ [ over not ] [ 2drop f ] }
{ [ dup any-reg eq? ] [ 2drop t ] }
} cond ;
: template-match? ( template phantom -- ? )
- 2dup [ length ] 2apply <= [
- >r dup length r> tail-slice*
- t [ swap first compatible-values? and ] 2reduce
- ] [
- 2drop f
- ] if ;
+ [ reverse-slice ] 2apply
+ t [ swap first compatible-values? and ] 2reduce ;
: templates-match? ( template template -- ? )
- 2dup template-vreg# sufficient-vregs? [
- phantom-r get template-match?
- >r phantom-d get template-match? r> and
+ phantom-r get template-match?
+ >r phantom-d get template-match? r> and ;
+
+: split-template ( template phantom -- slow fast )
+ over length over length <= [
+ drop { } swap
] [
- 2drop f
+ length swap cut*
] if ;
-: optimized-input ( template phantom -- )
+: split-templates ( template template -- slow slow fast fast )
+ >r phantom-d get split-template r>
+ phantom-r get split-template swapd ;
+
+: match-templates ( template template -- slow slow fast fast )
+ 2dup templates-match? [ split-templates ] [ { } { } ] if ;
+
+: (fast-input) ( template phantom -- )
over length neg over adjust-phantom
- over length over cut-phantom
- >r dup empty? [ drop ] [ vregs>stack ] if r>
+ over length swap cut-phantom
swap phantom-vregs ;
-: template-input ( template phantom -- )
+: fast-input ( template template -- )
+ phantom-r get (fast-input)
+ phantom-d get (fast-input) ;
+
+: (slow-input) ( template phantom -- )
swap [ stack>vregs ] keep phantom-vregs ;
+: slow-input ( template template -- )
+ phantom-r get (slow-input)
+ phantom-d get (slow-input) ;
+
+: adjust-free-vregs ( -- )
+ used-vregs free-vregs [ diff ] change ;
+
: template-inputs ( template template -- )
- 2dup templates-match? [
- phantom-r get optimized-input
- phantom-d get optimized-input
- compute-free-vregs
- ] [
- phantom-r get vregs>stack
- phantom-d get vregs>stack
- compute-free-vregs
- phantom-r get template-input
- phantom-d get template-input
- ] if ;
+ compute-free-vregs
+ match-templates fast-input
+ adjust-free-vregs
+ finalize-contents
+ slow-input ;
: drop-phantom ( -- )
end-basic-block -1 phantom-d get adjust-phantom ;
-: prep-output ( value -- value )
- dup clean? [ delegate ] [ get ?clean ] if ;
-
: phantom-append ( seq stack -- )
over length over adjust-phantom swap nappend ;
-: template-output ( seq stack -- )
- >r [ prep-output ] map r> phantom-append ;
-
-: trace-outputs ( stack stack -- )
- "==== Template output:" print [ . ] 2apply ;
+: (template-outputs) ( seq stack -- )
+ phantom-r get phantom-append phantom-d get phantom-append ;
: template-outputs ( stack stack -- )
- ! 2dup trace-outputs
- phantom-r get template-output
- phantom-d get template-output ;
+ [ [ get ] map ] 2apply (template-outputs) ;
: with-template ( in out quot -- )
swap >r >r { } template-inputs
projects / factor.git / commitdiff