From cf46a832e72ba6533e31734c42f196743fd48931 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 8 Oct 2008 23:42:53 -0500
Subject: [PATCH] Debugging register allocator and inline allocation
---
basis/compiler/cfg/builder/builder.factor | 6 +--
.../linear-scan/allocation/allocation.factor | 33 +++++++++--------
.../cfg/linear-scan/linear-scan-tests.factor | 16 ++++++++
.../cfg/linear-scan/linear-scan.factor | 10 ++---
basis/compiler/cfg/stacks/stacks.factor | 30 +++++++--------
basis/cpu/architecture/architecture.factor | 4 +-
basis/cpu/x86/allot/allot.factor | 37 ++++++++++---------
7 files changed, 78 insertions(+), 58 deletions(-)
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 1a8eae0643..50101c3cdf 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -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 ] }
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 4d1d8543bf..5433908768 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -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
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 8f1378755d..f64534227e 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -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
diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index 046f2a7eff..4628728299 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -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 ;
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index 62663bdad0..94557c9320 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -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 ( -- )
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index deed160cc3..230cc18814 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -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 -- )
diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor
index 7dfd1f4096..659f55af41 100644
--- a/basis/cpu/x86/allot/allot.factor
+++ b/basis/cpu/x86/allot/allot.factor
@@ -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