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

Merge branch 'inlinec' into marshall 

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

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

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

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

@ -22,11 +22,11 @@ HELP: bit-vector
{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
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{

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

@ -1,38 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 ;

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

@ -9,11 +9,6 @@ compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.state ;
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* ;

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

@ -9,15 +9,15 @@ IN: compiler.cfg.linear-scan.allocation.coalescing
: active-interval ( vreg -- live-interval )
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 -- )

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

@ -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 ;

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

@ -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

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

@ -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 ;

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

@ -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

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

@ -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 )

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

@ -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

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

@ -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' )
[

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

@ -145,8 +145,7 @@ M: ##copy-float compute-live-intervals*
<reversed> [ compute-live-intervals-step ] each
] 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

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

@ -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 ;

2
basis/functors/functors.factor
View File

@ -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) ;

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

@ -1,37 +1,25 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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{ \ } ;

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

@ -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

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

@ -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

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

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

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

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

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

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

10
basis/threads/threads.factor
View File

@ -43,13 +43,15 @@ sleep-entry ;
: thread-registered? ( thread -- ? )
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

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

@ -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 }

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

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

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

@ -26,6 +26,8 @@ M: byte-vector new-sequence
M: byte-vector equal?
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,

8
core/growable/growable.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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

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

@ -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 }"
}

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

@ -0,0 +1 @@
Slava Pestov

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

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