From 0bcf4ce535ed990c054d2f29912fb51210ed1f64 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 03:28:55 -0500 Subject: [PATCH 01/14] 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 --- .../linear-scan/allocation/allocation.factor | 13 +- .../allocation/coalescing/coalescing.factor | 6 +- .../allocation/spilling/spilling.factor | 144 ++++-- .../allocation/splitting/splitting.factor | 13 +- .../linear-scan/allocation/state/state.factor | 19 +- .../linear-scan/assignment/assignment.factor | 71 ++- .../cfg/linear-scan/debugger/debugger.factor | 7 +- .../cfg/linear-scan/linear-scan-tests.factor | 450 +++++++++++++----- .../live-intervals/live-intervals.factor | 12 +- 9 files changed, 508 insertions(+), 227 deletions(-) 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..9be80b0775 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,106 @@ 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 + [ [ assign-spill ] [ assign-reload ] bi* ] + [ [ t >>record-spill? ] [ t >>record-reload? ] bi* ] 2bi ; -: 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 -- ) + "not sure what to do yet" throw ; + +: split-intersecting? ( live-interval new reg -- ? ) + { [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ; + +: split-live-out ( live-interval -- ) + f >>record-spill? + { + [ trim-before-ranges ] + [ compute-start/end ] + [ assign-spill ] + [ add-handled ] + } cleave ; + +: split-live-in ( live-interval -- ) + f >>record-reload? + { + [ trim-after-ranges ] + [ compute-start/end ] + ! [ assign-reload ] + [ add-handled ] + } 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..a08e3e37bd 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -1,7 +1,7 @@ ! 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 @@ -32,6 +32,9 @@ 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 @@ -133,4 +136,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..bc565c6cbb 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 ; @@ -88,12 +77,6 @@ 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>> ] @@ -103,7 +86,7 @@ ERROR: already-reloaded ; } 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 @@ -145,35 +128,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 ; 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..59e6190b63 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -76,36 +76,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 +227,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 +1441,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 +1583,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 +2081,255 @@ 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 \ No newline at end of file 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..e735640b10 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -11,7 +11,7 @@ C: live-range TUPLE: live-interval vreg -reg spill-to reload-from +reg spill-to record-spill? reload-from record-reload? split-before split-after split-next start end ranges uses copy-from ; @@ -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 From 43c873f00a4e023f851b7ebb0cfe59397f445a11 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 03:45:27 -0500 Subject: [PATCH 02/14] compiler.cfg.linear-scan: code cleanup --- .../cfg/linear-scan/allocation/spilling/spilling.factor | 8 ++------ .../cfg/linear-scan/live-intervals/live-intervals.factor | 2 +- 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 9be80b0775..1bd7093526 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -44,9 +44,7 @@ ERROR: bad-live-ranges interval ; dup vreg>> assign-spill-slot >>reload-from drop ; : split-and-spill ( live-interval n -- before after ) - split-for-spill - [ [ assign-spill ] [ assign-reload ] bi* ] - [ [ t >>record-spill? ] [ t >>record-reload? ] bi* ] 2bi ; + split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ; : find-use-position ( live-interval new -- n ) [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ; @@ -80,7 +78,6 @@ ERROR: bad-live-ranges interval ; { [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ; : split-live-out ( live-interval -- ) - f >>record-spill? { [ trim-before-ranges ] [ compute-start/end ] @@ -89,11 +86,10 @@ ERROR: bad-live-ranges interval ; } cleave ; : split-live-in ( live-interval -- ) - f >>record-reload? { [ trim-after-ranges ] [ compute-start/end ] - ! [ assign-reload ] + [ assign-reload ] [ add-handled ] } cleave ; 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 e735640b10..bf7e8bc042 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -11,7 +11,7 @@ C: live-range TUPLE: live-interval vreg -reg spill-to record-spill? reload-from record-reload? +reg spill-to reload-from split-before split-after split-next start end ranges uses copy-from ; From 1a190ae97eca3e8b0b0c0c142521c76a807b353c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 03:49:10 -0500 Subject: [PATCH 03/14] Remove A+s shortcut for saving image in UI --- basis/ui/tools/tools.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index 7ea34e651f..42bc0ef1f2 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -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 } From 6737d2cdabf04981bd779a796eccf93b19d92447 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 12:20:43 -0500 Subject: [PATCH 04/14] benchmark.hashtables: throw something together --- extra/benchmark/hashtables/authors.txt | 1 + extra/benchmark/hashtables/hashtables.factor | 75 ++++++++++++++++++++ 2 files changed, 76 insertions(+) create mode 100644 extra/benchmark/hashtables/authors.txt create mode 100644 extra/benchmark/hashtables/hashtables.factor 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 From 516ce0c71de7e5a8bd64a255b2f39d208a9353f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 13:00:58 -0500 Subject: [PATCH 05/14] threads: better error messages --- basis/threads/threads.factor | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) 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 ; Date: Tue, 7 Jul 2009 13:01:27 -0500 Subject: [PATCH 06/14] compiler.cfg.linear-scan: debugging spilling, add more assertions --- .../allocation/spilling/spilling.factor | 10 +- .../linear-scan/allocation/state/state.factor | 27 ++- .../linear-scan/assignment/assignment.factor | 17 +- .../cfg/linear-scan/linear-scan-tests.factor | 204 +++++++++++++++++- .../cfg/linear-scan/linear-scan.factor | 3 +- .../linear-scan/numbering/numbering.factor | 15 +- 6 files changed, 251 insertions(+), 25 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 1bd7093526..9949832294 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -72,7 +72,13 @@ ERROR: bad-live-ranges interval ; [ uses>> first ] [ second ] bi* > ; : spill-new ( new pair -- ) - "not sure what to do yet" throw ; + 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&& ; @@ -90,7 +96,7 @@ ERROR: bad-live-ranges interval ; [ trim-after-ranges ] [ compute-start/end ] [ assign-reload ] - [ add-handled ] + [ add-unhandled ] } cleave ; : (split-intersecting) ( live-interval new -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index a08e3e37bd..3e646b40f0 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -5,6 +5,20 @@ 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 @@ -39,7 +53,7 @@ SYMBOL: inactive-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 < ; @@ -93,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 ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index bc565c6cbb..c995569c2e 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -68,8 +68,7 @@ SYMBOL: register-live-outs } 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 '[ @@ -82,7 +81,7 @@ SYMBOL: register-live-outs [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] - [ end>> ] + [ start>> ] } cleave f swap \ _reload boa , ; : handle-reload ( live-interval -- ) @@ -92,7 +91,7 @@ SYMBOL: register-live-outs #! 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 @@ -179,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/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 59e6190b63..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 } } @@ -2332,4 +2334,204 @@ V{ 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/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 From c171527b8de91a42eb65db842cc9f47e36f84c6f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 14:34:08 -0500 Subject: [PATCH 07/14] Add vectors.functor for generating vector types from arrays; re-implement bit-vectors and specialized-vectors using this. Add DEFERS directive to functors --- basis/bit-vectors/bit-vectors-docs.factor | 4 +-- basis/bit-vectors/bit-vectors.factor | 28 ++-------------- basis/functors/functors.factor | 2 ++ .../functor/functor.factor | 26 ++++----------- basis/vectors/functor/functor.factor | 33 +++++++++++++++++++ 5 files changed, 45 insertions(+), 48 deletions(-) create mode 100644 basis/vectors/functor/functor.factor 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..cdfe48b164 100644 --- a/basis/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -2,34 +2,10 @@ ! 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 ; 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..e4534e5948 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -1,37 +1,23 @@ -! 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 } ; - -: ( 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 +V A vectors.functor:define-vector M: V pprint-delims drop \ V{ \ } ; diff --git a/basis/vectors/functor/functor.factor b/basis/vectors/functor/functor.factor new file mode 100644 index 0000000000..47a6c2090a --- /dev/null +++ b/basis/vectors/functor/functor.factor @@ -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 -- ) + + 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 From dafdbe13c914884122d42a0c389fc4741ced334a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 15:01:30 -0500 Subject: [PATCH 08/14] growable vocabulary: make 'contract' generic so that only real vectors clear popped elements; add resize method for struct-arrays, add new struct-vectors vocabulary --- basis/bit-vectors/bit-vectors.factor | 3 ++- .../functor/functor.factor | 2 ++ .../struct-arrays/struct-arrays-tests.factor | 4 +++- basis/struct-arrays/struct-arrays.factor | 4 ++++ .../struct-vectors/struct-vectors-docs.factor | 16 +++++++++++++ .../struct-vectors-tests.factor | 20 ++++++++++++++++ basis/struct-vectors/struct-vectors.factor | 23 +++++++++++++++++++ core/byte-vectors/byte-vectors.factor | 2 ++ core/growable/growable.factor | 8 ++++--- 9 files changed, 77 insertions(+), 5 deletions(-) create mode 100644 basis/struct-vectors/struct-vectors-docs.factor create mode 100644 basis/struct-vectors/struct-vectors-tests.factor create mode 100644 basis/struct-vectors/struct-vectors.factor diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor index cdfe48b164..7febe6fc1b 100644 --- a/basis/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -1,4 +1,4 @@ -! 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 @@ -9,6 +9,7 @@ IN: bit-vectors 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/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index e4534e5948..6635fbeaf2 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -19,6 +19,8 @@ WHERE V A vectors.functor:define-vector +M: V contract 2drop ; + M: V pprint-delims drop \ V{ \ } ; M: V >pprint-sequence ; diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index 8ce45ccc15..7347b94628 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -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 "point" 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..a033de5e14 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -20,6 +20,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..cff65d3371 --- /dev/null +++ b/basis/struct-vectors/struct-vectors-tests.factor @@ -0,0 +1,20 @@ +IN: struct-vectors.tests +USING: struct-vectors tools.test alien.c-types 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..252a46d640 --- /dev/null +++ b/basis/struct-vectors/struct-vectors.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors 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 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 \ No newline at end of file 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 From 01d344fb463d31999c3f3ddaa152eae04c7d278e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 7 Jul 2009 15:11:04 -0500 Subject: [PATCH 09/14] byte-length method for struct-arrays --- basis/struct-arrays/struct-arrays.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index 5aaf2c2ea6..c21dae864a 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 ; From 37241c5eee43d03c6f728ac108f5c2965d2467b3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 15:12:21 -0500 Subject: [PATCH 10/14] sequences: fix replicate example --- core/sequences/sequences-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 }" } From b42a1cc7463cad29d20d6beefcff02fa1ac3534a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 7 Jul 2009 15:29:16 -0500 Subject: [PATCH 11/14] fix struct-vectors --- basis/struct-vectors/struct-vectors.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/struct-vectors/struct-vectors.factor b/basis/struct-vectors/struct-vectors.factor index 252a46d640..974fa1d452 100644 --- a/basis/struct-vectors/struct-vectors.factor +++ b/basis/struct-vectors/struct-vectors.factor @@ -13,11 +13,11 @@ TUPLE: struct-vector [ 0 ] keep struct-vector boa ; inline M: struct-vector new-sequence - [ c-type>> ] [ [ >fixnum ] [ c-type>> ] bi ] 2bi + [ 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 \ No newline at end of file +INSTANCE: struct-vector growable From 84485d36ee1ed17cd7272fa9239b6328ee85b70a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 7 Jul 2009 15:30:41 -0500 Subject: [PATCH 12/14] byte-length for struct-vectors --- basis/struct-vectors/struct-vectors.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/struct-vectors/struct-vectors.factor b/basis/struct-vectors/struct-vectors.factor index 974fa1d452..b29ab19e4d 100644 --- a/basis/struct-vectors/struct-vectors.factor +++ b/basis/struct-vectors/struct-vectors.factor @@ -12,6 +12,7 @@ TUPLE: struct-vector : ( 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 ; From 4763ee9a4dc50653d559f1e84d443c2c2761d51f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 7 Jul 2009 15:34:14 -0500 Subject: [PATCH 13/14] oops --- basis/struct-vectors/struct-vectors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/struct-vectors/struct-vectors.factor b/basis/struct-vectors/struct-vectors.factor index b29ab19e4d..5a0654ea16 100644 --- a/basis/struct-vectors/struct-vectors.factor +++ b/basis/struct-vectors/struct-vectors.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays growable kernel math sequences +USING: accessors alien.c-types byte-arrays growable kernel math sequences sequences.private struct-arrays ; IN: struct-vectors From 76288ae55dcf6b043deefdd87aaebe8bed0faf8f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Jul 2009 19:15:50 -0500 Subject: [PATCH 14/14] struct-arrays and struct-vectors: fix unit tests --- basis/struct-arrays/struct-arrays-tests.factor | 4 ++-- basis/struct-vectors/struct-vectors-tests.factor | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index 7347b94628..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" } @@ -37,4 +37,4 @@ C-STRUCT: test-struct ] with-destructors ] unit-test -[ 15 ] [ 15 10 "point" resize length ] unit-test \ No newline at end of file +[ 15 ] [ 15 10 "test-struct" resize length ] unit-test \ No newline at end of file diff --git a/basis/struct-vectors/struct-vectors-tests.factor b/basis/struct-vectors/struct-vectors-tests.factor index cff65d3371..f57c64152c 100644 --- a/basis/struct-vectors/struct-vectors-tests.factor +++ b/basis/struct-vectors/struct-vectors-tests.factor @@ -1,5 +1,6 @@ IN: struct-vectors.tests -USING: struct-vectors tools.test alien.c-types kernel sequences ; +USING: struct-vectors tools.test alien.c-types alien.syntax +namespaces kernel sequences ; C-STRUCT: point { "float" "x" }