diff --git a/basis/bit-vectors/bit-vectors-docs.factor b/basis/bit-vectors/bit-vectors-docs.factor index f0e4e47586..66d3d603fe 100644 --- a/basis/bit-vectors/bit-vectors-docs.factor +++ b/basis/bit-vectors/bit-vectors-docs.factor @@ -22,11 +22,11 @@ HELP: bit-vector { $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ; HELP: -{ $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{ diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor index a238f61244..7febe6fc1b 100644 --- a/basis/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -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 } ; - -: ( n -- bit-vector ) - 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 [ ] [ >fixnum ] bi bit-vector boa ; - -M: bit-vector equal? - over bit-vector? [ sequence= ] [ 2drop f ] if ; - -M: bit-array new-resizable drop ; - -INSTANCE: bit-vector growable +<< "bit-vector" create-class-in \ 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 ; diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 4a58064582..7dd3977605 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -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* ; diff --git a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor index b2b9202204..e99c2ba710 100644 --- a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor +++ b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor @@ -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 -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index e5c4b10021..9949832294 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index b2872ace14..71d3d56285 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -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 diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index a17a1181b5..3e646b40f0 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -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 ; \ No newline at end of file + 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 ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 8a9bfa02db..c995569c2e 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -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 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 ] 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 [ ] 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 diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor index be3fb2bea8..a350ee5f43 100644 --- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor @@ -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 ) diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index e3cd9e105f..b5999838ca 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -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 \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 2d3ad41b22..9013389cc9 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -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' ) [ diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 61432eefdf..bf7e8bc042 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -145,8 +145,7 @@ M: ##copy-float compute-live-intervals* [ 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 \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor index 6734f6a359..ac18b0cb2e 100644 --- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -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 ; \ No newline at end of file + ] 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 ; \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index b7dab0d6af..6ffc4d8112 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -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) ; diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 412e5b4689..6635fbeaf2 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -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 IS <${A}> -V DEFINES-CLASS ${T}-vector - DEFINES <${V}> ->V DEFINES >${V} +>V DEFERS >${V} V{ DEFINES ${V}{ WHERE -TUPLE: V { underlying A } { length array-capacity } ; +V A vectors.functor:define-vector -: ( capacity -- vector ) 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 [ ] [ >fixnum ] bi V boa ; - -M: A new-resizable drop ; - -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{ \ } ; diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index 8ce45ccc15..b537f448d5 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -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 \ No newline at end of file +] unit-test + +[ 15 ] [ 15 10 "test-struct" resize length ] unit-test \ No newline at end of file diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index 5aaf2c2ea6..60b9af0f19 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -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 ; @@ -20,6 +21,10 @@ M: struct-array set-nth-unsafe M: struct-array new-sequence element-size>> [ * ] 2keep struct-array boa ; inline +M: struct-array resize ( n seq -- newseq ) + [ [ element-size>> * ] [ underlying>> ] bi resize ] [ element-size>> ] 2bi + struct-array boa ; + : ( length c-type -- struct-array ) heap-size [ * ] 2keep struct-array boa ; inline diff --git a/basis/struct-vectors/struct-vectors-docs.factor b/basis/struct-vectors/struct-vectors-docs.factor new file mode 100644 index 0000000000..368b054565 --- /dev/null +++ b/basis/struct-vectors/struct-vectors-docs.factor @@ -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: +{ $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 } ; + +ABOUT: "struct-vectors" diff --git a/basis/struct-vectors/struct-vectors-tests.factor b/basis/struct-vectors/struct-vectors-tests.factor new file mode 100644 index 0000000000..f57c64152c --- /dev/null +++ b/basis/struct-vectors/struct-vectors-tests.factor @@ -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" + [ set-point-y ] keep + [ set-point-x ] keep ; + +[ ] [ 1 "point" "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 \ No newline at end of file diff --git a/basis/struct-vectors/struct-vectors.factor b/basis/struct-vectors/struct-vectors.factor new file mode 100644 index 0000000000..5a0654ea16 --- /dev/null +++ b/basis/struct-vectors/struct-vectors.factor @@ -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 } ; + +: ( capacity c-type -- struct-vector ) + [ 0 ] keep struct-vector boa ; inline + +M: struct-vector byte-length underlying>> byte-length ; +M: struct-vector new-sequence + [ c-type>> ] [ [ >fixnum ] [ c-type>> ] bi* ] 2bi + struct-vector boa ; + +M: struct-vector contract 2drop ; + +M: struct-array new-resizable c-type>> ; + +INSTANCE: struct-vector growable diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index cacc628e2a..dec44625f7 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -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 ; -- ) + + DEFINES <${V}> +>V DEFINES >${V} + +WHERE + +TUPLE: V { underlying A } { length array-capacity } ; + +: ( capacity -- vector ) 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 [ ] [ >fixnum ] bi V boa ; + +M: A new-resizable drop ; + +M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; + +: >V ( seq -- vector ) V new clone-like ; inline + +INSTANCE: V growable + +;FUNCTOR diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index c273cea867..fc3d9501c7 100644 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -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, diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 684aab1158..754a3293d1 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -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 diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 927a404519..0a301b3e38 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -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 }" } diff --git a/extra/benchmark/hashtables/authors.txt b/extra/benchmark/hashtables/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/hashtables/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/hashtables/hashtables.factor b/extra/benchmark/hashtables/hashtables.factor new file mode 100644 index 0000000000..065ad9c34a --- /dev/null +++ b/extra/benchmark/hashtables/hashtables.factor @@ -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 \ No newline at end of file