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 ;
: emit-write-barrier ( -- )
phantom-pop dup >vreg fresh-object? [ drop ] [
phantom-pop dup fresh-object? [ drop ] [
int-regs next-vreg
int-regs next-vreg
##write-barrier

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

@ -1,21 +1,21 @@
! Copyright (C) 2008 Slava Pestov.
! 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 ;
IN: compiler.cfg.instructions
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: ##cond-branch < insn src ;
TUPLE: ##unary < insn dst src ;
TUPLE: ##nullary < insn dst ;
TUPLE: ##cond-branch < insn { src vreg } ;
TUPLE: ##unary < insn { dst vreg } { src vreg } ;
TUPLE: ##nullary < insn { dst vreg } ;
! Stack operations
INSN: ##load-literal < ##nullary obj ;
INSN: ##peek < ##nullary loc ;
INSN: ##replace src loc ;
INSN: ##inc-d n ;
INSN: ##inc-r n ;
INSN: ##peek < ##nullary { loc loc } ;
INSN: ##replace { src vreg } { loc loc } ;
INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ;
! Subroutine calls
TUPLE: stack-frame
@ -33,8 +33,8 @@ INSN: ##return ;
INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables
INSN: ##dispatch-label label ;
INSN: ##dispatch src temp ;
INSN: ##dispatch-label label ;
! Boxing and unboxing
INSN: ##copy < ##unary ;
@ -44,12 +44,12 @@ INSN: ##unbox-f < ##unary ;
INSN: ##unbox-alien < ##unary ;
INSN: ##unbox-byte-array < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary ;
INSN: ##box-float < ##unary temp ;
INSN: ##box-alien < ##unary temp ;
INSN: ##box-float < ##unary { temp vreg } ;
INSN: ##box-alien < ##unary { temp vreg } ;
! Memory allocation
INSN: ##allot < ##nullary size type tag temp ;
INSN: ##write-barrier src card# table ;
INSN: ##allot < ##nullary size type tag { temp vreg } ;
INSN: ##write-barrier { src vreg } card# table ;
INSN: ##gc ;
! FFI
@ -61,28 +61,28 @@ INSN: ##callback-return params ;
GENERIC: defs-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
M: ##nullary defs-vregs dst>> >vreg 1array ;
M: ##unary defs-vregs dst>> >vreg 1array ;
M: ##nullary defs-vregs dst>> 1array ;
M: ##unary defs-vregs dst>> 1array ;
M: ##write-barrier defs-vregs
[ card#>> >vreg ] [ table>> >vreg ] bi 2array ;
[ card#>> ] [ table>> ] bi 2array ;
: 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-alien 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: ##replace uses-vregs src>> >vreg 1array ;
M: ##unary uses-vregs src>> >vreg 1array ;
M: ##write-barrier uses-vregs src>> >vreg 1array ;
M: ##dispatch uses-vregs src>> >vreg 1array ;
M: ##replace uses-vregs src>> 1array ;
M: ##unary uses-vregs src>> 1array ;
M: ##write-barrier uses-vregs src>> 1array ;
M: ##dispatch uses-vregs src>> 1array ;
M: insn uses-vregs drop f ;
: intrinsic-vregs ( assoc -- seq' )
[ nip >vreg ] { } assoc>map sift ;
values sift ;
: intrinsic-defs-vregs ( insn -- seq )
defs-vregs>> intrinsic-vregs ;
@ -102,7 +102,7 @@ INSN: ##branch-f < ##cond-branch ;
INSN: ##branch-t < ##cond-branch ;
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 uses-vregs intrinsic-uses-vregs ;
@ -113,20 +113,20 @@ INSN: _epilogue stack-frame ;
INSN: _label id ;
TUPLE: _cond-branch < insn src label ;
TUPLE: _cond-branch < insn { src vreg } label ;
INSN: _branch label ;
INSN: _branch-f < _cond-branch ;
INSN: _branch-t < _cond-branch ;
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 uses-vregs intrinsic-uses-vregs ;
INSN: _spill-integer src n ;
INSN: _reload-integer dst n ;
INSN: _spill-integer { src vreg } n ;
INSN: _reload-integer { dst vreg } n ;
INSN: _spill-float src n ;
INSN: _reload-float dst n ;
INSN: _spill-float { src vreg } 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
GENERIC: move-spec ( obj -- spec )
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: minimal-ds-loc* ( min obj -- min )
! This will be a multimethod soon
DEFER: ##move
@ -28,7 +25,6 @@ PRIVATE>
! Default implementation
M: value live-loc? 2drop f ;
M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
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 value-class* drop float ;
M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc?
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 ;
! 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 -- )
dup value-class {
{ [ dup \ f class<= ] [ drop ##unbox-f ] }
{ [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
{ [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
[ drop ##unbox-any-c-ptr ]
{ [ dup \ f class<= ] [ drop [ >vreg ] bi@ ##unbox-f ] }
{ [ dup simple-alien class<= ] [ drop [ >vreg ] bi@ ##unbox-alien ] }
{ [ dup byte-array class<= ] [ drop [ >vreg ] bi@ ##unbox-byte-array ] }
[ drop [ >vreg ] bi@ ##unbox-any-c-ptr ]
} cond ; inline
: ##move-via-temp ( dst src -- )
@ -97,28 +92,28 @@ SYMBOL: fresh-objects
: ##move ( dst src -- )
2dup [ move-spec ] bi@ 2array {
{ { f f } [ ##copy ] }
{ { unboxed-alien unboxed-alien } [ ##copy ] }
{ { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
{ { unboxed-f unboxed-f } [ ##copy ] }
{ { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
{ { float float } [ ##copy-float ] }
{ { f f } [ [ >vreg ] bi@ ##copy ] }
{ { unboxed-alien unboxed-alien } [ [ >vreg ] bi@ ##copy ] }
{ { unboxed-byte-array unboxed-byte-array } [ [ >vreg ] bi@ ##copy ] }
{ { unboxed-f unboxed-f } [ [ >vreg ] bi@ ##copy ] }
{ { unboxed-c-ptr unboxed-c-ptr } [ [ >vreg ] bi@ ##copy ] }
{ { float float } [ [ >vreg ] bi@ ##copy-float ] }
{ { f unboxed-c-ptr } [ ##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 unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] }
{ { f loc } [ ##peek ] }
{ { f float } [ [ >vreg ] bi@ int-regs next-vreg ##box-float t fresh-object ] }
{ { f unboxed-alien } [ [ >vreg ] bi@ int-regs next-vreg ##box-alien t fresh-object ] }
{ { f loc } [ [ >vreg ] dip ##peek ] }
{ { float f } [ ##unbox-float ] }
{ { unboxed-alien f } [ ##unbox-alien ] }
{ { unboxed-byte-array f } [ ##unbox-byte-array ] }
{ { unboxed-f f } [ ##unbox-f ] }
{ { float f } [ [ >vreg ] bi@ ##unbox-float ] }
{ { unboxed-alien f } [ [ >vreg ] bi@ ##unbox-alien ] }
{ { unboxed-byte-array f } [ [ >vreg ] bi@ ##unbox-byte-array ] }
{ { unboxed-f f } [ [ >vreg ] bi@ ##unbox-f ] }
{ { unboxed-c-ptr f } [ ##unbox-c-ptr ] }
{ { loc f } [ swap ##replace ] }
{ { loc f } [ >vreg swap ##replace ] }
[ drop ##move-via-temp ]
} case ;
@ -168,7 +163,7 @@ M: phantom-retainstack finalize-height
: phantom-locs ( n phantom -- locs )
#! 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 )
[ stack>> length ] keep phantom-locs ;
@ -209,15 +204,6 @@ M: phantom-retainstack finalize-height
: 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 )
float eq? double-float-regs int-regs ? ;
@ -231,6 +217,14 @@ M: phantom-retainstack finalize-height
[ drop ]
} 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 -- ? )
>r move-spec r> {
{ [ 2dup = ] [ t ] }
@ -240,20 +234,21 @@ M: phantom-retainstack finalize-height
[ f ]
} cond 2nip ;
: alloc-vreg-for ( value spec -- vreg )
alloc-vreg swap value-class
over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
: (lazy-load) ( value spec -- value )
{
{ [ dup { small-slot small-tagged } memq? ] [ drop ] }
{ [ 2dup compatible? ] [ drop ] }
{ [ dup { small-slot small-tagged } memq? ] [ drop >vreg ] }
{ [ 2dup compatible? ] [ drop >vreg ] }
[ (eager-load) ]
} cond ;
M: value (eager-load) ( value spec -- vreg )
[ alloc-vreg-for ] [ drop ] 2bi
[ ##move ] [ drop ] 2bi ;
: (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 ;
M: loc lazy-store
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 ;
: 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 )
[ stack>> [ >vreg ] map sift ] each-phantom append ;
@ -41,7 +33,7 @@ TUPLE: template input output scratch clobber gc ;
] with-scope ;
: alloc-scratch ( template -- assoc )
scratch>> [ swap alloc-vreg ] assoc-map ;
scratch>> [ swap alloc-vreg >vreg ] assoc-map ;
: do-template-inputs ( template -- defs uses )
#! Load input values into registers and allocates scratch
@ -60,6 +52,11 @@ TUPLE: template input output scratch clobber gc ;
[ do-template-outputs ] 2keep
] dip call ; inline
: phantom&spec ( phantom specs -- phantom' specs' )
>r stack>> r>
[ length f pad-left ] keep
[ <reversed> ] bi@ ; 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
@ -80,8 +77,8 @@ TUPLE: template input output scratch clobber gc ;
>r >r value-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( template -- ? )
input>> phantom-datastack get swap
[ spec-matches? ] phantom&spec-agree? ;
input>> phantom-datastack get swap phantom&spec
[ spec-matches? ] 2all? ;
: find-template ( templates -- pair/f )
#! 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* ;
M: value v>operand
>vreg [ registers get at ] [ "Bad value" throw ] if* ;
registers get at [ "Bad value" throw ] unless* ;
: generate-insns ( insns -- code )
[