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 spilleddb4
commit
7d708a17c2
|
@ -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 ;
|
||||||
|
|
|
@ -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{
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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* ;
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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 ;
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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
|
|
@ -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' )
|
||||||
[
|
[
|
||||||
|
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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) ;
|
||||||
|
|
|
@ -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{ \ } ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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"
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 }
|
||||||
|
|
|
@ -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
|
|
@ -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,
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 }"
|
||||||
}
|
}
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -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
|
Loading…
Reference in New Issue