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

Debugging register allocator and inline allocation

db4
Slava Pestov 2008-10-08 23:42:53 -05:00
parent 0e4e05d5cd
commit cf46a832e7
7 changed files with 78 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -250,9 +250,9 @@ M: #dispatch emit-node
: emit-intrinsic ( word -- next )
{
{ \ (tuple) [ allot-size 2 cells + tuple tuple emit-allot ] }
{ \ (array) [ allot-size 2 cells + array object emit-allot ] }
{ \ (byte-array) [ allot-size cells 2 + byte-array object emit-allot ] }
{ \ (tuple) [ allot-size 2 + cells tuple tuple emit-allot ] }
{ \ (array) [ allot-size 2 + cells array object emit-allot ] }
{ \ (byte-array) [ allot-size 2 cells + byte-array object emit-allot ] }
{ \ (complex) [ 3 cells complex complex emit-allot ] }
{ \ (ratio) [ 3 cells ratio ratio emit-allot ] }
{ \ (wrapper) [ 2 cells wrapper object emit-allot ] }

33
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -24,15 +24,21 @@ SYMBOL: active-intervals
: delete-active ( live-interval -- )
active-intervals get delete ;
: expired-interval? ( n interval -- ? )
[ end>> ] [ start>> ] bi or > ;
: expire-old-intervals ( n -- )
active-intervals get
swap '[ end>> _ < ] partition
active-intervals set
[ deallocate-register ] each ;
[ expired-interval? ] with partition
[ [ deallocate-register ] each ] [ active-intervals set ] bi* ;
: expire-old-uses ( n -- )
active-intervals get
swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ;
swap '[
uses>> [
dup peek _ < [ pop* ] [ drop ] if
] unless-empty
] each ;
: update-state ( live-interval -- )
start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
@ -59,13 +65,7 @@ SYMBOL: progress
unhandled-intervals get heap-push-all ;
: assign-free-register ( live-interval registers -- )
#! If the live interval does not have any uses, it means it
#! will be spilled immediately, so it still needs a register
#! to compute the new value, but we don't add the interval
#! to the active set and we don't remove the register from
#! the free list.
over uses>> empty?
[ peek >>reg drop ] [ pop >>reg add-active ] if ;
pop >>reg add-active ;
! Spilling
SYMBOL: spill-counts
@ -75,7 +75,9 @@ SYMBOL: spill-counts
: interval-to-spill ( -- live-interval )
#! We spill the interval with the most distant use location.
active-intervals get unclip-slice [
active-intervals get
[ uses>> empty? not ] filter
unclip-slice [
[ [ uses>> peek ] bi@ > ] most
] reduce ;
@ -95,15 +97,16 @@ SYMBOL: spill-counts
: assign-spill ( before after -- before after )
#! If it has been spilled already, reuse spill location.
over reload-from>> [ next-spill-location ] unless*
USE: cpu.architecture ! XXX
over reload-from>>
[ int-regs next-spill-location ] unless*
tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
: split-and-spill ( live-interval -- before after )
dup split-interval [ record-split ] [ assign-spill ] 2bi ;
: reuse-register ( new existing -- )
reg>> >>reg
dup uses>> empty? [ deallocate-register ] [ add-active ] if ;
reg>> >>reg add-active ;
: spill-existing ( new existing -- )
#! Our new interval will be used before the active interval

16
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -2,6 +2,8 @@ IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors
math.order
cpu.architecture
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.linear-scan
compiler.cfg.linear-scan.live-intervals
@ -103,3 +105,17 @@ SYMBOL: max-uses
USING: math.private compiler.cfg.debugger ;
[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
[ f ] [
T{ ##allot
f
T{ vreg f int-regs 1 }
40
array
object
T{ vreg f int-regs 2 }
T{ vreg f int-regs 3 }
f
} clone
1array (linear-scan) first regs>> values all-equal?
] unit-test

10
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -22,12 +22,12 @@ IN: compiler.cfg.linear-scan
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: (linear-scan) ( insns -- insns' )
dup compute-live-intervals
machine-registers allocate-registers assign-registers ;
: linear-scan ( mr -- mr' )
[
[
dup compute-live-intervals
machine-registers allocate-registers
assign-registers
] change-instructions
[ (linear-scan) ] change-instructions
! spill-counts get >>spill-counts
] with-scope ;

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

@ -24,7 +24,7 @@ GENERIC: lazy-store ( dst src -- )
GENERIC: minimal-ds-loc* ( min obj -- min )
! This will be a multimethod soon
DEFER: %move
DEFER: ##move
PRIVATE>
@ -62,7 +62,7 @@ M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
M: cached (eager-load) >r vreg>> r> (eager-load) ;
M: cached lazy-store
2dup loc>> live-loc?
[ "live-locs" get at %move ] [ 2drop ] if ;
[ "live-locs" get at ##move ] [ 2drop ] if ;
M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
M: tagged move-spec drop f ;
@ -78,9 +78,9 @@ 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 generator.registers" throw ;
: %unbox-c-ptr ( dst src -- )
: ##unbox-c-ptr ( dst src -- )
dup value-class {
{ [ dup \ f class<= ] [ drop ##unbox-f ] }
{ [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
@ -88,15 +88,15 @@ M: constant move-spec class ;
[ drop ##unbox-any-c-ptr ]
} cond ; inline
: %move-via-temp ( dst src -- )
: ##move-via-temp ( dst src -- )
#! For many transfers, such as loc to unboxed-alien, we
#! don't have an intrinsic, so we transfer the source to
#! temp then temp to the destination.
int-regs next-vreg [ over %move value-class ] keep
int-regs next-vreg [ over ##move value-class ] keep
tagged new
swap >>vreg
swap >>class
%move ;
##move ;
! Operands holding pointers to freshly-allocated objects which
! are guaranteed to be in the nursery
@ -106,7 +106,7 @@ SYMBOL: fresh-objects
: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
: %move ( dst src -- )
: ##move ( dst src -- )
2dup [ move-spec ] bi@ 2array {
{ { f f } [ ##copy ] }
{ { unboxed-alien unboxed-alien } [ ##copy ] }
@ -115,8 +115,8 @@ SYMBOL: fresh-objects
{ { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
{ { float float } [ ##copy-float ] }
{ { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] }
{ { f unboxed-c-ptr } [ ##move-bug ] }
{ { f unboxed-byte-array } [ ##move-bug ] }
{ { f constant } [ value>> ##load-literal ] }
@ -128,10 +128,10 @@ SYMBOL: fresh-objects
{ { unboxed-alien f } [ ##unbox-alien ] }
{ { unboxed-byte-array f } [ ##unbox-byte-array ] }
{ { unboxed-f f } [ ##unbox-f ] }
{ { unboxed-c-ptr f } [ %unbox-c-ptr ] }
{ { unboxed-c-ptr f } [ ##unbox-c-ptr ] }
{ { loc f } [ swap ##replace ] }
[ drop %move-via-temp ]
[ drop ##move-via-temp ]
} case ;
! A compile-time stack
@ -264,10 +264,10 @@ M: value (lazy-load)
M: value (eager-load) ( value spec -- vreg )
[ alloc-vreg-for ] [ drop ] 2bi
[ %move ] [ drop ] 2bi ;
[ ##move ] [ drop ] 2bi ;
M: loc lazy-store
2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
2dup live-loc? [ "live-locs" get at ##move ] [ 2drop ] if ;
: finalize-locs ( -- )
#! Perform any deferred stack shuffling.
@ -279,7 +279,7 @@ M: loc lazy-store
: finalize-vregs ( -- )
#! Store any vregs to their final stack locations.
[
dup loc? over cached? or [ 2drop ] [ %move ] if
dup loc? over cached? or [ 2drop ] [ ##move ] if
] each-loc ;
: clear-phantoms ( -- )

4
basis/cpu/architecture/architecture.factor
View File

@ -88,7 +88,7 @@ HOOK: %copy-float cpu ( dst src -- )
! Box and unbox floats
HOOK: %unbox-float cpu ( dst src -- )
HOOK: %box-float cpu ( dst src -- )
HOOK: %box-float cpu ( dst src temp -- )
! FFI stuff
@ -184,7 +184,7 @@ HOOK: %unbox-f cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src temp1 temp2 -- )
! Allocation
HOOK: %allot cpu ( dst size type tag temp -- )

37
basis/cpu/x86/allot/allot.factor
View File

@ -12,34 +12,34 @@ M:: x86 %write-barrier ( src temp -- )
! Mark the card
src card-bits SHR
"cards_offset" f temp %alien-global
temp temp [+] card-mark <byte> MOV
temp src [+] card-mark <byte> MOV
! Mark the card deck
temp deck-bits card-bits - SHR
src deck-bits card-bits - SHR
"decks_offset" f temp %alien-global
temp temp [+] card-mark <byte> MOV ;
temp src [+] card-mark <byte> MOV ;
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
: load-allot-ptr ( temp -- )
[ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
: inc-allot-ptr ( n temp -- )
[ POP ] [ cell [+] swap 8 align ADD ] bi ;
: inc-allot-ptr ( nursery-ptr n -- )
[ cell [+] ] dip 8 align ADD ;
: store-header ( temp type -- )
[ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
: store-tagged ( dst temp tag -- )
dupd tag-number OR MOV ;
: store-tagged ( dst tag -- )
tag-number OR ;
M:: x86 %allot ( dst size type tag temp -- )
temp load-allot-ptr
temp type store-header
temp size inc-allot-ptr
dst temp store-tagged ;
M:: x86 %allot ( dst size type tag nursery-ptr -- )
nursery-ptr dst load-allot-ptr
dst type store-header
dst tag store-tagged
nursery-ptr size inc-allot-ptr ;
M: x86 %gc ( -- )
"end" define-label
@ -130,10 +130,11 @@ M:: x86 %box-alien ( dst src temp -- )
\ fixnum>bignum [
"x" operand %untag-fixnum
"x" operand dup "scratch" operand %allot-bignum-signed-1
"y" operand "x" operand "scratch" operand %allot-bignum-signed-1
] T{ template
{ input { { f "x" } } }
{ scratch { { f "scratch" } } }
{ output { "x" } }
{ scratch { { f "y" } { f "scratch" } } }
{ output { "y" } }
{ clobber { "x" } }
{ gc t }
} define-intrinsic