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

Simplifying vregs work in progress

db4
Slava Pestov 2008-10-17 15:35:04 -05:00
parent fe2c20882a
commit 239578353f
5 changed files with 80 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/cfg/builder/builder.factor
View File

@ -253,7 +253,7 @@ M: #dispatch emit-node
type tagged boa phantom-push ; type tagged boa phantom-push ;
: emit-write-barrier ( -- ) : emit-write-barrier ( -- )
phantom-pop dup >vreg fresh-object? [ drop ] [ phantom-pop dup fresh-object? [ drop ] [
int-regs next-vreg int-regs next-vreg
int-regs next-vreg int-regs next-vreg
##write-barrier ##write-barrier

60
basis/compiler/cfg/instructions/instructions.factor
View File

@ -1,21 +1,21 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces USING: assocs accessors arrays kernel sequences namespaces words
math compiler.cfg.registers compiler.cfg.instructions.syntax ; math compiler.cfg.registers compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions IN: compiler.cfg.instructions
! Virtual CPU instructions, used by CFG and machine IRs ! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: ##cond-branch < insn src ; TUPLE: ##cond-branch < insn { src vreg } ;
TUPLE: ##unary < insn dst src ; TUPLE: ##unary < insn { dst vreg } { src vreg } ;
TUPLE: ##nullary < insn dst ; TUPLE: ##nullary < insn { dst vreg } ;
! Stack operations ! Stack operations
INSN: ##load-literal < ##nullary obj ; INSN: ##load-literal < ##nullary obj ;
INSN: ##peek < ##nullary loc ; INSN: ##peek < ##nullary { loc loc } ;
INSN: ##replace src loc ; INSN: ##replace { src vreg } { loc loc } ;
INSN: ##inc-d n ; INSN: ##inc-d { n integer } ;
INSN: ##inc-r n ; INSN: ##inc-r { n integer } ;
! Subroutine calls ! Subroutine calls
TUPLE: stack-frame TUPLE: stack-frame
@ -33,8 +33,8 @@ INSN: ##return ;
INSN: ##intrinsic quot defs-vregs uses-vregs ; INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables ! Jump tables
INSN: ##dispatch-label label ;
INSN: ##dispatch src temp ; INSN: ##dispatch src temp ;
INSN: ##dispatch-label label ;
! Boxing and unboxing ! Boxing and unboxing
INSN: ##copy < ##unary ; INSN: ##copy < ##unary ;
@ -44,12 +44,12 @@ INSN: ##unbox-f < ##unary ;
INSN: ##unbox-alien < ##unary ; INSN: ##unbox-alien < ##unary ;
INSN: ##unbox-byte-array < ##unary ; INSN: ##unbox-byte-array < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary ; INSN: ##unbox-any-c-ptr < ##unary ;
INSN: ##box-float < ##unary temp ; INSN: ##box-float < ##unary { temp vreg } ;
INSN: ##box-alien < ##unary temp ; INSN: ##box-alien < ##unary { temp vreg } ;
! Memory allocation ! Memory allocation
INSN: ##allot < ##nullary size type tag temp ; INSN: ##allot < ##nullary size type tag { temp vreg } ;
INSN: ##write-barrier src card# table ; INSN: ##write-barrier { src vreg } card# table ;
INSN: ##gc ; INSN: ##gc ;
! FFI ! FFI
@ -61,28 +61,28 @@ INSN: ##callback-return params ;
GENERIC: defs-vregs ( insn -- seq ) GENERIC: defs-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq )
M: ##nullary defs-vregs dst>> >vreg 1array ; M: ##nullary defs-vregs dst>> 1array ;
M: ##unary defs-vregs dst>> >vreg 1array ; M: ##unary defs-vregs dst>> 1array ;
M: ##write-barrier defs-vregs M: ##write-barrier defs-vregs
[ card#>> >vreg ] [ table>> >vreg ] bi 2array ; [ card#>> ] [ table>> ] bi 2array ;
: allot-defs-vregs ( insn -- seq ) : allot-defs-vregs ( insn -- seq )
[ dst>> >vreg ] [ temp>> >vreg ] bi 2array ; [ dst>> ] [ temp>> ] bi 2array ;
M: ##box-float defs-vregs allot-defs-vregs ; M: ##box-float defs-vregs allot-defs-vregs ;
M: ##box-alien defs-vregs allot-defs-vregs ; M: ##box-alien defs-vregs allot-defs-vregs ;
M: ##allot defs-vregs allot-defs-vregs ; M: ##allot defs-vregs allot-defs-vregs ;
M: ##dispatch defs-vregs temp>> >vreg 1array ; M: ##dispatch defs-vregs temp>> 1array ;
M: insn defs-vregs drop f ; M: insn defs-vregs drop f ;
M: ##replace uses-vregs src>> >vreg 1array ; M: ##replace uses-vregs src>> 1array ;
M: ##unary uses-vregs src>> >vreg 1array ; M: ##unary uses-vregs src>> 1array ;
M: ##write-barrier uses-vregs src>> >vreg 1array ; M: ##write-barrier uses-vregs src>> 1array ;
M: ##dispatch uses-vregs src>> >vreg 1array ; M: ##dispatch uses-vregs src>> 1array ;
M: insn uses-vregs drop f ; M: insn uses-vregs drop f ;
: intrinsic-vregs ( assoc -- seq' ) : intrinsic-vregs ( assoc -- seq' )
[ nip >vreg ] { } assoc>map sift ; values sift ;
: intrinsic-defs-vregs ( insn -- seq ) : intrinsic-defs-vregs ( insn -- seq )
defs-vregs>> intrinsic-vregs ; defs-vregs>> intrinsic-vregs ;
@ -102,7 +102,7 @@ INSN: ##branch-f < ##cond-branch ;
INSN: ##branch-t < ##cond-branch ; INSN: ##branch-t < ##cond-branch ;
INSN: ##if-intrinsic quot defs-vregs uses-vregs ; INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
M: ##cond-branch uses-vregs src>> >vreg 1array ; M: ##cond-branch uses-vregs src>> 1array ;
M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ; M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ; M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
@ -113,20 +113,20 @@ INSN: _epilogue stack-frame ;
INSN: _label id ; INSN: _label id ;
TUPLE: _cond-branch < insn src label ; TUPLE: _cond-branch < insn { src vreg } label ;
INSN: _branch label ; INSN: _branch label ;
INSN: _branch-f < _cond-branch ; INSN: _branch-f < _cond-branch ;
INSN: _branch-t < _cond-branch ; INSN: _branch-t < _cond-branch ;
INSN: _if-intrinsic label quot defs-vregs uses-vregs ; INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
M: _cond-branch uses-vregs src>> >vreg 1array ; M: _cond-branch uses-vregs src>> 1array ;
M: _if-intrinsic defs-vregs intrinsic-defs-vregs ; M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
M: _if-intrinsic uses-vregs intrinsic-uses-vregs ; M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
INSN: _spill-integer src n ; INSN: _spill-integer { src vreg } n ;
INSN: _reload-integer dst n ; INSN: _reload-integer { dst vreg } n ;
INSN: _spill-float src n ; INSN: _spill-float { src vreg } n ;
INSN: _reload-float dst n ; INSN: _reload-float { dst vreg } n ;

85
basis/compiler/cfg/stacks/stacks.factor
View File

@ -16,10 +16,7 @@ PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
! Value protocol ! Value protocol
GENERIC: move-spec ( obj -- spec ) GENERIC: move-spec ( obj -- spec )
GENERIC: live-loc? ( actual current -- ? ) GENERIC: live-loc? ( actual current -- ? )
GENERIC# (lazy-load) 1 ( value spec -- value )
GENERIC# (eager-load) 1 ( value spec -- value )
GENERIC: lazy-store ( dst src -- ) GENERIC: lazy-store ( dst src -- )
GENERIC: minimal-ds-loc* ( min obj -- min )
! This will be a multimethod soon ! This will be a multimethod soon
DEFER: ##move DEFER: ##move
@ -28,7 +25,6 @@ PRIVATE>
! Default implementation ! Default implementation
M: value live-loc? 2drop f ; M: value live-loc? 2drop f ;
M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ; M: value lazy-store 2drop ;
M: vreg move-spec reg-class>> move-spec ; M: vreg move-spec reg-class>> move-spec ;
@ -40,7 +36,6 @@ M: int-regs value-class* drop object ;
M: float-regs move-spec drop float ; M: float-regs move-spec drop float ;
M: float-regs value-class* drop float ; M: float-regs value-class* drop float ;
M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc? M: ds-loc live-loc?
over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ; over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
@ -67,14 +62,14 @@ M: unboxed-c-ptr move-spec class ;
M: constant move-spec class ; M: constant move-spec class ;
! Moving values between locations and registers ! Moving values between locations and registers
: ##move-bug ( -- * ) "Bug in generator.registers" throw ; : ##move-bug ( -- * ) "Bug in compiler.cfg.stacks" throw ;
: ##unbox-c-ptr ( dst src -- ) : ##unbox-c-ptr ( dst src -- )
dup value-class { dup value-class {
{ [ dup \ f class<= ] [ drop ##unbox-f ] } { [ dup \ f class<= ] [ drop [ >vreg ] bi@ ##unbox-f ] }
{ [ dup simple-alien class<= ] [ drop ##unbox-alien ] } { [ dup simple-alien class<= ] [ drop [ >vreg ] bi@ ##unbox-alien ] }
{ [ dup byte-array class<= ] [ drop ##unbox-byte-array ] } { [ dup byte-array class<= ] [ drop [ >vreg ] bi@ ##unbox-byte-array ] }
[ drop ##unbox-any-c-ptr ] [ drop [ >vreg ] bi@ ##unbox-any-c-ptr ]
} cond ; inline } cond ; inline
: ##move-via-temp ( dst src -- ) : ##move-via-temp ( dst src -- )
@ -97,28 +92,28 @@ SYMBOL: fresh-objects
: ##move ( dst src -- ) : ##move ( dst src -- )
2dup [ move-spec ] bi@ 2array { 2dup [ move-spec ] bi@ 2array {
{ { f f } [ ##copy ] } { { f f } [ [ >vreg ] bi@ ##copy ] }
{ { unboxed-alien unboxed-alien } [ ##copy ] } { { unboxed-alien unboxed-alien } [ [ >vreg ] bi@ ##copy ] }
{ { unboxed-byte-array unboxed-byte-array } [ ##copy ] } { { unboxed-byte-array unboxed-byte-array } [ [ >vreg ] bi@ ##copy ] }
{ { unboxed-f unboxed-f } [ ##copy ] } { { unboxed-f unboxed-f } [ [ >vreg ] bi@ ##copy ] }
{ { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] } { { unboxed-c-ptr unboxed-c-ptr } [ [ >vreg ] bi@ ##copy ] }
{ { float float } [ ##copy-float ] } { { float float } [ [ >vreg ] bi@ ##copy-float ] }
{ { f unboxed-c-ptr } [ ##move-bug ] } { { f unboxed-c-ptr } [ ##move-bug ] }
{ { f unboxed-byte-array } [ ##move-bug ] } { { f unboxed-byte-array } [ ##move-bug ] }
{ { f constant } [ value>> ##load-literal ] } { { f constant } [ [ >vreg ] [ value>> ] bi* ##load-literal ] }
{ { f float } [ int-regs next-vreg ##box-float t fresh-object ] } { { f float } [ [ >vreg ] bi@ int-regs next-vreg ##box-float t fresh-object ] }
{ { f unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] } { { f unboxed-alien } [ [ >vreg ] bi@ int-regs next-vreg ##box-alien t fresh-object ] }
{ { f loc } [ ##peek ] } { { f loc } [ [ >vreg ] dip ##peek ] }
{ { float f } [ ##unbox-float ] } { { float f } [ [ >vreg ] bi@ ##unbox-float ] }
{ { unboxed-alien f } [ ##unbox-alien ] } { { unboxed-alien f } [ [ >vreg ] bi@ ##unbox-alien ] }
{ { unboxed-byte-array f } [ ##unbox-byte-array ] } { { unboxed-byte-array f } [ [ >vreg ] bi@ ##unbox-byte-array ] }
{ { unboxed-f f } [ ##unbox-f ] } { { unboxed-f f } [ [ >vreg ] bi@ ##unbox-f ] }
{ { unboxed-c-ptr f } [ ##unbox-c-ptr ] } { { unboxed-c-ptr f } [ ##unbox-c-ptr ] }
{ { loc f } [ swap ##replace ] } { { loc f } [ >vreg swap ##replace ] }
[ drop ##move-via-temp ] [ drop ##move-via-temp ]
} case ; } case ;
@ -168,7 +163,7 @@ M: phantom-retainstack finalize-height
: phantom-locs ( n phantom -- locs ) : phantom-locs ( n phantom -- locs )
#! A sequence of n ds-locs or rs-locs indexing the stack. #! A sequence of n ds-locs or rs-locs indexing the stack.
>r <reversed> r> '[ _ <loc> ] map ; [ <reversed> ] dip '[ _ <loc> ] map ;
: phantom-locs* ( phantom -- locs ) : phantom-locs* ( phantom -- locs )
[ stack>> length ] keep phantom-locs ; [ stack>> length ] keep phantom-locs ;
@ -209,15 +204,6 @@ M: phantom-retainstack finalize-height
: finalize-heights ( -- ) [ finalize-height ] each-phantom ; : finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
[ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-filter
values ;
: live-locs ( -- seq )
[ (live-locs) ] each-phantom append prune ;
: reg-spec>class ( spec -- class ) : reg-spec>class ( spec -- class )
float eq? double-float-regs int-regs ? ; float eq? double-float-regs int-regs ? ;
@ -231,6 +217,14 @@ M: phantom-retainstack finalize-height
[ drop ] [ drop ]
} case ; } case ;
: alloc-vreg-for ( value spec -- vreg )
alloc-vreg swap value-class
over tagged? [ >>class ] [ drop ] if ;
: (eager-load) ( value spec -- vreg )
[ alloc-vreg-for ] [ drop ] 2bi
[ ##move ] [ drop >vreg ] 2bi ;
: compatible? ( value spec -- ? ) : compatible? ( value spec -- ? )
>r move-spec r> { >r move-spec r> {
{ [ 2dup = ] [ t ] } { [ 2dup = ] [ t ] }
@ -240,20 +234,21 @@ M: phantom-retainstack finalize-height
[ f ] [ f ]
} cond 2nip ; } cond 2nip ;
: alloc-vreg-for ( value spec -- vreg ) : (lazy-load) ( value spec -- value )
alloc-vreg swap value-class
over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
{ {
{ [ dup { small-slot small-tagged } memq? ] [ drop ] } { [ dup { small-slot small-tagged } memq? ] [ drop >vreg ] }
{ [ 2dup compatible? ] [ drop ] } { [ 2dup compatible? ] [ drop >vreg ] }
[ (eager-load) ] [ (eager-load) ]
} cond ; } cond ;
M: value (eager-load) ( value spec -- vreg ) : (live-locs) ( phantom -- seq )
[ alloc-vreg-for ] [ drop ] 2bi #! Discard locs which haven't moved
[ ##move ] [ drop ] 2bi ; [ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-filter
values ;
: live-locs ( -- seq )
[ (live-locs) ] each-phantom append prune ;
M: loc lazy-store M: loc lazy-store
2dup live-loc? [ "live-locs" get at ##move ] [ 2drop ] if ; 2dup live-loc? [ "live-locs" get at ##move ] [ 2drop ] if ;

19
basis/compiler/cfg/templates/templates.factor
View File

@ -7,14 +7,6 @@ IN: compiler.cfg.templates
TUPLE: template input output scratch clobber gc ; TUPLE: template input output scratch clobber gc ;
: phantom&spec ( phantom specs -- phantom' specs' )
>r stack>> r>
[ length f pad-left ] keep
[ <reversed> ] bi@ ; inline
: phantom&spec-agree? ( phantom spec quot -- ? )
>r phantom&spec r> 2all? ; inline
: live-vregs ( -- seq ) : live-vregs ( -- seq )
[ stack>> [ >vreg ] map sift ] each-phantom append ; [ stack>> [ >vreg ] map sift ] each-phantom append ;
@ -41,7 +33,7 @@ TUPLE: template input output scratch clobber gc ;
] with-scope ; ] with-scope ;
: alloc-scratch ( template -- assoc ) : alloc-scratch ( template -- assoc )
scratch>> [ swap alloc-vreg ] assoc-map ; scratch>> [ swap alloc-vreg >vreg ] assoc-map ;
: do-template-inputs ( template -- defs uses ) : do-template-inputs ( template -- defs uses )
#! Load input values into registers and allocates scratch #! Load input values into registers and allocates scratch
@ -60,6 +52,11 @@ TUPLE: template input output scratch clobber gc ;
[ do-template-outputs ] 2keep [ do-template-outputs ] 2keep
] dip call ; inline ] dip call ; inline
: phantom&spec ( phantom specs -- phantom' specs' )
>r stack>> r>
[ length f pad-left ] keep
[ <reversed> ] bi@ ; inline
: 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
#! fixnum, see if the quotation yields true when applied #! fixnum, see if the quotation yields true when applied
@ -80,8 +77,8 @@ TUPLE: template input output scratch clobber gc ;
>r >r value-class 2 r> ?nth class-matches? r> and ; >r >r value-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( template -- ? ) : template-matches? ( template -- ? )
input>> phantom-datastack get swap input>> phantom-datastack get swap phantom&spec
[ spec-matches? ] phantom&spec-agree? ; [ spec-matches? ] 2all? ;
: find-template ( templates -- pair/f ) : find-template ( templates -- pair/f )
#! Pair has shape { quot assoc } #! Pair has shape { quot assoc }

2
basis/compiler/codegen/codegen.factor
View File

@ -24,7 +24,7 @@ M: constant v>operand
value>> [ tag-fixnum ] [ \ f tag-number ] if* ; value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
M: value v>operand M: value v>operand
>vreg [ registers get at ] [ "Bad value" throw ] if* ; registers get at [ "Bad value" throw ] unless* ;
: generate-insns ( insns -- code ) : generate-insns ( insns -- code )
[ [