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

Merge branch 'inlinec' into marshall 

* inlinec:
  alien.inline: added RAW-C: word
  struct-arrays and struct-vectors: fix unit tests
  oops
  byte-length for struct-vectors
  fix struct-vectors
  sequences: fix replicate example
  byte-length method for struct-arrays
  growable vocabulary: make 'contract' generic so that only real vectors clear popped elements; add resize method for struct-arrays, add new struct-vectors vocabulary
  Add vectors.functor for generating vector types from arrays; re-implement bit-vectors and specialized-vectors using this. Add DEFERS directive to functors
  compiler.cfg.linear-scan: debugging spilling, add more assertions
  threads: better error messages
  benchmark.hashtables: throw something together
  Remove A+s shortcut for saving image in UI
  compiler.cfg.linear-scan: code cleanup
  compiler.cfg.linear-scan: Re-implement spilling, add some additional runtime assertions, simplify assignment pass since it doesn't have to track spill slots anymore; just assume a live value that's not in active or inactive is spilled
db4
Jeremy Hughes 2009-07-08 17:21:53 +12:00
parent 25e034adb6 f93e7dd859
commit 7d708a17c2
29 changed files with 963 additions and 308 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
basis/alien/inline/inline.factor
View File

@ -130,3 +130,6 @@ SYNTAX: C-STRUCTURE:
SYNTAX: ;C-LIBRARY compile-c-library ; SYNTAX: ;C-LIBRARY compile-c-library ;
SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ; SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
SYNTAX: RAW-C:
[ "\n" % parse-here % "\n" % c-strings get push ] "" make ;

4
basis/bit-vectors/bit-vectors-docs.factor
View File

