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

Convert compiler to use inheritance

db4
Slava Pestov 2008-04-04 05:44:45 -05:00
parent 9e227d394e
commit 48a6baedcd
2 changed files with 70 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/compiler/tests/templates-early.factor
View File

@ -173,12 +173,12 @@ SYMBOL: template-chosen
] unit-test ] unit-test
[ ] [ [ ] [
2 phantom-d get phantom-input 2 phantom-datastack get phantom-input
[ { { f "a" } { f "b" } } lazy-load ] { } make drop [ { { f "a" } { f "b" } } lazy-load ] { } make drop
] unit-test ] unit-test
[ t ] [ [ t ] [
phantom-d get [ cached? ] all? phantom-datastack get [ cached? ] all?
] unit-test ] unit-test
! >r ! >r

142
core/generator/registers/registers.factor
View File

@ -230,48 +230,44 @@ INSTANCE: constant value
} case ; } case ;
! A compile-time stack ! A compile-time stack
TUPLE: phantom-stack height ; TUPLE: phantom-stack height stack ;
M: phantom-stack clone
call-next-method [ clone ] change-stack ;
GENERIC: finalize-height ( stack -- ) GENERIC: finalize-height ( stack -- )
SYMBOL: phantom-d : construct-phantom-stack ( class -- stack )
SYMBOL: phantom-r >r 0 V{ } clone r> construct-boa ; inline
: <phantom-stack> ( class -- stack )
>r
V{ } clone 0
{ set-delegate set-phantom-stack-height }
phantom-stack construct
r> construct-delegate ;
: (loc) : (loc)
#! Utility for methods on <loc> #! Utility for methods on <loc>
phantom-stack-height - ; height>> - ;
: (finalize-height) ( stack word -- ) : (finalize-height) ( stack word -- )
#! We consolidate multiple stack height changes until the #! We consolidate multiple stack height changes until the
#! last moment, and we emit the final height changing #! last moment, and we emit the final height changing
#! instruction here. #! instruction here.
swap [ [
phantom-stack-height over zero? [ 2drop ] [ execute ] if 0
dup zero? [ 2drop ] [ swap execute ] if ] curry change-height drop ; inline
0
] keep set-phantom-stack-height ; inline
GENERIC: <loc> ( n stack -- loc ) GENERIC: <loc> ( n stack -- loc )
TUPLE: phantom-datastack ; TUPLE: phantom-datastack < phantom-stack ;
: <phantom-datastack> phantom-datastack <phantom-stack> ; : <phantom-datastack> ( -- stack )
phantom-datastack construct-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ; M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ; \ %inc-d (finalize-height) ;
TUPLE: phantom-retainstack ; TUPLE: phantom-retainstack < phantom-stack ;
: <phantom-retainstack> phantom-retainstack <phantom-stack> ; : <phantom-retainstack> ( -- stack )
phantom-retainstack construct-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ; M: phantom-retainstack <loc> (loc) <rs-loc> ;
@ -283,34 +279,33 @@ M: phantom-retainstack finalize-height
>r <reversed> r> [ <loc> ] curry map ; >r <reversed> r> [ <loc> ] curry map ;
: phantom-locs* ( phantom -- locs ) : phantom-locs* ( phantom -- locs )
dup length swap phantom-locs ; [ stack>> length ] keep phantom-locs ;
: phantoms ( -- phantom phantom )
phantom-datastack get phantom-retainstack get ;
: (each-loc) ( phantom quot -- ) : (each-loc) ( phantom quot -- )
>r dup phantom-locs* swap r> 2each ; inline >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
: each-loc ( quot -- ) : each-loc ( quot -- )
>r phantom-d get r> phantom-r get over phantoms 2array swap [ (each-loc) ] curry each ; inline
>r >r (each-loc) r> r> (each-loc) ; inline
: adjust-phantom ( n phantom -- ) : adjust-phantom ( n phantom -- )
[ phantom-stack-height + ] keep set-phantom-stack-height ; swap [ + ] curry change-height drop ;
GENERIC: cut-phantom ( n phantom -- seq ) : cut-phantom ( n phantom -- seq )
swap [ cut* swap ] curry change-stack drop ;
M: phantom-stack cut-phantom
[ delegate swap cut* swap ] keep set-delegate ;
: phantom-append ( seq stack -- ) : phantom-append ( seq stack -- )
over length over adjust-phantom push-all ; over length over adjust-phantom stack>> push-all ;
: add-locs ( n phantom -- ) : add-locs ( n phantom -- )
2dup length <= [ 2dup stack>> length <= [
2drop 2drop
] [ ] [
[ phantom-locs ] keep [ phantom-locs ] keep
[ length head-slice* ] keep [ stack>> length head-slice* ] keep
[ append >vector ] keep [ append >vector ] change-stack drop
delegate set-delegate
] if ; ] if ;
: phantom-input ( n phantom -- seq ) : phantom-input ( n phantom -- seq )
@ -318,18 +313,16 @@ M: phantom-stack cut-phantom
2dup cut-phantom 2dup cut-phantom
>r >r neg r> adjust-phantom r> ; >r >r neg r> adjust-phantom r> ;
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
: each-phantom ( quot -- ) phantoms rot bi@ ; inline : each-phantom ( quot -- ) phantoms rot bi@ ; inline
: finalize-heights ( -- ) [ finalize-height ] each-phantom ; : finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: live-vregs ( -- seq ) : live-vregs ( -- seq )
[ [ [ live-vregs* ] each ] each-phantom ] { } make ; [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
: (live-locs) ( phantom -- seq ) : (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved #! Discard locs which haven't moved
dup phantom-locs* swap 2array flip [ phantom-locs* ] [ stack>> ] bi 2array flip
[ live-loc? ] assoc-subset [ live-loc? ] assoc-subset
values ; values ;
@ -349,7 +342,7 @@ SYMBOL: fresh-objects
\ free-vregs get at ; \ free-vregs get at ;
: alloc-vreg ( spec -- reg ) : alloc-vreg ( spec -- reg )
dup reg-spec>class free-vregs pop swap { [ reg-spec>class free-vregs pop ] keep {
{ f [ <tagged> ] } { f [ <tagged> ] }
{ unboxed-alien [ <unboxed-alien> ] } { unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] } { unboxed-byte-array [ <unboxed-byte-array> ] }
@ -375,8 +368,8 @@ SYMBOL: fresh-objects
} cond ; } cond ;
: alloc-vreg-for ( value spec -- vreg ) : alloc-vreg-for ( value spec -- vreg )
swap operand-class swap alloc-vreg alloc-vreg swap operand-class
dup tagged? [ tuck set-tagged-class ] [ nip ] if ; over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load) M: value (lazy-load)
2dup allocation [ 2dup allocation [
@ -419,7 +412,7 @@ M: loc lazy-store
#! When shuffling more values than can fit in registers, we #! When shuffling more values than can fit in registers, we
#! need to find an area on the data stack which isn't in #! need to find an area on the data stack which isn't in
#! use. #! use.
dup phantom-stack-height neg [ minimal-ds-loc* ] reduce ; [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
: find-tmp-loc ( -- n ) : find-tmp-loc ( -- n )
#! Find an area of the data stack which is not referenced #! Find an area of the data stack which is not referenced
@ -463,13 +456,13 @@ M: loc lazy-store
#! Kill register assignments but preserve constants and #! Kill register assignments but preserve constants and
#! class information. #! class information.
dup phantom-locs* dup phantom-locs*
over [ over stack>> [
dup constant? [ nip ] [ dup constant? [ nip ] [
operand-class over set-operand-class operand-class over set-operand-class
] if ] if
] 2map ] 2map
over delete-all over stack>> delete-all
swap push-all ; swap stack>> push-all ;
: reset-phantoms ( -- ) : reset-phantoms ( -- )
[ reset-phantom ] each-phantom ; [ reset-phantom ] each-phantom ;
@ -488,6 +481,7 @@ M: loc lazy-store
>r int-regs free-vregs length <= r> and ; >r int-regs free-vregs length <= r> and ;
: phantom&spec ( phantom spec -- phantom' spec' ) : phantom&spec ( phantom spec -- phantom' spec' )
>r stack>> r>
[ length f pad-left ] keep [ length f pad-left ] keep
[ <reversed> ] bi@ ; inline [ <reversed> ] bi@ ; inline
@ -505,7 +499,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- ) : substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map [ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable [ substitute-vreg? ] assoc-subset >hashtable
[ substitute-here ] curry each-phantom ; [ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- ) : set-operand ( value var -- )
>r dup constant? [ constant-value ] when r> set ; >r dup constant? [ constant-value ] when r> set ;
@ -517,14 +511,15 @@ M: loc lazy-store
substitute-vregs ; substitute-vregs ;
: load-inputs ( -- ) : load-inputs ( -- )
+input+ get dup length phantom-d get phantom-input +input+ get
swap lazy-load ; [ length phantom-datastack get phantom-input ] keep
lazy-load ;
: output-vregs ( -- seq seq ) : output-vregs ( -- seq seq )
+output+ +clobber+ [ get [ get ] map ] bi@ ; +output+ +clobber+ [ get [ get ] map ] bi@ ;
: clash? ( seq -- ? ) : clash? ( seq -- ? )
phantoms append [ phantoms [ stack>> ] bi@ append [
dup cached? [ cached-vreg ] when swap member? dup cached? [ cached-vreg ] when swap member?
] with contains? ; ] with contains? ;
@ -542,15 +537,14 @@ M: loc lazy-store
[ first reg-spec>class ] map count-vregs ; [ first reg-spec>class ] map count-vregs ;
: guess-vregs ( dinput rinput scratch -- int# float# ) : guess-vregs ( dinput rinput scratch -- int# float# )
H{ [
{ int-regs 0 } 0 int-regs set
{ double-float-regs 0 } 0 double-float-regs set
} clone [
count-scratch-regs count-scratch-regs
phantom-r get swap count-input-vregs phantom-retainstack get swap count-input-vregs
phantom-d get swap count-input-vregs phantom-datastack get swap count-input-vregs
int-regs get double-float-regs get int-regs get double-float-regs get
] bind ; ] with-scope ;
: alloc-scratch ( -- ) : alloc-scratch ( -- )
+scratch+ get [ >r alloc-vreg r> set ] assoc-each ; +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
@ -567,7 +561,7 @@ M: loc lazy-store
outputs-clash? [ finalize-contents ] when ; outputs-clash? [ finalize-contents ] when ;
: template-outputs ( -- ) : template-outputs ( -- )
+output+ get [ get ] map phantom-d get phantom-append ; +output+ get [ get ] map phantom-datastack get phantom-append ;
: value-matches? ( value spec -- ? ) : value-matches? ( value spec -- ? )
#! If the spec is a quotation and the value is a literal #! If the spec is a quotation and the value is a literal
@ -597,7 +591,7 @@ M: loc lazy-store
>r >r operand-class 2 r> ?nth class-matches? r> and ; >r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( spec -- ? ) : template-matches? ( spec -- ? )
phantom-d get +input+ rot at phantom-datastack get +input+ rot at
[ spec-matches? ] phantom&spec-agree? ; [ spec-matches? ] phantom&spec-agree? ;
: ensure-template-vregs ( -- ) : ensure-template-vregs ( -- )
@ -606,14 +600,14 @@ M: loc lazy-store
] unless ; ] unless ;
: clear-phantoms ( -- ) : clear-phantoms ( -- )
[ delete-all ] each-phantom ; [ stack>> delete-all ] each-phantom ;
PRIVATE> PRIVATE>
: set-operand-classes ( classes -- ) : set-operand-classes ( classes -- )
phantom-d get phantom-datastack get
over length over add-locs over length over add-locs
[ set-operand-class ] 2reverse-each ; stack>> [ set-operand-class ] 2reverse-each ;
: end-basic-block ( -- ) : end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the #! Commit all deferred stacking shuffling, and ensure the
@ -622,7 +616,7 @@ PRIVATE>
finalize-contents finalize-contents
clear-phantoms clear-phantoms
finalize-heights finalize-heights
fresh-objects get dup empty? swap delete-all [ %gc ] unless ; fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
: with-template ( quot hash -- ) : with-template ( quot hash -- )
clone [ clone [
@ -642,16 +636,16 @@ PRIVATE>
: init-templates ( -- ) : init-templates ( -- )
#! Initialize register allocator. #! Initialize register allocator.
V{ } clone fresh-objects set V{ } clone fresh-objects set
<phantom-datastack> phantom-d set <phantom-datastack> phantom-datastack set
<phantom-retainstack> phantom-r set <phantom-retainstack> phantom-retainstack set
compute-free-vregs ; compute-free-vregs ;
: copy-templates ( -- ) : copy-templates ( -- )
#! Copies register allocator state, used when compiling #! Copies register allocator state, used when compiling
#! branches. #! branches.
fresh-objects [ clone ] change fresh-objects [ clone ] change
phantom-d [ clone ] change phantom-datastack [ clone ] change
phantom-r [ clone ] change phantom-retainstack [ clone ] change
compute-free-vregs ; compute-free-vregs ;
: find-template ( templates -- pair/f ) : find-template ( templates -- pair/f )
@ -667,17 +661,17 @@ UNION: immediate fixnum POSTPONE: f ;
operand-class immediate class< ; operand-class immediate class< ;
: phantom-push ( obj -- ) : phantom-push ( obj -- )
1 phantom-d get adjust-phantom 1 phantom-datastack get adjust-phantom
phantom-d get push ; phantom-datastack get stack>> push ;
: phantom-shuffle ( shuffle -- ) : phantom-shuffle ( shuffle -- )
[ effect-in length phantom-d get phantom-input ] keep [ effect-in length phantom-datastack get phantom-input ] keep
shuffle* phantom-d get phantom-append ; shuffle* phantom-datastack get phantom-append ;
: phantom->r ( n -- ) : phantom->r ( n -- )
phantom-d get phantom-input phantom-datastack get phantom-input
phantom-r get phantom-append ; phantom-retainstack get phantom-append ;
: phantom-r> ( n -- ) : phantom-r> ( n -- )
phantom-r get phantom-input phantom-retainstack get phantom-input
phantom-d get phantom-append ; phantom-datastack get phantom-append ;