steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Templates cleanups

release
slava 2006-05-09 17:17:03 +00:00
parent 3c92baf8ed
commit 3b6cccb620
1 changed files with 24 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
library/compiler/generator/templates.factor
View File

@ -16,14 +16,12 @@ namespaces prettyprint sequences vectors words ;
: reg-spec>class ( spec -- class ) : reg-spec>class ( spec -- class )
float eq? T{ float-regs f 8 } T{ int-regs } ? ; float eq? T{ float-regs f 8 } T{ int-regs } ? ;
: alloc-vregs ( template -- template ) : spec>vreg ( spec -- vreg )
[ dup integer? [
dup integer? [ <int-vreg> dup take-reg
<int-vreg> dup take-reg ] [
] [ reg-spec>class alloc-reg
reg-spec>class alloc-reg ] if ;
] if
] map ;
! A data stack location. ! A data stack location.
TUPLE: ds-loc n ; TUPLE: ds-loc n ;
@ -175,26 +173,17 @@ SYMBOL: phantom-r
compute-free-vregs free-vregs* swapd <= >r <= r> and compute-free-vregs free-vregs* swapd <= >r <= r> and
[ finalize-contents compute-free-vregs ] unless ; [ finalize-contents compute-free-vregs ] unless ;
: spec>vreg ( spec -- vreg ) : (lazy-load) ( spec value -- value )
dup integer? [ <int-vreg> ] [ reg-spec>class alloc-reg ] if ; {
{ [ dup loc? ] [ >r spec>vreg dup r> %peek ] }
{ [ dup [ float-regs? ] is? ] [ nip ] }
{ [ over float eq? ] [ >r spec>vreg dup r> %move ] }
{ [ t ] [ nip ] }
} cond ;
: (lazy-load) ( value spec -- value ) : lazy-load ( values template -- )
spec>vreg [ dup length neg phantom-d get adjust-phantom
swap { [ first2 >r swap (lazy-load) r> set ] 2each ;
{ [ dup loc? ] [ %peek ] }
{ [ dup vreg? ] [ %move ] }
{ [ t ] [ 2drop ] }
} cond
] keep ;
: lazy-load ( values template -- template )
[ first2 >r (lazy-load) r> 2array ] 2map ;
: stack>vregs ( phantom template -- values )
[
[ first ] map alloc-vregs dup length rot phantom-locs
[ dupd %peek ] 2map
] 2keep length neg swap adjust-phantom ;
: compatible-vreg? ( n vreg -- ? ) : compatible-vreg? ( n vreg -- ? )
dup [ int-regs? ] is? [ vreg-n = ] [ 2drop f ] if ; dup [ int-regs? ] is? [ vreg-n = ] [ 2drop f ] if ;
@ -219,10 +208,7 @@ SYMBOL: phantom-r
[ split-template ] [ drop { } ] if ; [ split-template ] [ drop { } ] if ;
: fast-input ( template -- ) : fast-input ( template -- )
phantom-d get phantom-d get over length swap cut-phantom swap lazy-load ;
over length neg over adjust-phantom
over length swap cut-phantom
swap lazy-load [ first2 set ] each ;
: phantom-push ( obj stack -- ) : phantom-push ( obj stack -- )
1 over adjust-phantom push ; 1 over adjust-phantom push ;
@ -253,16 +239,13 @@ SYMBOL: +clobber
output-vregs append phantoms append output-vregs append phantoms append
[ swap member? ] contains-with? ; [ swap member? ] contains-with? ;
: phantom-vregs ( values template -- ) [ second set ] 2each ;
: slow-input ( template -- ) : slow-input ( template -- )
! Are we loading stuff from the stack? Then flush out #! Are we loading stuff from the stack? Then flush out
! remaining vregs, not slurped in by fast-input. #! remaining vregs, not slurped in by fast-input.
dup empty? [ finalize-contents ] unless #! Do the outputs clash with vregs on the phantom stacks?
! Do the outputs clash with vregs on the phantom stacks? #! Then we must flush them first.
! Then we must flush them first. dup empty? not outputs-clash? or [ finalize-contents ] when
outputs-clash? [ finalize-contents ] when [ length phantom-d get phantom-locs ] keep lazy-load ;
phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
: requested-vregs ( template -- int# float# ) : requested-vregs ( template -- int# float# )
dup length swap [ float eq? ] subset length [ - ] keep ; dup length swap [ float eq? ] subset length [ - ] keep ;
@ -272,8 +255,7 @@ SYMBOL: +clobber
+scratch get [ first ] map requested-vregs >r + r> ; +scratch get [ first ] map requested-vregs >r + r> ;
: alloc-scratch ( -- ) : alloc-scratch ( -- )
+scratch get +scratch get [ first2 >r spec>vreg r> set ] each ;
[ [ first ] map alloc-vregs ] keep phantom-vregs ;
: template-inputs ( -- ) : template-inputs ( -- )
! Ensure we have enough to hold any new stack elements we ! Ensure we have enough to hold any new stack elements we