@ -22,11 +22,11 @@ HELP: bit-vector
{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ; { $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
HELP: <bit-vector> HELP: <bit-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } } { $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } }
{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ; { $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
HELP: >bit-vector HELP: >bit-vector
{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } } { $values { "seq" "a sequence" } { "vector" bit-vector } }
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
HELP: ?V{ HELP: ?V{

31
basis/bit-vectors/bit-vectors.factor
View File

@ -1,38 +1,15 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays prettyprint.custom sequences.private growable bit-arrays prettyprint.custom
parser accessors ; parser accessors vectors.functor classes.parser ;
IN: bit-vectors IN: bit-vectors
TUPLE: bit-vector << "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
{ underlying bit-array initial: ?{ } }
{ length array-capacity } ;
: <bit-vector> ( n -- bit-vector )
<bit-array> 0 bit-vector boa ; inline
: >bit-vector ( seq -- bit-vector )
T{ bit-vector f ?{ } 0 } clone-like ;
M: bit-vector like
drop dup bit-vector? [
dup bit-array?
[ dup length bit-vector boa ] [ >bit-vector ] if
] unless ;
M: bit-vector new-sequence
drop [ <bit-array> ] [ >fixnum ] bi bit-vector boa ;
M: bit-vector equal?
over bit-vector? [ sequence= ] [ 2drop f ] if ;
M: bit-array new-resizable drop <bit-vector> ;
INSTANCE: bit-vector growable
SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ; SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
M: bit-vector contract 2drop ;
M: bit-vector >pprint-sequence ; M: bit-vector >pprint-sequence ;
M: bit-vector pprint-delims drop \ ?V{ \ } ; M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: bit-vector pprint* pprint-object ; M: bit-vector pprint* pprint-object ;

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

@ -9,11 +9,6 @@ compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ; compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation IN: compiler.cfg.linear-scan.allocation
: free-positions ( new -- assoc )
vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
: active-positions ( new assoc -- ) : active-positions ( new assoc -- )
[ vreg>> active-intervals-for ] dip [ vreg>> active-intervals-for ] dip
'[ [ 0 ] dip reg>> _ add-use-position ] each ; '[ [ 0 ] dip reg>> _ add-use-position ] each ;
@ -21,7 +16,7 @@ IN: compiler.cfg.linear-scan.allocation
: inactive-positions ( new assoc -- ) : inactive-positions ( new assoc -- )
[ [ vreg>> inactive-intervals-for ] keep ] dip [ [ vreg>> inactive-intervals-for ] keep ] dip
'[ '[
[ _ relevant-ranges intersect-live-ranges ] [ reg>> ] bi [ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi
_ add-use-position _ add-use-position
] each ; ] each ;
@ -33,12 +28,6 @@ IN: compiler.cfg.linear-scan.allocation
: no-free-registers? ( result -- ? ) : no-free-registers? ( result -- ? )
second 0 = ; inline second 0 = ; inline
: register-available? ( new result -- ? )
[ end>> ] [ second ] bi* < ; inline
: register-available ( new result -- )
first >>reg add-active ;
: register-partially-available ( new result -- ) : register-partially-available ( new result -- )
[ second split-before-use ] keep [ second split-before-use ] keep
'[ _ register-available ] [ add-unhandled ] bi* ; '[ _ register-available ] [ add-unhandled ] bi* ;

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

@ -9,15 +9,15 @@ IN: compiler.cfg.linear-scan.allocation.coalescing
: active-interval ( vreg -- live-interval ) : active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ; dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
: intersects-inactive-intervals? ( live-interval -- ? ) : avoids-inactive-intervals? ( live-interval -- ? )
dup vreg>> inactive-intervals-for dup vreg>> inactive-intervals-for
[ relevant-ranges intersect-live-ranges 1/0. = ] with all? ; [ intervals-intersect? not ] with all? ;
: coalesce? ( live-interval -- ? ) : coalesce? ( live-interval -- ? )
{ {
[ copy-from>> active-interval ] [ copy-from>> active-interval ]
[ [ start>> ] [ copy-from>> active-interval end>> ] bi = ] [ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
[ intersects-inactive-intervals? ] [ avoids-inactive-intervals? ]
} 1&& ; } 1&& ;
: coalesce ( live-interval -- ) : coalesce ( live-interval -- )

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

@ -1,23 +1,13 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting compiler.utilities namespaces math sequences sets sorting splitting namespaces
combinators.short-circuit compiler.utilities
compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.spilling IN: compiler.cfg.linear-scan.allocation.spilling
: find-use ( live-interval n quot -- elt )
[ uses>> ] 2dip curry find nip ; inline
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
#! If an active interval has no more use positions, find-use
#! returns f. This occurs if the interval is a split. In
#! this case, we prefer to spill this interval always.
start>> '[ dup _ [ >= ] find-use 1/0. or ] { } map>assoc
alist-max first ;
ERROR: bad-live-ranges interval ; ERROR: bad-live-ranges interval ;
: check-ranges ( live-interval -- ) : check-ranges ( live-interval -- )
@ -47,52 +37,108 @@ ERROR: bad-live-ranges interval ;
[ ] [ ]
} 2cleave ; } 2cleave ;
: assign-spill ( live-interval -- live-interval ) : assign-spill ( live-interval -- )
dup vreg>> assign-spill-slot >>spill-to ; dup vreg>> assign-spill-slot >>spill-to drop ;
: assign-reload ( before after -- before after ) : assign-reload ( live-interval -- )
over spill-to>> >>reload-from ; dup vreg>> assign-spill-slot >>reload-from drop ;
: split-and-spill ( new existing -- before after ) : split-and-spill ( live-interval n -- before after )
swap start>> split-for-spill [ assign-spill ] dip assign-reload ; split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;
: reuse-register ( new existing -- ) : find-use-position ( live-interval new -- n )
[ nip delete-active ] [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
[ reg>> >>reg add-active ] 2bi ;
: spill-existing? ( new existing -- ? ) : find-use-positions ( live-intervals new assoc -- )
#! Test if 'new' will be used before 'existing'. '[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
over start>> '[ _ [ > ] find-use -1 or ] bi@ < ;
: spill-existing ( new existing -- ) : active-positions ( new assoc -- )
#! Our new interval will be used before the active interval [ [ vreg>> active-intervals-for ] keep ] dip
#! with the most distant use location. Spill the existing find-use-positions ;
#! interval, then process the new interval and the tail end
#! of the existing interval again.
[ reuse-register ]
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2bi ;
: spill-live-out? ( new existing -- ? ) : inactive-positions ( new assoc -- )
[ start>> ] [ uses>> last ] bi* > ; [
[ vreg>> inactive-intervals-for ] keep
[ '[ _ intervals-intersect? ] filter ] keep
] dip
find-use-positions ;
: spill-live-out ( new existing -- ) : spill-status ( new -- use-pos )
#! The existing interval is never used again. Spill it and H{ } clone
#! re-use the register. [ inactive-positions ] [ active-positions ] [ nip ] 2tri
assign-spill >alist alist-max ;
[ reuse-register ]
[ nip add-handled ] 2bi ;
: spill-new ( new existing -- ) : spill-new? ( new pair -- ? )
#! Our new interval will be used after the active interval [ uses>> first ] [ second ] bi* > ;
#! with the most distant use location. Split the new
#! interval, then process both parts of the new interval
#! again.
[ dup split-and-spill add-unhandled ] dip spill-existing ;
: assign-blocked-register ( new -- ) : spill-new ( new pair -- )
[ dup vreg>> active-intervals-for ] keep interval-to-spill { drop
{ [ 2dup spill-live-out? ] [ spill-live-out ] } {
{ [ 2dup spill-existing? ] [ spill-existing ] } [ trim-after-ranges ]
[ spill-new ] [ compute-start/end ]
[ assign-reload ]
[ add-unhandled ]
} cleave ;
: split-intersecting? ( live-interval new reg -- ? )
{ [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ;
: split-live-out ( live-interval -- )
{
[ trim-before-ranges ]
[ compute-start/end ]
[ assign-spill ]
[ add-handled ]
} cleave ;
: split-live-in ( live-interval -- )
{
[ trim-after-ranges ]
[ compute-start/end ]
[ assign-reload ]
[ add-unhandled ]
} cleave ;
: (split-intersecting) ( live-interval new -- )
start>> {
{ [ 2dup [ uses>> last ] dip < ] [ drop split-live-out ] }
{ [ 2dup [ uses>> first ] dip > ] [ drop split-live-in ] }
[ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
} cond ; } cond ;
: (split-intersecting-active) ( active new -- )
[ drop delete-active ]
[ (split-intersecting) ] 2bi ;
: split-intersecting-active ( new reg -- )
[ [ vreg>> active-intervals-for ] keep ] dip
[ '[ _ _ split-intersecting? ] filter ] 2keep drop
'[ _ (split-intersecting-active) ] each ;
: (split-intersecting-inactive) ( inactive new -- )
[ drop delete-inactive ]
[ (split-intersecting) ] 2bi ;
: split-intersecting-inactive ( new reg -- )
[ [ vreg>> inactive-intervals-for ] keep ] dip
[ '[ _ _ split-intersecting? ] filter ] 2keep drop
'[ _ (split-intersecting-inactive) ] each ;
: split-intersecting ( new reg -- )
[ split-intersecting-active ]
[ split-intersecting-inactive ]
2bi ;
: spill-available ( new pair -- )
[ first split-intersecting ] [ register-available ] 2bi ;
: spill-partially-available ( new pair -- )
[ second 1 - split-and-spill add-unhandled ] keep
spill-available ;
: assign-blocked-register ( new -- )
dup spill-status {
{ [ 2dup spill-new? ] [ spill-new ] }
{ [ 2dup register-available? ] [ spill-available ] }
[ spill-partially-available ]
} cond ;

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

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting math sequences sets sorting splitting namespaces
compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.splitting IN: compiler.cfg.linear-scan.allocation.splitting
@ -32,12 +32,17 @@ IN: compiler.cfg.linear-scan.allocation.splitting
ERROR: splitting-too-early ; ERROR: splitting-too-early ;
ERROR: splitting-too-late ;
ERROR: splitting-atomic-interval ; ERROR: splitting-atomic-interval ;
: check-split ( live-interval n -- ) : check-split ( live-interval n -- )
[ [ start>> ] dip > [ splitting-too-early ] when ] check-allocation? get [
[ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ] [ [ start>> ] dip > [ splitting-too-early ] when ]
2bi ; inline [ [ end>> ] dip <= [ splitting-too-late ] when ]
[ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
2tri
] [ 2drop ] if ; inline
: split-before ( before -- before' ) : split-before ( before -- before' )
f >>spill-to ; inline f >>spill-to ; inline

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

@ -1,10 +1,24 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps USING: accessors assocs combinators cpu.architecture fry heaps
kernel math namespaces sequences vectors kernel math math.order namespaces sequences vectors
compiler.cfg.linear-scan.live-intervals ; compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state IN: compiler.cfg.linear-scan.allocation.state
! Start index of current live interval. We ensure that all
! live intervals added to the unhandled set have a start index
! strictly greater than this one. This ensures that we can catch
! infinite loop situations. We also ensure that all live
! intervals added to the handled set have an end index strictly
! smaller than this one. This helps catch bugs.
SYMBOL: progress
: check-unhandled ( live-interval -- )
start>> progress get <= [ "check-unhandled" throw ] when ; inline
: check-handled ( live-interval -- )
end>> progress get > [ "check-handled" throw ] when ; inline
! Mapping from register classes to sequences of machine registers ! Mapping from register classes to sequences of machine registers
SYMBOL: registers SYMBOL: registers
@ -32,11 +46,14 @@ SYMBOL: inactive-intervals
: add-inactive ( live-interval -- ) : add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ; dup vreg>> inactive-intervals-for push ;
: delete-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for delq ;
! Vector of handled live intervals ! Vector of handled live intervals
SYMBOL: handled-intervals SYMBOL: handled-intervals
: add-handled ( live-interval -- ) : add-handled ( live-interval -- )
handled-intervals get push ; [ check-handled ] [ handled-intervals get push ] bi ;
: finished? ( n live-interval -- ? ) end>> swap < ; : finished? ( n live-interval -- ? ) end>> swap < ;
@ -90,17 +107,8 @@ ERROR: register-already-used live-interval ;
! Minheap of live intervals which still need a register allocation ! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals SYMBOL: unhandled-intervals
! Start index of current live interval. We ensure that all
! live intervals added to the unhandled set have a start index
! strictly greater than ths one. This ensures that we can catch
! infinite loop situations.
SYMBOL: progress
: check-progress ( live-interval -- )
start>> progress get <= [ "No progress" throw ] when ; inline
: add-unhandled ( live-interval -- ) : add-unhandled ( live-interval -- )
[ check-progress ] [ check-unhandled ]
[ dup start>> unhandled-intervals get heap-push ] [ dup start>> unhandled-intervals get heap-push ]
bi ; bi ;
@ -133,4 +141,16 @@ SYMBOL: spill-slots
: init-unhandled ( live-intervals -- ) : init-unhandled ( live-intervals -- )
[ [ start>> ] keep ] { } map>assoc [ [ start>> ] keep ] { } map>assoc
unhandled-intervals get heap-push-all ; unhandled-intervals get heap-push-all ;
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )
vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
: register-available? ( new result -- ? )
[ end>> ] [ second ] bi* < ; inline
: register-available ( new result -- )
first >>reg add-active ;

88
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -3,7 +3,9 @@
USING: accessors kernel math assocs namespaces sequences heaps USING: accessors kernel math assocs namespaces sequences heaps
fry make combinators sets locals fry make combinators sets locals
cpu.architecture cpu.architecture
compiler.cfg
compiler.cfg.def-use compiler.cfg.def-use
compiler.cfg.liveness
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
@ -27,12 +29,6 @@ SYMBOL: unhandled-intervals
: init-unhandled ( live-intervals -- ) : init-unhandled ( live-intervals -- )
[ add-unhandled ] each ; [ add-unhandled ] each ;
! Mapping spill slots to vregs
SYMBOL: spill-slots
: spill-slots-for ( vreg -- assoc )
reg-class>> spill-slots get at ;
! Mapping from basic blocks to values which are live at the start ! Mapping from basic blocks to values which are live at the start
SYMBOL: register-live-ins SYMBOL: register-live-ins
@ -42,17 +38,10 @@ SYMBOL: register-live-outs
: init-assignment ( live-intervals -- ) : init-assignment ( live-intervals -- )
V{ } clone pending-intervals set V{ } clone pending-intervals set
<min-heap> unhandled-intervals set <min-heap> unhandled-intervals set
[ H{ } clone ] reg-class-assoc spill-slots set
H{ } clone register-live-ins set H{ } clone register-live-ins set
H{ } clone register-live-outs set H{ } clone register-live-outs set
init-unhandled ; init-unhandled ;
ERROR: already-spilled ;
: record-spill ( live-interval -- )
[ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
2dup key? drop set-at ; ! [ already-spilled ] [ set-at ] if ;
: insert-spill ( live-interval -- ) : insert-spill ( live-interval -- )
{ {
[ reg>> ] [ reg>> ]
@ -62,7 +51,7 @@ ERROR: already-spilled ;
} cleave f swap \ _spill boa , ; } cleave f swap \ _spill boa , ;
: handle-spill ( live-interval -- ) : handle-spill ( live-interval -- )
dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ; dup spill-to>> [ insert-spill ] [ drop ] if ;
: first-split ( live-interval -- live-interval' ) : first-split ( live-interval -- live-interval' )
dup split-before>> [ first-split ] [ ] ?if ; dup split-before>> [ first-split ] [ ] ?if ;
@ -79,8 +68,7 @@ ERROR: already-spilled ;
} cleave f swap \ _copy boa , ; } cleave f swap \ _copy boa , ;
: handle-copy ( live-interval -- ) : handle-copy ( live-interval -- )
dup [ spill-to>> not ] [ split-next>> ] bi and dup split-next>> [ insert-copy ] [ drop ] if ;
[ insert-copy ] [ drop ] if ;
: expire-old-intervals ( n -- ) : expire-old-intervals ( n -- )
[ pending-intervals get ] dip '[ [ pending-intervals get ] dip '[
@ -88,28 +76,22 @@ ERROR: already-spilled ;
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
] filter-here ; ] filter-here ;
ERROR: already-reloaded ;
: record-reload ( live-interval -- )
[ reload-from>> ] [ vreg>> spill-slots-for ] bi
2dup key? [ delete-at ] [ already-reloaded ] if ;
: insert-reload ( live-interval -- ) : insert-reload ( live-interval -- )
{ {
[ reg>> ] [ reg>> ]
[ vreg>> reg-class>> ] [ vreg>> reg-class>> ]
[ reload-from>> ] [ reload-from>> ]
[ end>> ] [ start>> ]
} cleave f swap \ _reload boa , ; } cleave f swap \ _reload boa , ;
: handle-reload ( live-interval -- ) : handle-reload ( live-interval -- )
dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ; dup reload-from>> [ insert-reload ] [ drop ] if ;
: activate-new-intervals ( n -- ) : activate-new-intervals ( n -- )
#! Any live intervals which start on the current instruction #! Any live intervals which start on the current instruction
#! are added to the active set. #! are added to the active set.
unhandled-intervals get dup heap-empty? [ 2drop ] [ unhandled-intervals get dup heap-empty? [ 2drop ] [
2dup heap-peek drop start>> >= [ 2dup heap-peek drop start>> = [
heap-pop drop heap-pop drop
[ add-active ] [ handle-reload ] bi [ add-active ] [ handle-reload ] bi
activate-new-intervals activate-new-intervals
@ -145,35 +127,43 @@ M: vreg-insn assign-registers-in-insn
register-mapping register-mapping
>>regs drop ; >>regs drop ;
: compute-live-registers ( n -- assoc )
active-intervals register-mapping ;
: compute-live-spill-slots ( -- assocs )
spill-slots get values first2
[ [ vreg>> swap <spill-slot> ] H{ } assoc-map-as ] bi@
assoc-union ;
: compute-live-values ( n -- assoc )
[ compute-live-spill-slots ] dip compute-live-registers
assoc-union ;
: compute-live-gc-values ( insn -- assoc )
[ insn#>> compute-live-values ] [ temp-vregs ] bi
'[ drop _ memq? not ] assoc-filter ;
M: ##gc assign-registers-in-insn M: ##gc assign-registers-in-insn
! This works because ##gc is always the first instruction
! in a block.
dup call-next-method dup call-next-method
dup compute-live-gc-values >>live-values basic-block get register-live-ins get at >>live-values
drop ; drop ;
M: insn assign-registers-in-insn drop ; M: insn assign-registers-in-insn drop ;
: compute-live-spill-slots ( vregs -- assoc )
spill-slots get '[ _ at dup [ <spill-slot> ] when ] assoc-map ;
: compute-live-registers ( n -- assoc )
active-intervals register-mapping ;
ERROR: bad-live-values live-values ;
: check-live-values ( assoc -- assoc )
check-assignment? get [
dup values [ not ] any? [ bad-live-values ] when
] when ;
: compute-live-values ( vregs n -- assoc )
! If a live vreg is not in active or inactive, then it must have been
! spilled.
[ compute-live-spill-slots ] [ compute-live-registers ] bi*
assoc-union check-live-values ;
: begin-block ( bb -- ) : begin-block ( bb -- )
dup basic-block set
dup block-from prepare-insn dup block-from prepare-insn
[ block-from compute-live-values ] keep register-live-ins get set-at ; [ [ live-in ] [ block-from ] bi compute-live-values ] keep
register-live-ins get set-at ;
: end-block ( bb -- ) : end-block ( bb -- )
[ block-to compute-live-values ] keep register-live-outs get set-at ; [ [ live-out ] [ block-to ] bi compute-live-values ] keep
register-live-outs get set-at ;
ERROR: bad-vreg vreg ; ERROR: bad-vreg vreg ;
@ -188,10 +178,12 @@ ERROR: bad-vreg vreg ;
[ [
bb begin-block bb begin-block
[ [
[ insn#>> prepare-insn ] {
[ assign-registers-in-insn ] [ insn#>> 1 - prepare-insn ]
[ , ] [ insn#>> prepare-insn ]
tri [ assign-registers-in-insn ]
[ , ]
} cleave
] each ] each
bb end-block bb end-block
] V{ } make ] V{ } make

7
basis/compiler/cfg/linear-scan/debugger/debugger.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences sets arrays math strings fry USING: accessors kernel sequences sets arrays math strings fry
namespaces prettyprint compiler.cfg.linear-scan.live-intervals namespaces prettyprint compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg ; compiler.cfg.linear-scan.allocation compiler.cfg assocs ;
IN: compiler.cfg.linear-scan.debugger IN: compiler.cfg.linear-scan.debugger
: check-assigned ( live-intervals -- ) : check-assigned ( live-intervals -- )
@ -19,7 +19,10 @@ IN: compiler.cfg.linear-scan.debugger
] [ 1array ] if ; ] [ 1array ] if ;
: check-linear-scan ( live-intervals machine-registers -- ) : check-linear-scan ( live-intervals machine-registers -- )
[ [ clone ] map ] dip allocate-registers [
[ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
live-intervals set
] dip allocate-registers
[ split-children ] map concat check-assigned ; [ split-children ] map concat check-assigned ;
: picture ( uses -- str ) : picture ( uses -- str )

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

@ -1,7 +1,7 @@
IN: compiler.cfg.linear-scan.tests IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors locals kernel fry arrays splitting namespaces math accessors vectors locals
math.order grouping math.order grouping strings strings.private
cpu.architecture cpu.architecture
compiler.cfg compiler.cfg
compiler.cfg.optimizer compiler.cfg.optimizer
@ -13,6 +13,7 @@ compiler.cfg.rpo
compiler.cfg.linearization compiler.cfg.linearization
compiler.cfg.debugger compiler.cfg.debugger
compiler.cfg.linear-scan compiler.cfg.linear-scan
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.allocation.state
@ -24,6 +25,7 @@ FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
check-allocation? on check-allocation? on
check-assignment? on check-assignment? on
check-numbering? on
[ [
{ T{ live-range f 1 10 } T{ live-range f 15 15 } } { T{ live-range f 1 10 } T{ live-range f 15 15 } }
@ -76,36 +78,6 @@ check-assignment? on
{ T{ live-range f 0 5 } } 0 split-ranges { T{ live-range f 0 5 } } 0 split-ranges
] unit-test ] unit-test
[ 7 ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 7 10 } }
}
4 [ >= ] find-use
] unit-test
[ 4 ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 4 10 } }
}
4 [ >= ] find-use
] unit-test
[ f ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ start 0 }
{ end 10 }
{ uses V{ 0 1 3 4 10 } }
}
100 [ >= ] find-use
] unit-test
[ [
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@ -257,88 +229,82 @@ check-assignment? on
] unit-test ] unit-test
[ [
T{ live-interval {
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } 3
{ start 3 } 10
{ end 10 }
{ uses V{ 3 10 } }
} }
] [ ] [
H{
{ int-regs
V{
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ reg 1 }
{ start 1 }
{ end 15 }
{ uses V{ 1 3 7 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ reg 2 }
{ start 3 }
{ end 8 }
{ uses V{ 3 4 8 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ reg 3 }
{ start 3 }
{ end 10 }
{ uses V{ 3 10 } }
}
}
}
} active-intervals set
H{ } inactive-intervals set
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
spill-status
] unit-test
[
{ {
T{ live-interval 1
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } 1/0.
{ start 1 }
{ end 15 }
{ uses V{ 1 3 7 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 3 }
{ end 8 }
{ uses V{ 3 4 8 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 3 }
{ end 10 }
{ uses V{ 3 10 } }
}
} }
] [
H{
{ int-regs
V{
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ reg 1 }
{ start 1 }
{ end 15 }
{ uses V{ 1 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 2 } } }
{ reg 2 }
{ start 3 }
{ end 8 }
{ uses V{ 3 8 } }
}
}
}
} active-intervals set
H{ } inactive-intervals set
T{ live-interval T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } } { vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 5 } { start 5 }
{ end 5 } { end 5 }
{ uses V{ 5 } } { uses V{ 5 } }
} }
interval-to-spill spill-status
] unit-test
[ t ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 15 }
{ uses V{ 5 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 20 } }
}
spill-existing?
] unit-test
[ f ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 15 }
{ uses V{ 5 10 15 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 7 20 } }
}
spill-existing?
] unit-test
[ t ] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 1 }
{ end 20 }
{ uses V{ 1 7 20 } }
}
spill-existing?
] unit-test ] unit-test
[ ] [ [ ] [
@ -1477,6 +1443,20 @@ USING: math.private ;
intersect-live-ranges intersect-live-ranges
] unit-test ] unit-test
[ f ] [
{
T{ live-range f 0 10 }
T{ live-range f 20 30 }
T{ live-range f 40 50 }
}
{
T{ live-range f 11 15 }
T{ live-range f 31 36 }
T{ live-range f 51 55 }
}
intersect-live-ranges
] unit-test
[ 5 ] [ [ 5 ] [
T{ live-interval T{ live-interval
{ start 0 } { start 0 }
@ -1605,12 +1585,14 @@ V{
SYMBOL: linear-scan-result SYMBOL: linear-scan-result
:: test-linear-scan-on-cfg ( regs -- ) :: test-linear-scan-on-cfg ( regs -- )
cfg new 0 get >>entry [
compute-predecessors cfg new 0 get >>entry
compute-liveness compute-predecessors
dup reverse-post-order compute-liveness
{ { int-regs regs } } (linear-scan) dup reverse-post-order
flatten-cfg 1array mr. ; { { int-regs regs } } (linear-scan)
flatten-cfg 1array mr.
] with-scope ;
! This test has a critical edge -- do we care about these? ! This test has a critical edge -- do we care about these?
@ -2101,3 +2083,455 @@ V{
5 get 1vector 3 get (>>successors) 5 get 1vector 3 get (>>successors)
[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
! Reduction of push-all regression, x86-32
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
T{ ##load-immediate { dst V int-regs 61 } }
T{ ##peek { dst V int-regs 62 } { loc D 0 } }
T{ ##peek { dst V int-regs 64 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 69 }
{ obj V int-regs 64 }
{ slot 1 }
{ tag 2 }
}
T{ ##copy { dst V int-regs 79 } { src V int-regs 69 } }
T{ ##slot-imm
{ dst V int-regs 85 }
{ obj V int-regs 62 }
{ slot 2 }
{ tag 7 }
}
T{ ##compare-branch
{ src1 V int-regs 69 }
{ src2 V int-regs 85 }
{ cc cc> }
}
} 1 test-bb
V{
T{ ##slot-imm
{ dst V int-regs 97 }
{ obj V int-regs 62 }
{ slot 2 }
{ tag 7 }
}
T{ ##replace { src V int-regs 79 } { loc D 3 } }
T{ ##replace { src V int-regs 62 } { loc D 4 } }
T{ ##replace { src V int-regs 79 } { loc D 1 } }
T{ ##replace { src V int-regs 62 } { loc D 2 } }
T{ ##replace { src V int-regs 61 } { loc D 5 } }
T{ ##replace { src V int-regs 62 } { loc R 0 } }
T{ ##replace { src V int-regs 69 } { loc R 1 } }
T{ ##replace { src V int-regs 97 } { loc D 0 } }
T{ ##call { word resize-array } }
T{ ##branch }
} 2 test-bb
V{
T{ ##peek { dst V int-regs 98 } { loc R 0 } }
T{ ##peek { dst V int-regs 100 } { loc D 0 } }
T{ ##set-slot-imm
{ src V int-regs 100 }
{ obj V int-regs 98 }
{ slot 2 }
{ tag 7 }
}
T{ ##peek { dst V int-regs 108 } { loc D 2 } }
T{ ##peek { dst V int-regs 110 } { loc D 3 } }
T{ ##peek { dst V int-regs 112 } { loc D 0 } }
T{ ##peek { dst V int-regs 114 } { loc D 1 } }
T{ ##peek { dst V int-regs 116 } { loc D 4 } }
T{ ##peek { dst V int-regs 119 } { loc R 0 } }
T{ ##copy { dst V int-regs 109 } { src V int-regs 108 } }
T{ ##copy { dst V int-regs 111 } { src V int-regs 110 } }
T{ ##copy { dst V int-regs 113 } { src V int-regs 112 } }
T{ ##copy { dst V int-regs 115 } { src V int-regs 114 } }
T{ ##copy { dst V int-regs 117 } { src V int-regs 116 } }
T{ ##copy { dst V int-regs 120 } { src V int-regs 119 } }
T{ ##branch }
} 3 test-bb
V{
T{ ##copy { dst V int-regs 109 } { src V int-regs 62 } }
T{ ##copy { dst V int-regs 111 } { src V int-regs 61 } }
T{ ##copy { dst V int-regs 113 } { src V int-regs 62 } }
T{ ##copy { dst V int-regs 115 } { src V int-regs 79 } }
T{ ##copy { dst V int-regs 117 } { src V int-regs 64 } }
T{ ##copy { dst V int-regs 120 } { src V int-regs 69 } }
T{ ##branch }
} 4 test-bb
V{
T{ ##replace { src V int-regs 120 } { loc D 0 } }
T{ ##replace { src V int-regs 109 } { loc D 3 } }
T{ ##replace { src V int-regs 111 } { loc D 4 } }
T{ ##replace { src V int-regs 113 } { loc D 1 } }
T{ ##replace { src V int-regs 115 } { loc D 2 } }
T{ ##replace { src V int-regs 117 } { loc D 5 } }
T{ ##epilogue }
T{ ##return }
} 5 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 4 get V{ } 2sequence >>successors drop
2 get 3 get 1vector >>successors drop
3 get 5 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
! Another reduction of push-all
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
T{ ##peek { dst V int-regs 85 } { loc D 0 } }
T{ ##slot-imm
{ dst V int-regs 89 }
{ obj V int-regs 85 }
{ slot 3 }
{ tag 7 }
}
T{ ##peek { dst V int-regs 91 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 96 }
{ obj V int-regs 91 }
{ slot 1 }
{ tag 2 }
}
T{ ##add
{ dst V int-regs 109 }
{ src1 V int-regs 89 }
{ src2 V int-regs 96 }
}
T{ ##slot-imm
{ dst V int-regs 115 }
{ obj V int-regs 85 }
{ slot 2 }
{ tag 7 }
}
T{ ##slot-imm
{ dst V int-regs 118 }
{ obj V int-regs 115 }
{ slot 1 }
{ tag 2 }
}
T{ ##compare-branch
{ src1 V int-regs 109 }
{ src2 V int-regs 118 }
{ cc cc> }
}
} 1 test-bb
V{
T{ ##add-imm
{ dst V int-regs 128 }
{ src1 V int-regs 109 }
{ src2 8 }
}
T{ ##load-immediate { dst V int-regs 129 } { val 24 } }
T{ ##inc-d { n 4 } }
T{ ##inc-r { n 1 } }
T{ ##replace { src V int-regs 109 } { loc D 2 } }
T{ ##replace { src V int-regs 85 } { loc D 3 } }
T{ ##replace { src V int-regs 128 } { loc D 0 } }
T{ ##replace { src V int-regs 85 } { loc D 1 } }
T{ ##replace { src V int-regs 89 } { loc D 4 } }
T{ ##replace { src V int-regs 96 } { loc R 0 } }
T{ ##fixnum-mul
{ src1 V int-regs 128 }
{ src2 V int-regs 129 }
{ temp1 V int-regs 132 }
{ temp2 V int-regs 133 }
}
T{ ##branch }
} 2 test-bb
V{
T{ ##peek { dst V int-regs 134 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 140 }
{ obj V int-regs 134 }
{ slot 2 }
{ tag 7 }
}
T{ ##inc-d { n 1 } }
T{ ##inc-r { n 1 } }
T{ ##replace { src V int-regs 140 } { loc D 0 } }
T{ ##replace { src V int-regs 134 } { loc R 0 } }
T{ ##call { word resize-array } }
T{ ##branch }
} 3 test-bb
V{
T{ ##peek { dst V int-regs 141 } { loc R 0 } }
T{ ##peek { dst V int-regs 143 } { loc D 0 } }
T{ ##set-slot-imm
{ src V int-regs 143 }
{ obj V int-regs 141 }
{ slot 2 }
{ tag 7 }
}
T{ ##write-barrier
{ src V int-regs 141 }
{ card# V int-regs 145 }
{ table V int-regs 146 }
}
T{ ##inc-d { n -1 } }
T{ ##inc-r { n -1 } }
T{ ##peek { dst V int-regs 156 } { loc D 2 } }
T{ ##peek { dst V int-regs 158 } { loc D 3 } }
T{ ##peek { dst V int-regs 160 } { loc D 0 } }
T{ ##peek { dst V int-regs 162 } { loc D 1 } }
T{ ##peek { dst V int-regs 164 } { loc D 4 } }
T{ ##peek { dst V int-regs 167 } { loc R 0 } }
T{ ##copy { dst V int-regs 157 } { src V int-regs 156 } }
T{ ##copy { dst V int-regs 159 } { src V int-regs 158 } }
T{ ##copy { dst V int-regs 161 } { src V int-regs 160 } }
T{ ##copy { dst V int-regs 163 } { src V int-regs 162 } }
T{ ##copy { dst V int-regs 165 } { src V int-regs 164 } }
T{ ##copy { dst V int-regs 168 } { src V int-regs 167 } }
T{ ##branch }
} 4 test-bb
V{
T{ ##inc-d { n 3 } }
T{ ##inc-r { n 1 } }
T{ ##copy { dst V int-regs 157 } { src V int-regs 85 } }
T{ ##copy { dst V int-regs 159 } { src V int-regs 89 } }
T{ ##copy { dst V int-regs 161 } { src V int-regs 85 } }
T{ ##copy { dst V int-regs 163 } { src V int-regs 109 } }
T{ ##copy { dst V int-regs 165 } { src V int-regs 91 } }
T{ ##copy { dst V int-regs 168 } { src V int-regs 96 } }
T{ ##branch }
} 5 test-bb
V{
T{ ##set-slot-imm
{ src V int-regs 163 }
{ obj V int-regs 161 }
{ slot 3 }
{ tag 7 }
}
T{ ##inc-d { n 1 } }
T{ ##inc-r { n -1 } }
T{ ##replace { src V int-regs 168 } { loc D 0 } }
T{ ##replace { src V int-regs 157 } { loc D 3 } }
T{ ##replace { src V int-regs 159 } { loc D 4 } }
T{ ##replace { src V int-regs 161 } { loc D 1 } }
T{ ##replace { src V int-regs 163 } { loc D 2 } }
T{ ##replace { src V int-regs 165 } { loc D 5 } }
T{ ##epilogue }
T{ ##return }
} 6 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 5 get V{ } 2sequence >>successors drop
2 get 3 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 6 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
! Another push-all reduction to demonstrate numbering anamoly
V{ T{ ##prologue } T{ ##branch } }
0 test-bb
V{
T{ ##peek { dst V int-regs 1 } { loc D 0 } }
T{ ##slot-imm
{ dst V int-regs 5 }
{ obj V int-regs 1 }
{ slot 3 }
{ tag 7 }
}
T{ ##peek { dst V int-regs 7 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 12 }
{ obj V int-regs 7 }
{ slot 1 }
{ tag 6 }
}
T{ ##add
{ dst V int-regs 25 }
{ src1 V int-regs 5 }
{ src2 V int-regs 12 }
}
T{ ##compare-branch
{ src1 V int-regs 25 }
{ src2 V int-regs 5 }
{ cc cc> }
}
}
1 test-bb
V{
T{ ##slot-imm
{ dst V int-regs 41 }
{ obj V int-regs 1 }
{ slot 2 }
{ tag 7 }
}
T{ ##slot-imm
{ dst V int-regs 44 }
{ obj V int-regs 41 }
{ slot 1 }
{ tag 6 }
}
T{ ##compare-branch
{ src1 V int-regs 25 }
{ src2 V int-regs 44 }
{ cc cc> }
}
}
2 test-bb
V{
T{ ##add-imm
{ dst V int-regs 54 }
{ src1 V int-regs 25 }
{ src2 8 }
}
T{ ##load-immediate { dst V int-regs 55 } { val 24 } }
T{ ##inc-d { n 4 } }
T{ ##inc-r { n 1 } }
T{ ##replace { src V int-regs 25 } { loc D 2 } }
T{ ##replace { src V int-regs 1 } { loc D 3 } }
T{ ##replace { src V int-regs 5 } { loc D 4 } }
T{ ##replace { src V int-regs 1 } { loc D 1 } }
T{ ##replace { src V int-regs 54 } { loc D 0 } }
T{ ##replace { src V int-regs 12 } { loc R 0 } }
T{ ##fixnum-mul
{ src1 V int-regs 54 }
{ src2 V int-regs 55 }
{ temp1 V int-regs 58 }
{ temp2 V int-regs 59 }
}
T{ ##branch }
}
3 test-bb
V{
T{ ##peek { dst V int-regs 60 } { loc D 1 } }
T{ ##slot-imm
{ dst V int-regs 66 }
{ obj V int-regs 60 }
{ slot 2 }
{ tag 7 }
}
T{ ##inc-d { n 1 } }
T{ ##inc-r { n 1 } }
T{ ##replace { src V int-regs 66 } { loc D 0 } }
T{ ##replace { src V int-regs 60 } { loc R 0 } }
T{ ##call { word resize-string } }
T{ ##branch }
}
4 test-bb
V{
T{ ##peek { dst V int-regs 67 } { loc R 0 } }
T{ ##peek { dst V int-regs 68 } { loc D 0 } }
T{ ##set-slot-imm
{ src V int-regs 68 }
{ obj V int-regs 67 }
{ slot 2 }
{ tag 7 }
}
T{ ##write-barrier
{ src V int-regs 67 }
{ card# V int-regs 75 }
{ table V int-regs 76 }
}
T{ ##inc-d { n -1 } }
T{ ##inc-r { n -1 } }
T{ ##peek { dst V int-regs 94 } { loc D 0 } }
T{ ##peek { dst V int-regs 96 } { loc D 1 } }
T{ ##peek { dst V int-regs 98 } { loc D 2 } }
T{ ##peek { dst V int-regs 100 } { loc D 3 } }
T{ ##peek { dst V int-regs 102 } { loc D 4 } }
T{ ##peek { dst V int-regs 106 } { loc R 0 } }
T{ ##copy { dst V int-regs 95 } { src V int-regs 94 } }
T{ ##copy { dst V int-regs 97 } { src V int-regs 96 } }
T{ ##copy { dst V int-regs 99 } { src V int-regs 98 } }
T{ ##copy { dst V int-regs 101 } { src V int-regs 100 } }
T{ ##copy { dst V int-regs 103 } { src V int-regs 102 } }
T{ ##copy { dst V int-regs 107 } { src V int-regs 106 } }
T{ ##branch }
}
5 test-bb
V{
T{ ##inc-d { n 3 } }
T{ ##inc-r { n 1 } }
T{ ##copy { dst V int-regs 95 } { src V int-regs 1 } }
T{ ##copy { dst V int-regs 97 } { src V int-regs 25 } }
T{ ##copy { dst V int-regs 99 } { src V int-regs 1 } }
T{ ##copy { dst V int-regs 101 } { src V int-regs 5 } }
T{ ##copy { dst V int-regs 103 } { src V int-regs 7 } }
T{ ##copy { dst V int-regs 107 } { src V int-regs 12 } }
T{ ##branch }
}
6 test-bb
V{
T{ ##load-immediate
{ dst V int-regs 78 }
{ val 4611686018427387896 }
}
T{ ##and
{ dst V int-regs 81 }
{ src1 V int-regs 97 }
{ src2 V int-regs 78 }
}
T{ ##set-slot-imm
{ src V int-regs 81 }
{ obj V int-regs 95 }
{ slot 3 }
{ tag 7 }
}
T{ ##inc-d { n -2 } }
T{ ##copy { dst V int-regs 110 } { src V int-regs 99 } }
T{ ##copy { dst V int-regs 111 } { src V int-regs 101 } }
T{ ##copy { dst V int-regs 112 } { src V int-regs 103 } }
T{ ##copy { dst V int-regs 117 } { src V int-regs 107 } }
T{ ##branch }
}
7 test-bb
V{
T{ ##inc-d { n 1 } }
T{ ##inc-r { n 1 } }
T{ ##copy { dst V int-regs 110 } { src V int-regs 1 } }
T{ ##copy { dst V int-regs 111 } { src V int-regs 5 } }
T{ ##copy { dst V int-regs 112 } { src V int-regs 7 } }
T{ ##copy { dst V int-regs 117 } { src V int-regs 12 } }
T{ ##branch }
}
8 test-bb
V{
T{ ##inc-d { n 1 } }
T{ ##inc-r { n -1 } }
T{ ##replace { src V int-regs 117 } { loc D 0 } }
T{ ##replace { src V int-regs 110 } { loc D 1 } }
T{ ##replace { src V int-regs 111 } { loc D 2 } }
T{ ##replace { src V int-regs 112 } { loc D 3 } }
T{ ##epilogue }
T{ ##return }
}
9 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 8 get V{ } 2sequence >>successors drop
2 get 3 get 6 get V{ } 2sequence >>successors drop
3 get 4 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
5 get 7 get 1vector >>successors drop
6 get 7 get 1vector >>successors drop
7 get 9 get 1vector >>successors drop
8 get 9 get 1vector >>successors drop
[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test

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

@ -31,7 +31,8 @@ IN: compiler.cfg.linear-scan
rpo number-instructions rpo number-instructions
rpo compute-live-intervals machine-registers allocate-registers rpo compute-live-intervals machine-registers allocate-registers
rpo assign-registers rpo assign-registers
rpo resolve-data-flow ; rpo resolve-data-flow
rpo check-numbering ;
: linear-scan ( cfg -- cfg' ) : linear-scan ( cfg -- cfg' )
[ [

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

@ -145,8 +145,7 @@ M: ##copy-float compute-live-intervals*
<reversed> [ compute-live-intervals-step ] each <reversed> [ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ; ] keep values dup finish-live-intervals ;
: relevant-ranges ( new inactive -- new' inactive' ) : relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
! Slice off all ranges of 'inactive' that precede the start of 'new'
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ; [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
: intersect-live-range ( range1 range2 -- n/f ) : intersect-live-range ( range1 range2 -- n/f )
@ -155,8 +154,8 @@ M: ##copy-float compute-live-intervals*
: intersect-live-ranges ( ranges1 ranges2 -- n ) : intersect-live-ranges ( ranges1 ranges2 -- n )
{ {
{ [ over empty? ] [ 2drop 1/0. ] } { [ over empty? ] [ 2drop f ] }
{ [ dup empty? ] [ 2drop 1/0. ] } { [ dup empty? ] [ 2drop f ] }
[ [
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [ 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
drop drop
@ -166,3 +165,6 @@ M: ##copy-float compute-live-intervals*
] if ] if
] ]
} cond ; } cond ;
: intervals-intersect? ( interval1 interval2 -- ? )
relevant-ranges intersect-live-ranges >boolean ; inline

15
basis/compiler/cfg/linear-scan/numbering/numbering.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math sequences ; USING: kernel accessors math sequences grouping namespaces ;
IN: compiler.cfg.linear-scan.numbering IN: compiler.cfg.linear-scan.numbering
: number-instructions ( rpo -- ) : number-instructions ( rpo -- )
@ -8,4 +8,15 @@ IN: compiler.cfg.linear-scan.numbering
instructions>> [ instructions>> [
[ (>>insn#) ] [ drop 2 + ] 2bi [ (>>insn#) ] [ drop 2 + ] 2bi
] each ] each
] each drop ; ] each drop ;
SYMBOL: check-numbering?
ERROR: bad-numbering bb ;
: check-block-numbering ( bb -- )
dup instructions>> [ insn#>> ] map sift [ <= ] monotonic?
[ drop ] [ bad-numbering ] if ;
: check-numbering ( rpo -- )
check-numbering? get [ [ check-block-numbering ] each ] [ drop ] if ;

2
basis/functors/functors.factor
View File

@ -121,6 +121,8 @@ PRIVATE>
SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ;
SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ; SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;

26
basis/specialized-vectors/functor/functor.factor
View File

@ -1,37 +1,25 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private growable USING: functors sequences sequences.private growable
prettyprint.custom kernel words classes math parser ; prettyprint.custom kernel words classes math parser ;
QUALIFIED: vectors.functor
IN: specialized-vectors.functor IN: specialized-vectors.functor
FUNCTOR: define-vector ( T -- ) FUNCTOR: define-vector ( T -- )
V DEFINES-CLASS ${T}-vector
A IS ${T}-array A IS ${T}-array
<A> IS <${A}> <A> IS <${A}>
V DEFINES-CLASS ${T}-vector >V DEFERS >${V}
<V> DEFINES <${V}>
>V DEFINES >${V}
V{ DEFINES ${V}{ V{ DEFINES ${V}{
WHERE WHERE
TUPLE: V { underlying A } { length array-capacity } ; V A <A> vectors.functor:define-vector
: <V> ( capacity -- vector ) <A> 0 V boa ; inline M: V contract 2drop ;
M: V like
drop dup V instance? [
dup A instance? [ dup length V boa ] [ >V ] if
] unless ;
M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
M: A new-resizable drop <V> ;
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
: >V ( seq -- vector ) V new clone-like ; inline
M: V pprint-delims drop \ V{ \ } ; M: V pprint-delims drop \ V{ \ } ;

6
basis/struct-arrays/struct-arrays-tests.factor
View File

@ -1,6 +1,6 @@
IN: struct-arrays.tests IN: struct-arrays.tests
USING: struct-arrays tools.test kernel math sequences USING: struct-arrays tools.test kernel math sequences
alien.syntax alien.c-types destructors libc accessors ; alien.syntax alien.c-types destructors libc accessors sequences.private ;
C-STRUCT: test-struct C-STRUCT: test-struct
{ "int" "x" } { "int" "x" }
@ -35,4 +35,6 @@ C-STRUCT: test-struct
10 "test-struct" malloc-struct-array 10 "test-struct" malloc-struct-array
&free drop &free drop
] with-destructors ] with-destructors
] unit-test ] unit-test
[ 15 ] [ 15 10 "test-struct" <struct-array> resize length ] unit-test

5
basis/struct-arrays/struct-arrays.factor
View File

@ -10,6 +10,7 @@ TUPLE: struct-array
{ element-size array-capacity read-only } ; { element-size array-capacity read-only } ;
M: struct-array length length>> ; M: struct-array length length>> ;
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ;
M: struct-array nth-unsafe M: struct-array nth-unsafe
[ element-size>> * ] [ underlying>> ] bi <displaced-alien> ; [ element-size>> * ] [ underlying>> ] bi <displaced-alien> ;
@ -20,6 +21,10 @@ M: struct-array set-nth-unsafe
M: struct-array new-sequence M: struct-array new-sequence
element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline
M: struct-array resize ( n seq -- newseq )
[ [ element-size>> * ] [ underlying>> ] bi resize ] [ element-size>> ] 2bi
struct-array boa ;
: <struct-array> ( length c-type -- struct-array ) : <struct-array> ( length c-type -- struct-array )
heap-size [ * <byte-array> ] 2keep struct-array boa ; inline heap-size [ * <byte-array> ] 2keep struct-array boa ; inline

16
basis/struct-vectors/struct-vectors-docs.factor Normal file
View File

@ -0,0 +1,16 @@
IN: struct-vectors
USING: help.markup help.syntax alien strings math ;
HELP: struct-vector
{ $class-description "The class of growable C struct and union arrays." } ;
HELP: <struct-vector>
{ $values { "capacity" integer } { "c-type" string } { "struct-vector" struct-vector } }
{ $description "Creates a new vector with the given initial capacity." } ;
ARTICLE: "struct-vectors" "C struct and union vectors"
"The " { $vocab-link "struct-vectors" } " vocabulary implements vectors specialized for holding C struct and union values. These are growable versions of " { $vocab-link "struct-arrays" } "."
{ $subsection struct-vector }
{ $subsection <struct-vector> } ;
ABOUT: "struct-vectors"

21
basis/struct-vectors/struct-vectors-tests.factor Normal file
View File

@ -0,0 +1,21 @@
IN: struct-vectors.tests
USING: struct-vectors tools.test alien.c-types alien.syntax
namespaces kernel sequences ;
C-STRUCT: point
{ "float" "x" }
{ "float" "y" } ;
: make-point ( x y -- point )
"point" <c-object>
[ set-point-y ] keep
[ set-point-x ] keep ;
[ ] [ 1 "point" <struct-vector> "v" set ] unit-test
[ 1.5 6.0 ] [
1.0 2.0 make-point "v" get push
3.0 4.5 make-point "v" get push
1.5 6.0 make-point "v" get push
"v" get pop [ point-x ] [ point-y ] bi
] unit-test

24
basis/struct-vectors/struct-vectors.factor Normal file
View File

@ -0,0 +1,24 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types byte-arrays growable kernel math sequences
sequences.private struct-arrays ;
IN: struct-vectors
TUPLE: struct-vector
{ underlying struct-array }
{ length array-capacity }
{ c-type read-only } ;
: <struct-vector> ( capacity c-type -- struct-vector )
[ <struct-array> 0 ] keep struct-vector boa ; inline
M: struct-vector byte-length underlying>> byte-length ;
M: struct-vector new-sequence
[ c-type>> <struct-array> ] [ [ >fixnum ] [ c-type>> ] bi* ] 2bi
struct-vector boa ;
M: struct-vector contract 2drop ;
M: struct-array new-resizable c-type>> <struct-vector> ;
INSTANCE: struct-vector growable

10
basis/threads/threads.factor
View File

@ -43,13 +43,15 @@ sleep-entry ;
: thread-registered? ( thread -- ? ) : thread-registered? ( thread -- ? )
id>> threads key? ; id>> threads key? ;
ERROR: already-stopped thread ;
: check-unregistered ( thread -- thread ) : check-unregistered ( thread -- thread )
dup thread-registered? dup thread-registered? [ already-stopped ] when ;
[ "Thread already stopped" throw ] when ;
ERROR: not-running thread ;
: check-registered ( thread -- thread ) : check-registered ( thread -- thread )
dup thread-registered? dup thread-registered? [ not-running ] unless ;
[ "Thread is not running" throw ] unless ;
<PRIVATE <PRIVATE

1
basis/ui/tools/tools.factor
View File

@ -26,7 +26,6 @@ tool "tool-switching" f {
} define-command-map } define-command-map
tool "common" f { tool "common" f {
{ T{ key-down f { A+ } "s" } save }
{ T{ key-down f { A+ } "w" } close-window } { T{ key-down f { A+ } "w" } close-window }
{ T{ key-down f { A+ } "q" } com-exit } { T{ key-down f { A+ } "q" } com-exit }
{ T{ key-down f f "F2" } refresh-all } { T{ key-down f f "F2" } refresh-all }

33
basis/vectors/functor/functor.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private growable
kernel words classes math parser ;
IN: vectors.functor
FUNCTOR: define-vector ( V A <A> -- )
<V> DEFINES <${V}>
>V DEFINES >${V}
WHERE
TUPLE: V { underlying A } { length array-capacity } ;
: <V> ( capacity -- vector ) <A> 0 V boa ; inline
M: V like
drop dup V instance? [
dup A instance? [ dup length V boa ] [ >V ] if
] unless ;
M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
M: A new-resizable drop <V> ;
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
: >V ( seq -- vector ) V new clone-like ; inline
INSTANCE: V growable
;FUNCTOR

2
core/byte-vectors/byte-vectors.factor
View File

@ -26,6 +26,8 @@ M: byte-vector new-sequence
M: byte-vector equal? M: byte-vector equal?
over byte-vector? [ sequence= ] [ 2drop f ] if ; over byte-vector? [ sequence= ] [ 2drop f ] if ;
M: byte-vector contract 2drop ;
M: byte-array like M: byte-array like
#! If we have an byte-array, we're done. #! If we have an byte-array, we're done.
#! If we have a byte-vector, and it's at full capacity, #! If we have a byte-vector, and it's at full capacity,

8
core/growable/growable.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private USING: accessors kernel kernel.private math math.private
sequences sequences.private ; sequences sequences.private ;
@ -18,10 +18,12 @@ M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
: expand ( len seq -- ) : expand ( len seq -- )
[ resize ] change-underlying drop ; inline [ resize ] change-underlying drop ; inline
: contract ( len seq -- ) GENERIC: contract ( len seq -- )
M: growable contract ( len seq -- )
[ length ] keep [ length ] keep
[ [ 0 ] 2dip set-nth-unsafe ] curry [ [ 0 ] 2dip set-nth-unsafe ] curry
(each-integer) ; inline (each-integer) ;
: growable-check ( n seq -- n seq ) : growable-check ( n seq -- n seq )
over 0 < [ bounds-error ] when ; inline over 0 < [ bounds-error ] when ; inline

2
core/sequences/sequences-docs.factor
View File

@ -1107,7 +1107,7 @@ HELP: replicate
{ "newseq" sequence } } { "newseq" sequence } }
{ $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the input sequence." } { $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the input sequence." }
{ $examples { $examples
{ $unchecked-example "USING: prettyprint kernel sequences ;" { $unchecked-example "USING: kernel prettyprint random sequences ;"
"5 [ 100 random ] replicate ." "5 [ 100 random ] replicate ."
"{ 52 10 45 81 30 }" "{ 52 10 45 81 30 }"
} }

1
extra/benchmark/hashtables/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

75
extra/benchmark/hashtables/hashtables.factor Normal file
View File

@ -0,0 +1,75 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators kernel locals math
math.ranges memoize sequences strings hashtables
math.parser grouping ;
IN: benchmark.hashtables
MEMO: strings ( -- str )
1 100 [a,b] 1 [ + ] accumulate nip [ number>string ] map ;
:: add-delete-mix ( hash keys -- )
keys [| k |
0 k hash set-at
k hash delete-at
] each
keys [
0 swap hash set-at
] each
keys [
hash delete-at
] each ;
:: store-lookup-mix ( hash keys -- )
keys [
0 swap hash set-at
] each
keys [
hash at
] map drop
keys [
hash [ 1 + ] change-at
] each ;
: string-mix ( hash -- )
strings
[ add-delete-mix ]
[ store-lookup-mix ]
2bi ;
TUPLE: collision value ;
M: collision hashcode* value>> hashcode* 15 bitand ;
: collision-mix ( hash -- )
strings 30 head [ collision boa ] map
[ add-delete-mix ]
[ store-lookup-mix ]
2bi ;
: small-mix ( hash -- )
strings 10 group [
[ add-delete-mix ]
[ store-lookup-mix ]
2bi
] with each ;
: hashtable-benchmark ( -- )
H{ } clone
10000 [
dup {
[ small-mix ]
[ clear-assoc ]
[ string-mix ]
[ clear-assoc ]
[ collision-mix ]
[ clear-assoc ]
} cleave
] times
drop ;
MAIN: hashtable-benchmark