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
Jeremy Hughes
commit
7d708a17c2
basis
alien/inline
bit-vectors
compiler/cfg/linear-scan
allocation
coalescing
spilling
splitting
state
assignment
debugger
live-intervals
numbering
functors
specialized-vectors/functor
struct-arrays
threads
ui/tools
vectors/functor
core
extra/benchmark/hashtables
|
|
@ -130,3 +130,6 @@ SYNTAX: C-STRUCTURE:
|
|||
SYNTAX: ;C-LIBRARY compile-c-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." } ;
|
||||
|
||||
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." } ;
|
||||
|
||||
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." } ;
|
||||
|
||||
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.
|
||||
USING: arrays kernel kernel.private math sequences
|
||||
sequences.private growable bit-arrays prettyprint.custom
|
||||
parser accessors ;
|
||||
parser accessors vectors.functor classes.parser ;
|
||||
IN: bit-vectors
|
||||
|
||||
TUPLE: bit-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
|
||||
<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
|
||||
|
||||
SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
|
||||
|
||||
M: bit-vector contract 2drop ;
|
||||
M: bit-vector >pprint-sequence ;
|
||||
M: bit-vector pprint-delims drop \ ?V{ \ } ;
|
||||
M: bit-vector pprint* pprint-object ;
|
||||
|
|
|
|||
|
|
@ -9,11 +9,6 @@ compiler.cfg.linear-scan.allocation.splitting
|
|||
compiler.cfg.linear-scan.allocation.state ;
|
||||
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 -- )
|
||||
[ vreg>> active-intervals-for ] dip
|
||||
'[ [ 0 ] dip reg>> _ add-use-position ] each ;
|
||||
|
|
@ -21,7 +16,7 @@ IN: compiler.cfg.linear-scan.allocation
|
|||
: inactive-positions ( new assoc -- )
|
||||
[ [ 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
|
||||
] each ;
|
||||
|
||||
|
|
@ -33,12 +28,6 @@ IN: compiler.cfg.linear-scan.allocation
|
|||
: no-free-registers? ( result -- ? )
|
||||
second 0 = ; inline
|
||||
|
||||
: register-available? ( new result -- ? )
|
||||
[ end>> ] [ second ] bi* < ; inline
|
||||
|
||||
: register-available ( new result -- )
|
||||
first >>reg add-active ;
|
||||
|
||||
: register-partially-available ( new result -- )
|
||||
[ second split-before-use ] keep
|
||||
'[ _ register-available ] [ add-unhandled ] bi* ;
|
||||
|
|
|
|||
|
|
@ -9,15 +9,15 @@ IN: compiler.cfg.linear-scan.allocation.coalescing
|
|||
: active-interval ( vreg -- live-interval )
|
||||
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
|
||||
[ relevant-ranges intersect-live-ranges 1/0. = ] with all? ;
|
||||
[ intervals-intersect? not ] with all? ;
|
||||
|
||||
: coalesce? ( live-interval -- ? )
|
||||
{
|
||||
[ copy-from>> active-interval ]
|
||||
[ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
|
||||
[ intersects-inactive-intervals? ]
|
||||
[ avoids-inactive-intervals? ]
|
||||
} 1&& ;
|
||||
|
||||
: coalesce ( live-interval -- )
|
||||
|
|
|
|||
|
|
@ -1,23 +1,13 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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.splitting
|
||||
compiler.cfg.linear-scan.live-intervals ;
|
||||
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 ;
|
||||
|
||||
: check-ranges ( live-interval -- )
|
||||
|
|
@ -47,52 +37,108 @@ ERROR: bad-live-ranges interval ;
|
|||
[ ]
|
||||
} 2cleave ;
|
||||
|
||||
: assign-spill ( live-interval -- live-interval )
|
||||
dup vreg>> assign-spill-slot >>spill-to ;
|
||||
: assign-spill ( live-interval -- )
|
||||
dup vreg>> assign-spill-slot >>spill-to drop ;
|
||||
|
||||
: assign-reload ( before after -- before after )
|
||||
over spill-to>> >>reload-from ;
|
||||
: assign-reload ( live-interval -- )
|
||||
dup vreg>> assign-spill-slot >>reload-from drop ;
|
||||
|
||||
: split-and-spill ( new existing -- before after )
|
||||
swap start>> split-for-spill [ assign-spill ] dip assign-reload ;
|
||||
: split-and-spill ( live-interval n -- before after )
|
||||
split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;
|
||||
|
||||
: reuse-register ( new existing -- )
|
||||
[ nip delete-active ]
|
||||
[ reg>> >>reg add-active ] 2bi ;
|
||||
: find-use-position ( live-interval new -- n )
|
||||
[ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
|
||||
|
||||
: spill-existing? ( new existing -- ? )
|
||||
#! Test if 'new' will be used before 'existing'.
|
||||
over start>> '[ _ [ > ] find-use -1 or ] bi@ < ;
|
||||
: find-use-positions ( live-intervals new assoc -- )
|
||||
'[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
|
||||
|
||||
: spill-existing ( new existing -- )
|
||||
#! Our new interval will be used before the active interval
|
||||
#! with the most distant use location. Spill the existing
|
||||
#! 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 ;
|
||||
: active-positions ( new assoc -- )
|
||||
[ [ vreg>> active-intervals-for ] keep ] dip
|
||||
find-use-positions ;
|
||||
|
||||
: spill-live-out? ( new existing -- ? )
|
||||
[ start>> ] [ uses>> last ] bi* > ;
|
||||
: inactive-positions ( new assoc -- )
|
||||
[
|
||||
[ vreg>> inactive-intervals-for ] keep
|
||||
[ '[ _ intervals-intersect? ] filter ] keep
|
||||
] dip
|
||||
find-use-positions ;
|
||||
|
||||
: spill-live-out ( new existing -- )
|
||||
#! The existing interval is never used again. Spill it and
|
||||
#! re-use the register.
|
||||
assign-spill
|
||||
[ reuse-register ]
|
||||
[ nip add-handled ] 2bi ;
|
||||
: spill-status ( new -- use-pos )
|
||||
H{ } clone
|
||||
[ inactive-positions ] [ active-positions ] [ nip ] 2tri
|
||||
>alist alist-max ;
|
||||
|
||||
: spill-new ( new existing -- )
|
||||
#! Our new interval will be used after the active interval
|
||||
#! 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 ;
|
||||
: spill-new? ( new pair -- ? )
|
||||
[ uses>> first ] [ second ] bi* > ;
|
||||
|
||||
: assign-blocked-register ( new -- )
|
||||
[ dup vreg>> active-intervals-for ] keep interval-to-spill {
|
||||
{ [ 2dup spill-live-out? ] [ spill-live-out ] }
|
||||
{ [ 2dup spill-existing? ] [ spill-existing ] }
|
||||
[ spill-new ]
|
||||
: spill-new ( new pair -- )
|
||||
drop
|
||||
{
|
||||
[ trim-after-ranges ]
|
||||
[ 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 ;
|
||||
|
||||
: (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.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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.live-intervals ;
|
||||
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-late ;
|
||||
|
||||
ERROR: splitting-atomic-interval ;
|
||||
|
||||
: check-split ( live-interval n -- )
|
||||
[ [ start>> ] dip > [ splitting-too-early ] when ]
|
||||
[ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ]
|
||||
2bi ; inline
|
||||
check-allocation? get [
|
||||
[ [ start>> ] dip > [ splitting-too-early ] when ]
|
||||
[ [ end>> ] dip <= [ splitting-too-late ] when ]
|
||||
[ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
|
||||
2tri
|
||||
] [ 2drop ] if ; inline
|
||||
|
||||
: split-before ( before -- before' )
|
||||
f >>spill-to ; inline
|
||||
|
|
|
|||
|
|
@ -1,10 +1,24 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 ;
|
||||
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
|
||||
SYMBOL: registers
|
||||
|
||||
|
|
@ -32,11 +46,14 @@ SYMBOL: inactive-intervals
|
|||
: add-inactive ( live-interval -- )
|
||||
dup vreg>> inactive-intervals-for push ;
|
||||
|
||||
: delete-inactive ( live-interval -- )
|
||||
dup vreg>> inactive-intervals-for delq ;
|
||||
|
||||
! Vector of handled live intervals
|
||||
SYMBOL: handled-intervals
|
||||
|
||||
: add-handled ( live-interval -- )
|
||||
handled-intervals get push ;
|
||||
[ check-handled ] [ handled-intervals get push ] bi ;
|
||||
|
||||
: 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
|
||||
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 -- )
|
||||
[ check-progress ]
|
||||
[ check-unhandled ]
|
||||
[ dup start>> unhandled-intervals get heap-push ]
|
||||
bi ;
|
||||
|
||||
|
|
@ -133,4 +141,16 @@ SYMBOL: spill-slots
|
|||
|
||||
: init-unhandled ( live-intervals -- )
|
||||
[ [ 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
|
||||
fry make combinators sets locals
|
||||
cpu.architecture
|
||||
compiler.cfg
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.linear-scan.allocation
|
||||
|
|
@ -27,12 +29,6 @@ SYMBOL: unhandled-intervals
|
|||
: init-unhandled ( live-intervals -- )
|
||||
[ 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
|
||||
SYMBOL: register-live-ins
|
||||
|
||||
|
|
@ -42,17 +38,10 @@ SYMBOL: register-live-outs
|
|||
: init-assignment ( live-intervals -- )
|
||||
V{ } clone pending-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-outs set
|
||||
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 -- )
|
||||
{
|
||||
[ reg>> ]
|
||||
|
|
@ -62,7 +51,7 @@ ERROR: already-spilled ;
|
|||
} cleave f swap \ _spill boa , ;
|
||||
|
||||
: 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' )
|
||||
dup split-before>> [ first-split ] [ ] ?if ;
|
||||
|
|
@ -79,8 +68,7 @@ ERROR: already-spilled ;
|
|||
} cleave f swap \ _copy boa , ;
|
||||
|
||||
: handle-copy ( live-interval -- )
|
||||
dup [ spill-to>> not ] [ split-next>> ] bi and
|
||||
[ insert-copy ] [ drop ] if ;
|
||||
dup split-next>> [ insert-copy ] [ drop ] if ;
|
||||
|
||||
: expire-old-intervals ( n -- )
|
||||
[ pending-intervals get ] dip '[
|
||||
|
|
@ -88,28 +76,22 @@ ERROR: already-spilled ;
|
|||
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
|
||||
] 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 -- )
|
||||
{
|
||||
[ reg>> ]
|
||||
[ vreg>> reg-class>> ]
|
||||
[ reload-from>> ]
|
||||
[ end>> ]
|
||||
[ start>> ]
|
||||
} cleave f swap \ _reload boa , ;
|
||||
|
||||
: 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 -- )
|
||||
#! Any live intervals which start on the current instruction
|
||||
#! are added to the active set.
|
||||
unhandled-intervals get dup heap-empty? [ 2drop ] [
|
||||
2dup heap-peek drop start>> >= [
|
||||
2dup heap-peek drop start>> = [
|
||||
heap-pop drop
|
||||
[ add-active ] [ handle-reload ] bi
|
||||
activate-new-intervals
|
||||
|
|
@ -145,35 +127,43 @@ M: vreg-insn assign-registers-in-insn
|
|||
register-mapping
|
||||
>>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
|
||||
! This works because ##gc is always the first instruction
|
||||
! in a block.
|
||||
dup call-next-method
|
||||
dup compute-live-gc-values >>live-values
|
||||
basic-block get register-live-ins get at >>live-values
|
||||
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 -- )
|
||||
dup basic-block set
|
||||
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 -- )
|
||||
[ 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 ;
|
||||
|
||||
|
|
@ -188,10 +178,12 @@ ERROR: bad-vreg vreg ;
|
|||
[
|
||||
bb begin-block
|
||||
[
|
||||
[ insn#>> prepare-insn ]
|
||||
[ assign-registers-in-insn ]
|
||||
[ , ]
|
||||
tri
|
||||
{
|
||||
[ insn#>> 1 - prepare-insn ]
|
||||
[ insn#>> prepare-insn ]
|
||||
[ assign-registers-in-insn ]
|
||||
[ , ]
|
||||
} cleave
|
||||
] each
|
||||
bb end-block
|
||||
] V{ } make
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences sets arrays math strings fry
|
||||
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
|
||||
|
||||
: check-assigned ( live-intervals -- )
|
||||
|
|
@ -19,7 +19,10 @@ IN: compiler.cfg.linear-scan.debugger
|
|||
] [ 1array ] if ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: picture ( uses -- str )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: compiler.cfg.linear-scan.tests
|
||||
USING: tools.test random sorting sequences sets hashtables assocs
|
||||
kernel fry arrays splitting namespaces math accessors vectors locals
|
||||
math.order grouping
|
||||
math.order grouping strings strings.private
|
||||
cpu.architecture
|
||||
compiler.cfg
|
||||
compiler.cfg.optimizer
|
||||
|
|
@ -13,6 +13,7 @@ compiler.cfg.rpo
|
|||
compiler.cfg.linearization
|
||||
compiler.cfg.debugger
|
||||
compiler.cfg.linear-scan
|
||||
compiler.cfg.linear-scan.numbering
|
||||
compiler.cfg.linear-scan.live-intervals
|
||||
compiler.cfg.linear-scan.allocation
|
||||
compiler.cfg.linear-scan.allocation.state
|
||||
|
|
@ -24,6 +25,7 @@ FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
|
|||
|
||||
check-allocation? on
|
||||
check-assignment? on
|
||||
check-numbering? on
|
||||
|
||||
[
|
||||
{ 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
|
||||
] 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
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
|
|
@ -257,88 +229,82 @@ check-assignment? on
|
|||
] unit-test
|
||||
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ start 3 }
|
||||
{ end 10 }
|
||||
{ uses V{ 3 10 } }
|
||||
{
|
||||
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
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ 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 } }
|
||||
}
|
||||
1
|
||||
1/0.
|
||||
}
|
||||
] [
|
||||
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
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
|
||||
{ vreg T{ vreg { reg-class int-regs } { n 3 } } }
|
||||
{ start 5 }
|
||||
{ end 5 }
|
||||
{ uses V{ 5 } }
|
||||
}
|
||||
interval-to-spill
|
||||
] 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?
|
||||
spill-status
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
@ -1477,6 +1443,20 @@ USING: math.private ;
|
|||
intersect-live-ranges
|
||||
] 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 ] [
|
||||
T{ live-interval
|
||||
{ start 0 }
|
||||
|
|
@ -1605,12 +1585,14 @@ V{
|
|||
SYMBOL: linear-scan-result
|
||||
|
||||
:: test-linear-scan-on-cfg ( regs -- )
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
compute-liveness
|
||||
dup reverse-post-order
|
||||
{ { int-regs regs } } (linear-scan)
|
||||
flatten-cfg 1array mr. ;
|
||||
[
|
||||
cfg new 0 get >>entry
|
||||
compute-predecessors
|
||||
compute-liveness
|
||||
dup reverse-post-order
|
||||
{ { int-regs regs } } (linear-scan)
|
||||
flatten-cfg 1array mr.
|
||||
] with-scope ;
|
||||
|
||||
! This test has a critical edge -- do we care about these?
|
||||
|
||||
|
|
@ -2101,3 +2083,455 @@ V{
|
|||
5 get 1vector 3 get (>>successors)
|
||||
|
||||
[ ] [ { 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 compute-live-intervals machine-registers allocate-registers
|
||||
rpo assign-registers
|
||||
rpo resolve-data-flow ;
|
||||
rpo resolve-data-flow
|
||||
rpo check-numbering ;
|
||||
|
||||
: linear-scan ( cfg -- cfg' )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -145,8 +145,7 @@ M: ##copy-float compute-live-intervals*
|
|||
<reversed> [ compute-live-intervals-step ] each
|
||||
] keep values dup finish-live-intervals ;
|
||||
|
||||
: relevant-ranges ( new inactive -- new' inactive' )
|
||||
! Slice off all ranges of 'inactive' that precede the start of 'new'
|
||||
: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
|
||||
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
|
||||
|
||||
: intersect-live-range ( range1 range2 -- n/f )
|
||||
|
|
@ -155,8 +154,8 @@ M: ##copy-float compute-live-intervals*
|
|||
|
||||
: intersect-live-ranges ( ranges1 ranges2 -- n )
|
||||
{
|
||||
{ [ over empty? ] [ 2drop 1/0. ] }
|
||||
{ [ dup empty? ] [ 2drop 1/0. ] }
|
||||
{ [ over empty? ] [ 2drop f ] }
|
||||
{ [ dup empty? ] [ 2drop f ] }
|
||||
[
|
||||
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
|
||||
drop
|
||||
|
|
@ -166,3 +165,6 @@ M: ##copy-float compute-live-intervals*
|
|||
] if
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: intervals-intersect? ( interval1 interval2 -- ? )
|
||||
relevant-ranges intersect-live-ranges >boolean ; inline
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! 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
|
||||
|
||||
: number-instructions ( rpo -- )
|
||||
|
|
@ -8,4 +8,15 @@ IN: compiler.cfg.linear-scan.numbering
|
|||
instructions>> [
|
||||
[ (>>insn#) ] [ drop 2 + ] 2bi
|
||||
] 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: DEFERS [ current-vocab create ] (INTERPOLATE) ;
|
||||
|
||||
SYNTAX: DEFINES [ create-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.
|
||||
USING: functors sequences sequences.private growable
|
||||
prettyprint.custom kernel words classes math parser ;
|
||||
QUALIFIED: vectors.functor
|
||||
IN: specialized-vectors.functor
|
||||
|
||||
FUNCTOR: define-vector ( T -- )
|
||||
|
||||
V DEFINES-CLASS ${T}-vector
|
||||
|
||||
A IS ${T}-array
|
||||
<A> IS <${A}>
|
||||
|
||||
V DEFINES-CLASS ${T}-vector
|
||||
<V> DEFINES <${V}>
|
||||
>V DEFINES >${V}
|
||||
>V DEFERS >${V}
|
||||
V{ DEFINES ${V}{
|
||||
|
||||
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 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 contract 2drop ;
|
||||
|
||||
M: V pprint-delims drop \ V{ \ } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: struct-arrays.tests
|
||||
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
|
||||
{ "int" "x" }
|
||||
|
|
@ -35,4 +35,6 @@ C-STRUCT: test-struct
|
|||
10 "test-struct" malloc-struct-array
|
||||
&free drop
|
||||
] 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 } ;
|
||||
|
||||
M: struct-array length length>> ;
|
||||
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ;
|
||||
|
||||
M: struct-array nth-unsafe
|
||||
[ element-size>> * ] [ underlying>> ] bi <displaced-alien> ;
|
||||
|
|
@ -20,6 +21,10 @@ M: struct-array set-nth-unsafe
|
|||
M: struct-array new-sequence
|
||||
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 )
|
||||
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 -- ? )
|
||||
id>> threads key? ;
|
||||
|
||||
ERROR: already-stopped thread ;
|
||||
|
||||
: check-unregistered ( thread -- thread )
|
||||
dup thread-registered?
|
||||
[ "Thread already stopped" throw ] when ;
|
||||
dup thread-registered? [ already-stopped ] when ;
|
||||
|
||||
ERROR: not-running thread ;
|
||||
|
||||
: check-registered ( thread -- thread )
|
||||
dup thread-registered?
|
||||
[ "Thread is not running" throw ] unless ;
|
||||
dup thread-registered? [ not-running ] unless ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
|||
|
|
@ -26,7 +26,6 @@ tool "tool-switching" f {
|
|||
} define-command-map
|
||||
|
||||
tool "common" f {
|
||||
{ T{ key-down f { A+ } "s" } save }
|
||||
{ T{ key-down f { A+ } "w" } close-window }
|
||||
{ T{ key-down f { A+ } "q" } com-exit }
|
||||
{ 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?
|
||||
over byte-vector? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: byte-vector contract 2drop ;
|
||||
|
||||
M: byte-array like
|
||||
#! If we have an byte-array, we're done.
|
||||
#! 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.
|
||||
USING: accessors kernel kernel.private math math.private
|
||||
sequences sequences.private ;
|
||||
|
|
@ -18,10 +18,12 @@ M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
|
|||
: expand ( len seq -- )
|
||||
[ resize ] change-underlying drop ; inline
|
||||
|
||||
: contract ( len seq -- )
|
||||
GENERIC: contract ( len seq -- )
|
||||
|
||||
M: growable contract ( len seq -- )
|
||||
[ length ] keep
|
||||
[ [ 0 ] 2dip set-nth-unsafe ] curry
|
||||
(each-integer) ; inline
|
||||
(each-integer) ;
|
||||
|
||||
: growable-check ( n seq -- n seq )
|
||||
over 0 < [ bounds-error ] when ; inline
|
||||
|
|
|
|||
|
|
@ -1107,7 +1107,7 @@ HELP: replicate
|
|||
{ "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." }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: prettyprint kernel sequences ;"
|
||||
{ $unchecked-example "USING: kernel prettyprint random sequences ;"
|
||||
"5 [ 100 random ] replicate ."
|
||||
"{ 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