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

Clean up generator.registers a bit

release
Slava Pestov 2007-09-27 17:30:34 -04:00
parent ab89a3b902
commit 480e6a8b2b
4 changed files with 114 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
core/alien/compiler/compiler.factor
View File

@ -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 >= ;

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

@ -8,7 +8,7 @@ namespaces sequences words kernel math effects ;
[ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test
[ ] [ 0 <int-vreg> phantom-d get phantom-push ] unit-test
[ ] [ 0 <int-vreg> phantom-push ] unit-test
[ ] [ compute-free-vregs ] unit-test
@ -17,7 +17,7 @@ namespaces sequences words kernel math effects ;
[ f ] [
[
copy-templates
1 <int-vreg> phantom-d get phantom-push
1 <int-vreg> phantom-push
compute-free-vregs
1 <int-vreg> T{ int-regs } free-vregs member?
] with-scope

14
core/generator/generator.factor
View File

@ -228,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 -- )
[
@ -281,26 +281,20 @@ M: #call-label generate-node node-param generate-call ;
UNION: immediate fixnum POSTPONE: f ;
M: #push generate-node
node-out-d phantom-d get phantom-append iterate-next ;
node-out-d [ phantom-push ] each iterate-next ;
! #shuffle
: phantom-shuffle ( shuffle -- )
[ effect-in length phantom-d get phantom-input ] keep
shuffle* phantom-d get phantom-append ;
M: #shuffle generate-node
node-shuffle phantom-shuffle iterate-next ;
M: #>r generate-node
node-in-d length
phantom-d get phantom-input
phantom-r get phantom-append
phantom->r
iterate-next ;
M: #r> generate-node
node-out-d length
phantom-r get phantom-input
phantom-d get phantom-append
phantom-r>
iterate-next ;
! #return

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

@ -2,10 +2,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes classes.private combinators
cpu.architecture generator.fixup generic hashtables
inference.dataflow kernel kernel.private layouts math memory
namespaces quotations sequences system vectors words ;
inference.dataflow inference.stack kernel kernel.private layouts
math memory namespaces quotations sequences system vectors words
effects ;
IN: generator.registers
SYMBOL: +input+
SYMBOL: +output+
SYMBOL: +scratch+
SYMBOL: +clobber+
SYMBOL: known-tag
! A scratch register for computations
TUPLE: vreg n ;
@ -24,45 +31,8 @@ TUPLE: temp-reg ;
: temp-reg T{ temp-reg T{ int-regs } } ;
: %move ( dst src -- )
2dup = [
2drop
] [
2dup [ delegate class ] 2apply 2array {
{ { int-regs int-regs } [ %move-int>int ] }
{ { float-regs int-regs } [ %move-int>float ] }
{ { int-regs float-regs } [ %move-float>int ] }
} case
] if ;
GENERIC: reg-size ( register-class -- n )
GENERIC: inc-reg-class ( register-class -- )
M: int-regs reg-size drop cell ;
: (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 reg-size float-regs-size ;
M: float-regs inc-reg-class
dup (inc-reg-class)
fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
M: vreg v>operand dup vreg-n swap vregs nth ;
: reg-spec>class ( spec -- class )
float eq?
T{ float-regs f 8 } T{ int-regs } ? ;
SYMBOL: phantom-d
SYMBOL: phantom-r
! A data stack location.
TUPLE: ds-loc n ;
@ -73,10 +43,18 @@ TUPLE: rs-loc n ;
C: <rs-loc> rs-loc
<PRIVATE
UNION: loc ds-loc rs-loc ;
! A compile-time stack
TUPLE: phantom-stack height ;
GENERIC: finalize-height ( stack -- )
SYMBOL: phantom-d
SYMBOL: phantom-r
: <phantom-stack> ( class -- stack )
>r
V{ } clone 0
@ -84,10 +62,6 @@ TUPLE: phantom-stack height ;
phantom-stack construct
r> construct-delegate ;
GENERIC: finalize-height ( stack -- )
GENERIC: <loc> ( n stack -- loc )
: (loc)
#! Utility for methods on <loc>
phantom-stack-height - ;
@ -102,6 +76,8 @@ GENERIC: <loc> ( n stack -- loc )
0
] keep set-phantom-stack-height ; inline
GENERIC: <loc> ( n stack -- loc )
TUPLE: phantom-datastack ;
: <phantom-datastack> phantom-datastack <phantom-stack> ;
@ -137,17 +113,14 @@ M: phantom-retainstack finalize-height
: adjust-phantom ( n phantom -- )
[ phantom-stack-height + ] keep set-phantom-stack-height ;
: phantom-push ( obj stack -- )
1 over adjust-phantom push ;
: phantom-append ( seq stack -- )
over length over adjust-phantom push-all ;
GENERIC: cut-phantom ( n phantom -- seq )
M: phantom-stack cut-phantom
[ delegate cut* swap ] keep set-delegate ;
: phantom-append ( seq stack -- )
over length over adjust-phantom push-all ;
: phantom-input ( n phantom -- seq )
[
2dup length <= [
@ -160,6 +133,26 @@ M: phantom-stack cut-phantom
] if
] 2keep >r neg r> adjust-phantom ;
PRIVATE>
: phantom-push ( obj -- )
1 phantom-d get adjust-phantom
phantom-d get push ;
: phantom-shuffle ( shuffle -- )
[ effect-in length phantom-d get phantom-input ] keep
shuffle* phantom-d get phantom-append ;
: phantom->r ( n -- )
phantom-d get phantom-input
phantom-r get phantom-append ;
: phantom-r> ( n -- )
phantom-r get phantom-input
phantom-d get phantom-append ;
<PRIVATE
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
: each-phantom ( quot -- ) phantoms rot 2apply ; inline
@ -195,10 +188,6 @@ UNION: pseudo loc value ;
! are guaranteed to be in the nursery
SYMBOL: fresh-objects
: fresh-object ( obj -- ) fresh-objects get push ;
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
! Computing free registers and initializing allocator
: free-vregs ( reg-class -- seq )
#! Free vregs in a given register class
@ -217,25 +206,25 @@ SYMBOL: fresh-objects
[ 2dup (compute-free-vregs) ] H{ } map>assoc \ free-vregs set
drop ;
: init-templates ( -- )
#! Initialize register allocator.
V{ } clone fresh-objects set
<phantom-datastack> phantom-d set
<phantom-retainstack> phantom-r set
compute-free-vregs ;
: copy-templates ( -- )
#! Copies register allocator state, used when compiling
#! branches.
fresh-objects [ clone ] change
phantom-d [ clone ] change
phantom-r [ clone ] change
compute-free-vregs ;
: reg-spec>class ( spec -- class )
float eq?
T{ float-regs f 8 } T{ int-regs } ? ;
! Copying vregs to stacks
: alloc-vreg ( spec -- vreg )
reg-spec>class free-vregs pop ;
: %move ( dst src -- )
2dup = [
2drop
] [
2dup [ delegate class ] 2apply 2array {
{ { int-regs int-regs } [ %move-int>int ] }
{ { float-regs int-regs } [ %move-int>float ] }
{ { int-regs float-regs } [ %move-float>int ] }
} case
] if ;
: vreg>vreg ( vreg spec -- vreg )
alloc-vreg dup rot %move ;
@ -382,13 +371,6 @@ M: object template-rhs ;
%prepare-alien-invoke
"simple_gc" f %alien-invoke ;
: end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the
#! in-memory data and retain stacks are up to date with
#! respect to the compiler's current picture.
finalize-contents finalize-heights
fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
! Loading stacks to vregs
: free-vregs# ( -- int# float# )
T{ int-regs } T{ float-regs f 8 }
@ -433,11 +415,6 @@ M: object template-rhs ;
dup length phantom-d get phantom-input swap lazy-load
] if ;
SYMBOL: +input+
SYMBOL: +output+
SYMBOL: +scratch+
SYMBOL: +clobber+
: output-vregs ( -- seq seq )
+output+ +clobber+ [ get [ get ] map ] 2apply ;
@ -489,11 +466,6 @@ SYMBOL: +clobber+
: template-outputs ( -- )
+output+ get [ get ] map phantom-d get phantom-append ;
: with-template ( quot hash -- )
clone [ template-inputs call template-outputs ] bind
compute-free-vregs ;
inline
: value-matches? ( value spec -- ? )
#! If the spec is a quotation and the value is a literal
#! fixnum, see if the quotation yields true when applied
@ -519,8 +491,6 @@ SYMBOL: +clobber+
dup length 1 = [ first tag-number ] [ drop f ] if
] if ;
SYMBOL: known-tag
: class-match? ( actual expected -- ? )
{
{ f [ drop t ] }
@ -545,6 +515,39 @@ SYMBOL: known-tag
#! Depends on node@
[ second template-matches? ] find nip ;
PRIVATE>
: end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the
#! in-memory data and retain stacks are up to date with
#! respect to the compiler's current picture.
finalize-contents finalize-heights
fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
: with-template ( quot hash -- )
clone [ template-inputs call template-outputs ] bind
compute-free-vregs ;
inline
: fresh-object ( obj -- ) fresh-objects get push ;
: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
: init-templates ( -- )
#! Initialize register allocator.
V{ } clone fresh-objects set
<phantom-datastack> phantom-d set
<phantom-retainstack> phantom-r set
compute-free-vregs ;
: copy-templates ( -- )
#! Copies register allocator state, used when compiling
#! branches.
fresh-objects [ clone ] change
phantom-d [ clone ] change
phantom-r [ clone ] change
compute-free-vregs ;
: find-template ( templates -- pair/f )
#! Pair has shape { quot hash }
#! Depends on node@