Merge branch 'master' of git://factorcode.org/git/factor

basis/alien/inline/inline.factor

@@ -12,28 +12,17 @@ SYMBOL: library-is-c++
 SYMBOL: compiler-args
 SYMBOL: c-strings
 
-: (C-LIBRARY:) ( -- )
-    scan c-library set
-    V{ } clone c-strings set
-    V{ } clone compiler-args set ;
-
-: (C-LINK:) ( -- )
-    "-l" scan append compiler-args get push ;
-
-: (C-FRAMEWORK:) ( -- )
-    "-framework" scan compiler-args get '[ _ push ] bi@ ;
-
 : return-library-function-params ( -- return library function params )
     scan c-library get scan ")" parse-tokens
     [ "(" subseq? not ] filter [
         [ dup CHAR: - = [ drop CHAR: space ] when ] map
     ] 3dip ;
 
-: factor-function ( return library functions params -- )
+: factor-function ( return library function params -- )
     [ dup "const " head? [ 6 tail ] when ] 3dip
     make-function define-declared ;
 
-: (C-FUNCTION:) ( return library function params -- str )
+: c-function-string ( return library function params -- str )
     [ nip ] dip
     " " join "(" prepend ")" append 3array " " join
     library-is-c++ get [ "extern \"C\" " prepend ] when ;
@@ -53,31 +42,47 @@ SYMBOL: c-strings
     compiler-args get
     c-strings get "\n" join
     c-library get compile-to-library ;
-
-: (;C-LIBRARY) ( -- )
-    compile-library? [ compile-library ] when
-    c-library get library-path "cdecl" add-library ;
 PRIVATE>
 
-SYNTAX: C-LIBRARY: (C-LIBRARY:) ;
+: define-c-library ( name -- )
+    c-library set
+    V{ } clone c-strings set
+    V{ } clone compiler-args set ;
 
-SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
+: compile-c-library ( -- )
+    compile-library? [ compile-library ] when
+    c-library get library-path "cdecl" add-library ;
 
-SYNTAX: C-LINK: (C-LINK:) ;
+: define-c-function ( return library function params -- )
-
+    [ factor-function ] 4 nkeep c-function-string
-SYNTAX: C-FRAMEWORK: (C-FRAMEWORK:) ;
-
-SYNTAX: C-LINK/FRAMEWORK:
-    os macosx? [ (C-FRAMEWORK:) ] [ (C-LINK:) ] if ;
-
-SYNTAX: C-INCLUDE:
-    "#include " scan append c-strings get push ;
-
-SYNTAX: C-FUNCTION:
-    return-library-function-params
-    [ factor-function ]
-    4 nkeep (C-FUNCTION:)
     " {\n" append parse-here append "\n}\n" append
     c-strings get push ;
 
-SYNTAX: ;C-LIBRARY (;C-LIBRARY) ;
+: define-c-link ( str -- )
+    "-l" prepend compiler-args get push ;
+
+: define-c-framework ( str -- )
+    "-framework" swap compiler-args get '[ _ push ] bi@ ;
+
+: define-c-link/framework ( str -- )
+    os macosx? [ define-c-framework ] [ define-c-link ] if ;
+
+: define-c-include ( str -- )
+    "#include " prepend c-strings get push ;
+
+SYNTAX: C-LIBRARY: scan define-c-library ;
+
+SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
+
+SYNTAX: C-LINK: scan define-c-link ;
+
+SYNTAX: C-FRAMEWORK: scan define-c-framework ;
+
+SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ;
+
+SYNTAX: C-INCLUDE: scan define-c-include ;
+
+SYNTAX: C-FUNCTION:
+    return-library-function-params define-c-function ;
+
+SYNTAX: ;C-LIBRARY compile-c-library ;

basis/alien/inline/tests/tests.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Jeremy Hughes.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.inline alien.inline.private io.files io.directories kernel ;
+USING: tools.test alien.inline alien.inline.private io.files
+io.directories kernel ;
 IN: alien.inline.tests
 
 C-LIBRARY: const
@@ -42,6 +43,6 @@ C-FUNCTION: char* breakme ( )
     return not a string;
 ;
 
-<< [ (;C-LIBRARY) ] must-fail >>
+<< [ compile-c-library ] must-fail >>
 
 << library-path dup exists? [ delete-file ] [ drop ] if >>

basis/compiler/cfg/branch-folding/branch-folding-tests.factor

@@ -1,8 +1,8 @@
 IN: compiler.cfg.branch-folding.tests
 USING: compiler.cfg.branch-folding compiler.cfg.instructions
 compiler.cfg compiler.cfg.registers compiler.cfg.debugger
-arrays compiler.cfg.phi-elimination
+arrays compiler.cfg.phi-elimination compiler.cfg.dce
-compiler.cfg.predecessors kernel accessors
+compiler.cfg.predecessors kernel accessors assocs
 sequences classes namespaces tools.test cpu.architecture ;
 
 V{ T{ ##branch } } 0 test-bb
@@ -41,4 +41,45 @@ test-diamond
 [ t ] [ 1 get successors>> first 3 get eq? ] unit-test
 
 [ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
-[ 2 ] [ 4 get instructions>> length ] unit-test
+[ 2 ] [ 4 get instructions>> length ] unit-test
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
+} 1 test-bb
+
+V{
+    T{ ##copy f V int-regs 2 V int-regs 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f V int-regs 3 V{ } }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f V int-regs 3 D 0 }
+    T{ ##return }
+} 4 test-bb
+
+1 get V int-regs 1 2array
+2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
+
+test-diamond
+
+[ ] [
+    cfg new 0 get >>entry
+    compute-predecessors
+    fold-branches
+    compute-predecessors
+    eliminate-dead-code
+    drop
+] unit-test
+
+[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test

basis/compiler/cfg/gc-checks/gc-checks.factor

@@ -1,20 +1,16 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences assocs
-cpu.architecture compiler.cfg.rpo
+compiler.cfg.rpo compiler.cfg.instructions
-compiler.cfg.liveness compiler.cfg.instructions
 compiler.cfg.hats ;
 IN: compiler.cfg.gc-checks
 
 : gc? ( bb -- ? )
     instructions>> [ ##allocation? ] any? ;
 
-: object-pointer-regs ( basic-block -- vregs )
-    live-in keys [ reg-class>> int-regs eq? ] filter ;
-
 : insert-gc-check ( basic-block -- )
     dup gc? [
-        [ i i f f \ ##gc new-insn prefix ] change-instructions drop
+        [ i i f \ ##gc new-insn prefix ] change-instructions drop
     ] [ drop ] if ;
 
 : insert-gc-checks ( cfg -- cfg' )

basis/compiler/cfg/instructions/instructions.factor

@@ -199,6 +199,16 @@ SYMBOL: cc/=
         { cc/= cc= }
     } at ;
 
+: swap-cc ( cc -- cc' )
+    H{
+        { cc< cc> }
+        { cc<= cc>= }
+        { cc> cc< }
+        { cc>= cc<= }
+        { cc= cc= }
+        { cc/= cc/= }
+    } at ;
+
 : evaluate-cc ( result cc -- ? )
     H{
         { cc<  { +lt+           } }
@@ -220,7 +230,7 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
 INSN: ##compare-float-branch < ##conditional-branch ;
 INSN: ##compare-float < ##binary cc temp ;
 
-INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
+INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;
@@ -240,7 +250,7 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
 
 INSN: _compare-float-branch < _conditional-branch ;
 
-TUPLE: spill-slot { n integer } ; C: <spill-slot> spill-slot
+TUPLE: spill-slot n ; C: <spill-slot> spill-slot
 
 INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
 

basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor

@@ -48,9 +48,7 @@ ERROR: bad-live-ranges interval ;
     } 2cleave ;
 
 : assign-spill ( live-interval -- live-interval )
-    dup reload-from>>
+    dup vreg>> assign-spill-slot >>spill-to ;
-    [ dup vreg>> reg-class>> next-spill-location ] unless*
-    >>spill-to ;
 
 : assign-reload ( before after -- before after )
     over spill-to>> >>reload-from ;

basis/compiler/cfg/linear-scan/allocation/state/state.factor

@@ -109,18 +109,26 @@ CONSTANT: reg-classes { int-regs double-float-regs }
 : reg-class-assoc ( quot -- assoc )
     [ reg-classes ] dip { } map>assoc ; inline
 
+! Mapping from register classes to spill counts
 SYMBOL: spill-counts
 
-: next-spill-location ( reg-class -- n )
+: next-spill-slot ( reg-class -- n )
     spill-counts get [ dup 1 + ] change-at ;
 
+! Mapping from vregs to spill slots
+SYMBOL: spill-slots
+
+: assign-spill-slot ( vreg -- n )
+    spill-slots get [ reg-class>> next-spill-slot ] cache ;
+
 : init-allocator ( registers -- )
     registers set
-    [ 0 ] reg-class-assoc spill-counts set
     <min-heap> unhandled-intervals set
     [ V{ } clone ] reg-class-assoc active-intervals set
     [ V{ } clone ] reg-class-assoc inactive-intervals set
     V{ } clone handled-intervals set
+    [ 0 ] reg-class-assoc spill-counts set
+    H{ } clone spill-slots set
     -1 progress set ;
 
 : init-unhandled ( live-intervals -- )

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets
+fry make combinators sets locals
 cpu.architecture
 compiler.cfg.def-use
 compiler.cfg.registers
@@ -33,6 +33,20 @@ 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
+
+! Mapping from basic blocks to values which are live at the end
+SYMBOL: register-live-outs
+
+: init-assignment ( live-intervals -- )
+    V{ } clone pending-intervals set
+    <min-heap> unhandled-intervals set
+    [ H{ } clone ] reg-class-assoc spill-slots set
+    H{ } clone register-live-ins set
+    H{ } clone register-live-outs set
+    init-unhandled ;
+
 ERROR: already-spilled ;
 
 : record-spill ( live-interval -- )
@@ -102,10 +116,13 @@ ERROR: already-reloaded ;
         ] [ 2drop ] if
     ] if ;
 
+: prepare-insn ( n -- )
+    [ expire-old-intervals ] [ activate-new-intervals ] bi ;
+
 GENERIC: assign-registers-in-insn ( insn -- )
 
 : register-mapping ( live-intervals -- alist )
-    [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
+    [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ;
 
 : all-vregs ( insn -- vregs )
     [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
@@ -118,55 +135,67 @@ ERROR: overlapping-registers intervals ;
     dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
     dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
 
-: active-intervals ( insn -- intervals )
+: active-intervals ( n -- intervals )
-    insn#>> pending-intervals get [ covers? ] with filter
+    pending-intervals get [ covers? ] with filter
     check-assignment? get [
         dup check-assignment
     ] when ;
 
 M: vreg-insn assign-registers-in-insn
-    dup [ active-intervals ] [ all-vregs ] bi
+    dup [ insn#>> active-intervals ] [ all-vregs ] bi
     '[ vreg>> _ member? ] filter
     register-mapping
     >>regs drop ;
 
-: compute-live-registers ( insn -- regs )
+: compute-live-registers ( n -- assoc )
-    [ active-intervals ] [ temp-vregs ] bi
+    active-intervals register-mapping ;
-    '[ vreg>> _ memq? not ] filter
-    register-mapping ;
 
-: compute-live-spill-slots ( -- spill-slots )
+: compute-live-spill-slots ( -- assocs )
-    spill-slots get values
+    spill-slots get values first2
-    [ [ vreg>> swap ] { } assoc-map-as ] map concat ;
+    [ [ vreg>> swap <spill-slot> ] H{ } assoc-map-as ] bi@
+    assoc-union ;
+
+: compute-live-values ( n -- assoc )
+    [ compute-live-spill-slots ] dip compute-live-registers
+    assoc-union ;
+
+: compute-live-gc-values ( insn -- assoc )
+    [ insn#>> compute-live-values ] [ temp-vregs ] bi
+    '[ drop _ memq? not ] assoc-filter ;
 
 M: ##gc assign-registers-in-insn
     dup call-next-method
-    dup compute-live-registers >>live-registers
+    dup compute-live-gc-values >>live-values
-    compute-live-spill-slots >>live-spill-slots
     drop ;
 
 M: insn assign-registers-in-insn drop ;
 
-: init-assignment ( live-intervals -- )
+: begin-block ( bb -- )
-    V{ } clone pending-intervals set
+    dup block-from 1 - prepare-insn
-    <min-heap> unhandled-intervals set
+    [ block-from compute-live-values ] keep register-live-ins get set-at ;
-    [ H{ } clone ] reg-class-assoc spill-slots set 
-    init-unhandled ;
 
-: assign-registers-in-block ( bb -- )
+: end-block ( bb -- )
-    [
+    [ block-to compute-live-values ] keep register-live-outs get set-at ;
+
+ERROR: bad-vreg vreg ;
+
+: vreg-at-start ( vreg bb -- state )
+    register-live-ins get at ?at [ bad-vreg ] unless ;
+
+: vreg-at-end ( vreg bb -- state )
+    register-live-outs get at ?at [ bad-vreg ] unless ;
+
+:: assign-registers-in-block ( bb -- )
+    bb [
         [
+            bb begin-block
             [
-                [
+                [ insn#>> prepare-insn ]
-                    insn#>>
-                    [ expire-old-intervals ]
-                    [ activate-new-intervals ]
-                    bi
-                ]
                 [ assign-registers-in-insn ]
                 [ , ]
                 tri
             ] each
+            bb end-block
         ] V{ } make
     ] change-instructions drop ;
 

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -1353,7 +1353,7 @@ USING: math.private ;
 
 ! Spill slot liveness was computed incorrectly, leading to a FEP
 ! early in bootstrap on x86-32
-[ t t ] [
+[ t ] [
     [
         H{ } clone live-ins set
         H{ } clone live-outs set
@@ -1379,8 +1379,7 @@ USING: math.private ;
            }
         } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
         instructions>> first
-        [ live-spill-slots>> empty? ]
+        live-values>> assoc-empty?
-        [ live-registers>> empty? ] bi
     ] with-scope
 ] unit-test
 
@@ -1859,4 +1858,121 @@ test-diamond
 
 [ _spill ] [ 3 get instructions>> second class ] unit-test
 
-[ _reload ] [ 4 get instructions>> first class ] unit-test
+[ _reload ] [ 4 get instructions>> first class ] unit-test
+
+! Resolve pass
+V{
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+} 1 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##peek f V int-regs 1 D 0 }
+    T{ ##peek f V int-regs 2 D 0 }
+    T{ ##replace f V int-regs 1 D 0 }
+    T{ ##replace f V int-regs 2 D 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##peek f V int-regs 1 D 0 }
+    T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+} 4 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 5 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 6 test-bb
+
+0 get 1 get V{ } 1sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get V{ } 1sequence >>successors drop
+3 get 4 get V{ } 1sequence >>successors drop
+4 get 5 get 6 get V{ } 2sequence >>successors drop
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
+
+[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test
+
+[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
+
+! A more complicated failure case with resolve that came up after the above
+! got fixed
+V{ T{ ##branch } } 0 test-bb
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##peek f V int-regs 2 D 2 }
+    T{ ##peek f V int-regs 3 D 3 }
+    T{ ##peek f V int-regs 4 D 0 }
+    T{ ##branch }
+} 1 test-bb
+V{ T{ ##branch } } 2 test-bb
+V{ T{ ##branch } } 3 test-bb
+V{
+    
+    T{ ##replace f V int-regs 1 D 1 }
+    T{ ##replace f V int-regs 2 D 2 }
+    T{ ##replace f V int-regs 3 D 3 }
+    T{ ##replace f V int-regs 4 D 4 }
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##branch }
+} 4 test-bb
+V{ T{ ##replace f V int-regs 0 D 0 } T{ ##branch } } 5 test-bb
+V{ T{ ##return } } 6 test-bb
+V{ T{ ##branch } } 7 test-bb
+V{
+    T{ ##replace f V int-regs 1 D 1 }
+    T{ ##replace f V int-regs 2 D 2 }
+    T{ ##replace f V int-regs 3 D 3 }
+    T{ ##peek f V int-regs 5 D 1 }
+    T{ ##peek f V int-regs 6 D 2 }
+    T{ ##peek f V int-regs 7 D 3 }
+    T{ ##peek f V int-regs 8 D 4 }
+    T{ ##replace f V int-regs 5 D 1 }
+    T{ ##replace f V int-regs 6 D 2 }
+    T{ ##replace f V int-regs 7 D 3 }
+    T{ ##replace f V int-regs 8 D 4 }
+    T{ ##branch }
+} 8 test-bb
+V{
+    T{ ##replace f V int-regs 1 D 1 }
+    T{ ##replace f V int-regs 2 D 2 }
+    T{ ##replace f V int-regs 3 D 3 }
+    T{ ##return }
+} 9 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 7 get V{ } 2sequence >>successors drop
+7 get 8 get 1vector >>successors drop
+8 get 9 get 1vector >>successors drop
+2 get 3 get 5 get V{ } 2sequence >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 9 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
+
+[ _spill ] [ 1 get instructions>> second class ] unit-test
+[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
+[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> ] map ] unit-test
+[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
+
+! Resolve pass should insert this
+[ _reload ] [ 5 get instructions>> first class ] unit-test

basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor

@@ -12,59 +12,6 @@ IN: compiler.cfg.linear-scan.resolve.tests
     { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
 ] unit-test
 
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##replace f V int-regs 0 D 1 }
-    T{ ##return }
-} 1 test-bb
-
-1 get 1vector 0 get (>>successors)
-
-cfg new 0 get >>entry
-compute-predecessors
-dup reverse-post-order number-instructions
-drop
-
-CONSTANT: test-live-interval-1
-T{ live-interval
-   { start 0 }
-   { end 6 }
-   { uses V{ 0 6 } }
-   { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
-   { spill-to 0 }
-   { vreg V int-regs 0 }
-}
-
-[ f ] [
-    test-live-interval-1 0 get spill-to
-] unit-test
-
-[ 0 ] [
-    test-live-interval-1 1 get spill-to
-] unit-test
-
-CONSTANT: test-live-interval-2
-T{ live-interval
-   { start 0 }
-   { end 6 }
-   { uses V{ 0 6 } }
-   { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
-   { reload-from 0 }
-   { vreg V int-regs 0 }
-}
-
-[ 0 ] [
-    test-live-interval-2 0 get reload-from
-] unit-test
-
-[ f ] [
-    test-live-interval-2 1 get reload-from
-] unit-test
-
 [
     {
         T{ _copy { dst 5 } { src 4 } { class int-regs } }
@@ -142,8 +89,8 @@ T{ live-interval
     }
 ] [
     {
-       T{ register->memory { from 3 } { to 4 } { reg-class int-regs } }
+        T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } }
-       T{ memory->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } }
     } mapping-instructions
 ] unit-test
 

basis/compiler/cfg/linear-scan/resolve/resolve.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays assocs classes.parser classes.tuple
 combinators combinators.short-circuit fry hashtables kernel locals
 make math math.order namespaces sequences sets words parser
-compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals
+compiler.cfg.instructions compiler.cfg.linear-scan.assignment
 compiler.cfg.liveness ;
 IN: compiler.cfg.linear-scan.resolve
 
@@ -14,50 +14,33 @@ TUPLE: operation from to reg-class ;
 SYNTAX: OPERATION:
     CREATE-CLASS dup save-location
     [ operation { } define-tuple-class ]
-    [
+    [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
-        [ scan-word scan-word ] keep
-        '[
-            [ [ _ execute ] [ _ execute ] bi* ]
-            [ vreg>> reg-class>> ]
-            bi _ boa ,
-        ] (( from to -- )) define-declared
-    ] bi ;
 
 >>
 
-: insn-in-block? ( insn# bb -- ? )
+OPERATION: register->memory
-    [ block-from ] [ block-to ] bi between? ;
+OPERATION: memory->register
+OPERATION: register->register
 
-: reload-from ( live-interval bb -- n/f )
+! This should never come up because of how spill slots are assigned,
-    2dup [ start>> ] dip insn-in-block?
+! so make it an error.
-    [ drop reload-from>> ] [ 2drop f ] if ;
+: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
 
-: spill-to ( live-interval bb -- n/f )
+: add-mapping ( from to reg-class -- )
-    2dup [ end>> ] dip insn-in-block?
+    over spill-slot? [
-    [ drop spill-to>> ] [ 2drop f ] if ;
+        pick spill-slot?
-
+        [ memory->memory ]
-OPERATION: memory->memory spill-to>> reload-from>>
+        [ register->memory ] if
-OPERATION: register->memory reg>> reload-from>>
-OPERATION: memory->register spill-to>> reg>>
-OPERATION: register->register reg>> reg>>
-
-:: add-mapping ( bb1 bb2 li1 li2 -- )
-    li2 bb2 reload-from [
-        li1 bb1 spill-to
-        [ li1 li2 memory->memory ]
-        [ li1 li2 register->memory ] if
     ] [
-        li1 bb1 spill-to
+        pick spill-slot?
-        [ li1 li2 memory->register ]
+        [ memory->register ]
-        [ li1 li2 register->register ] if
+        [ register->register ] if
     ] if ;
 
-: resolve-value-data-flow ( bb to vreg -- )
+:: resolve-value-data-flow ( bb to vreg -- )
-    [ 2dup ] dip
+    vreg bb vreg-at-end
-    live-intervals get at
+    vreg to vreg-at-start
-    [ [ block-to ] dip child-interval-at ]
+    2dup eq? [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
-    [ [ block-from ] dip child-interval-at ]
-    bi-curry bi* 2dup eq? [ 2drop 2drop ] [ add-mapping ] if ;
 
 : compute-mappings ( bb to -- mappings )
     [
@@ -67,48 +50,23 @@ OPERATION: register->register reg>> reg>>
 
 GENERIC: >insn ( operation -- )
 
-M: memory->memory >insn
-    [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
-
 M: register->memory >insn
-    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
+    [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
 
 M: memory->register >insn
-    [ to>> ] [ reg-class>> ] [ from>> ] tri  _reload ;
+    [ to>> ] [ reg-class>> ] [ from>> n>> ] tri  _reload ;
 
 M: register->register >insn
     [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
 
-GENERIC: >collision-table ( operation -- )
-
-M: memory->memory >collision-table
-    [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
-
-M: register->memory >collision-table
-    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
-
-M: memory->register >collision-table
-    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
-
-M: register->register >collision-table
-    [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
-
 SYMBOL: froms
 SYMBOL: tos
 
 SINGLETONS: memory register ;
 
-GENERIC: from-loc ( operation -- obj )
+: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
-M: memory->memory from-loc drop memory ;
-M: register->memory from-loc drop register ;
-M: memory->register from-loc drop memory ;
-M: register->register from-loc drop register ;
 
-GENERIC: to-loc ( operation -- obj )
+: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
-M: memory->memory to-loc drop memory ;
-M: register->memory to-loc drop memory ;
-M: memory->register to-loc drop register ;
-M: register->register to-loc drop register ;
 
 : from-reg ( operation -- seq )
     [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
@@ -142,7 +100,6 @@ M: register->register to-loc drop register ;
         dup dup associate (trace-chain)
     ] { } make prune reverse ;
 
-
 : trace-chains ( seq -- seq' )
     [ trace-chain ] map concat ;
 
@@ -159,10 +116,10 @@ ERROR: resolve-error ;
 
 : break-cycle-n ( operations -- operations' )
     split-cycle [
-        [ from>> spill-temp ]
+        [ from>> spill-temp <spill-slot> ]
         [ reg-class>> ] bi \ register->memory boa
     ] [
-        [ to>> spill-temp swap ]
+        [ to>> spill-temp <spill-slot> swap ]
         [ reg-class>> ] bi \ memory->register boa
     ] bi [ 1array ] bi@ surround ;
 

basis/compiler/cfg/linearization/linearization.factor

@@ -57,41 +57,31 @@ M: ##dispatch linearize-insn
     [ successors>> [ number>> _dispatch-label ] each ]
     bi* ;
 
-: gc-root-registers ( n live-registers -- n )
+: (compute-gc-roots) ( n live-values -- n )
     [
-        [ second 2array , ]
+        [ nip 2array , ]
-        [ first reg-class>> reg-size + ]
+        [ drop reg-class>> reg-size + ]
-        2bi
+        3bi
-    ] each ;
+    ] assoc-each ;
 
-: gc-root-spill-slots ( n live-spill-slots -- n )
+: oop-values ( regs -- regs' )
+    [ drop reg-class>> int-regs eq? ] assoc-filter ;
+
+: data-values ( regs -- regs' )
+    [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
+
+: compute-gc-roots ( live-values -- alist )
     [
-        dup first reg-class>> int-regs eq? [
+        [ 0 ] dip
-            [ second <spill-slot> 2array , ]
-            [ first reg-class>> reg-size + ]
-            2bi
-        ] [ drop ] if
-    ] each ;
-
-: oop-registers ( regs -- regs' )
-    [ first reg-class>> int-regs eq? ] filter ;
-
-: data-registers ( regs -- regs' )
-    [ first reg-class>> double-float-regs eq? ] filter ;
-
-:: compute-gc-roots ( live-registers live-spill-slots -- alist )
-    [
-        0
         ! we put float registers last; the GC doesn't actually scan them
-        live-registers oop-registers gc-root-registers
+        [ oop-values (compute-gc-roots) ]
-        live-spill-slots gc-root-spill-slots
+        [ data-values (compute-gc-roots) ] bi
-        live-registers data-registers gc-root-registers
         drop
     ] { } make ;
 
-: count-gc-roots ( live-registers live-spill-slots -- n )
+: count-gc-roots ( live-values -- n )
     ! Size of GC root area, minus the float registers
-    [ oop-registers length ] bi@ + ;
+    oop-values assoc-size ;
 
 M: ##gc linearize-insn
     nip
@@ -99,11 +89,11 @@ M: ##gc linearize-insn
         [ temp1>> ]
         [ temp2>> ]
         [
-            [ live-registers>> ] [ live-spill-slots>> ] bi
+            live-values>>
             [ compute-gc-roots ]
             [ count-gc-roots ]
             [ gc-roots-size ]
-            2tri
+            tri
         ] tri
         _gc
     ] with-regs ;

basis/compiler/cfg/predecessors/predecessors.factor

@@ -1,13 +1,27 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences compiler.cfg.rpo ;
+USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo
+compiler.cfg.instructions ;
 IN: compiler.cfg.predecessors
 
-: predecessors-step ( bb -- )
+: update-predecessors ( bb -- )
     dup successors>> [ predecessors>> push ] with each ;
 
+: update-phi ( bb ##phi -- )
+    [
+        swap predecessors>>
+        '[ drop _ memq? ] assoc-filter
+    ] change-inputs drop ;
+
+: update-phis ( bb -- )
+    dup instructions>> [
+        dup ##phi? [ update-phi ] [ 2drop ] if
+    ] with each ;
+
 : compute-predecessors ( cfg -- cfg' )
-    [ [ V{ } clone >>predecessors drop ] each-basic-block ]
+    {
-    [ [ predecessors-step ] each-basic-block ]
+        [ [ V{ } clone >>predecessors drop ] each-basic-block ]
-    [ ]
+        [ [ update-predecessors ] each-basic-block ]
-    tri ;
+        [ [ update-phis ] each-basic-block ]
+        [ ]
+    } cleave ;

basis/compiler/cfg/stack-frame/stack-frame.factor

@@ -34,8 +34,8 @@ spill-counts ;
 
 : gc-root-offset ( n -- n' ) gc-root-base + ;
 
-: gc-roots-size ( live-registers live-spill-slots -- n )
+: gc-roots-size ( live-values -- n )
-    [ keys [ reg-class>> reg-size ] sigma ] bi@ + ;
+    keys [ reg-class>> reg-size ] sigma ;
 
 : (stack-frame-size) ( stack-frame -- n )
     [

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -1,11 +1,11 @@
-! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators combinators.short-circuit
+USING: accessors locals combinators combinators.short-circuit arrays
-arrays compiler.cfg.hats compiler.cfg.instructions
+fry kernel layouts math namespaces sequences cpu.architecture
+math.bitwise compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.simplify fry kernel layouts math
+compiler.cfg.value-numbering.simplify ;
-namespaces sequences cpu.architecture math.bitwise locals ;
 IN: compiler.cfg.value-numbering.rewrite
 
 GENERIC: rewrite ( insn -- insn' )
@@ -70,21 +70,34 @@ M: ##compare-imm-branch rewrite
         dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
     ] when ;
 
-: flip-comparison? ( insn -- ? )
+:: >compare-imm ( insn swap? -- insn' )
-    dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
+    insn dst>>
+    insn src1>>
+    insn src2>> swap? [ swap ] when vreg>constant
+    insn cc>> swap? [ swap-cc ] when
+    i \ ##compare-imm new-insn ; inline
 
-: flip-comparison ( insn -- insn' )
+! M: ##compare rewrite
-    [ dst>> ]
+!     dup [ src1>> ] [ src2>> ] bi
-    [ src2>> ]
+!     [ vreg>expr constant-expr? ] bi@ 2array {
-    [ src1>> vreg>constant ] tri
+!         { { f t } [ f >compare-imm ] }
-    cc= i \ ##compare-imm new-insn ;
+!         { { t f } [ t >compare-imm ] }
+!         [ drop ]
+!     } case ;
 
-M: ##compare rewrite
+:: >compare-imm-branch ( insn swap? -- insn' )
-    dup flip-comparison? [
+    insn src1>>
-        flip-comparison
+    insn src2>> swap? [ swap ] when vreg>constant
-        dup number-values
+    insn cc>> swap? [ swap-cc ] when
-        rewrite
+    \ ##compare-imm-branch new-insn ; inline
-    ] when ;
+
+! M: ##compare-branch rewrite
+!     dup [ src1>> ] [ src2>> ] bi
+!     [ vreg>expr constant-expr? ] bi@ 2array {
+!         { { f t } [ f >compare-imm-branch ] }
+!         { { t f } [ t >compare-imm-branch ] }
+!         [ drop ]
+!     } case ;
 
 : rewrite-redundant-comparison? ( insn -- ? )
     {

basis/compiler/tests/codegen.factor

@@ -310,4 +310,8 @@ M: cucumber equal? "The cucumber has no equal" throw ;
     }
 ] [
     [ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
-] unit-test
+] unit-test
+
+! Regression from Doug's value numbering changes
+[ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test
+[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -6,6 +6,7 @@ definitions system layouts vectors math.partial-dispatch
 math.order math.functions accessors hashtables classes assocs
 io.encodings.utf8 io.encodings.ascii io.encodings fry slots
 sorting.private combinators.short-circuit grouping prettyprint
+generalizations
 compiler.tree
 compiler.tree.combinators
 compiler.tree.cleanup
@@ -518,3 +519,23 @@ cell-bits 32 = [
     [ { integer integer } declare + drop ]
     { + +-integer-integer } inlined?
 ] unit-test
+
+[ [ ] ] [
+    [
+        20 f <array>
+        [ 0 swap nth ] keep
+        [ 1 swap nth ] keep
+        [ 2 swap nth ] keep
+        [ 3 swap nth ] keep
+        [ 4 swap nth ] keep
+        [ 5 swap nth ] keep
+        [ 6 swap nth ] keep
+        [ 7 swap nth ] keep
+        [ 8 swap nth ] keep
+        [ 9 swap nth ] keep
+        [ 10 swap nth ] keep
+        [ 11 swap nth ] keep
+        [ 12 swap nth ] keep
+        14 ndrop
+    ] cleaned-up-tree nodes>quot
+] unit-test

basis/compiler/tree/dead-code/simple/simple.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors words assocs sequences arrays namespaces
-fry locals definitions classes.algebra
+fry locals definitions classes classes.algebra generic
 stack-checker.state
 stack-checker.backend
 compiler.tree
@@ -9,8 +9,13 @@ compiler.tree.propagation.info
 compiler.tree.dead-code.liveness ;
 IN: compiler.tree.dead-code.simple
 
-: flushable? ( word -- ? )
+GENERIC: flushable? ( word -- ? )
-    [ "flushable" word-prop ] [ "predicating" word-prop ] bi or ;
+
+M: predicate flushable? drop t ;
+
+M: word flushable? "flushable" word-prop ;
+
+M: method-body flushable? "method-generic" word-prop flushable? ;
 
 : flushable-call? ( #call -- ? )
     dup word>> dup flushable? [

basis/tools/annotations/annotations-tests.factor

@@ -49,3 +49,14 @@ M: string blah-generic ;
 [ ] [ M\ string blah-generic watch ] unit-test
 
 [ "hi" ] [ "hi" blah-generic ] unit-test
+
+! See how well watch interacts with optimizations.
+GENERIC: my-generic ( a -- b )
+M: object my-generic ;
+
+\ my-generic watch
+
+: some-code ( -- )
+    f my-generic drop ;
+
+[ ] [ some-code ] unit-test

basis/tools/annotations/annotations.factor

@@ -3,7 +3,8 @@
 USING: accessors kernel math sorting words parser io summary
 quotations sequences prettyprint continuations effects
 definitions compiler.units namespaces assocs tools.walker
-tools.time generic inspector fry tools.continuations ;
+tools.time generic inspector fry tools.continuations
+locals generalizations macros ;
 IN: tools.annotations
 
 GENERIC: reset ( word -- )
@@ -46,17 +47,20 @@ M: word annotate
 
 <PRIVATE
 
-: stack-values ( names -- alist )
+:: trace-quot ( word effect quot str -- quot' )
-    [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ;
+    effect quot call :> values
+    values length :> n
+    [
+        "--- " write str write bl word .
+        n ndup n narray values swap zip simple-table.
+        flush
+    ] ; inline
 
-: trace-message ( word quot str -- )
+MACRO: entering ( word -- quot )
-    "--- " write write bl over .
+    dup stack-effect [ in>> ] "Entering" trace-quot ;
-    [ stack-effect ] dip '[ @ stack-values ] [ f ] if*
-    [ simple-table. ] unless-empty flush ; inline
 
-: entering ( str -- ) [ in>> ] "Entering" trace-message ;
+MACRO: leaving ( word -- quot )
-
+    dup stack-effect [ out>> ] "Leaving" trace-quot ;
-: leaving ( str -- ) [ out>> ] "Leaving" trace-message ;
 
 : (watch) ( word def -- def )
     over '[ _ entering @ _ leaving ] ;

basis/ui/gadgets/panes/panes.factor

@@ -397,8 +397,8 @@ M: f sloppy-pick-up*
     ] [ drop ] if ;
 
 : end-selection ( pane -- )
-    f >>selecting?
+    dup selecting?>> hand-moved? or
-    hand-moved?
+    [ f >>selecting? ] dip
     [ [ com-copy-selection ] [ request-focus ] bi ]
     [ [ relayout-1 ] [ focus-input ] bi ]
     if ;

basis/ui/tools/listener/completion/completion.factor

@@ -63,6 +63,7 @@ M: definition-completion row-columns
 
 M: word-completion row-color
     [ vocabulary>> ] [ manifest>> ] bi* {
+        { [ dup not ] [ COLOR: black ] }
         { [ 2dup search-vocabs>> memq? ] [ COLOR: black ] }
         { [ over ".private" tail? ] [ COLOR: dark-red ] }
         [ COLOR: dark-gray ]

basis/ui/tools/listener/history/history-tests.factor

@@ -52,3 +52,16 @@ IN: ui.tools.listener.history.tests
 [ ] [ "h" get history-recall-previous ] unit-test
 
 [ "22" ] [ "d" get doc-string ] unit-test
+
+[ ] [ <document> "d" set ] unit-test
+[ ] [ "d" get <history> "h" set ] unit-test
+
+[ ] [ "aaa" "d" get set-doc-string ] unit-test
+[ T{ input f "aaa" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "" "d" get set-doc-string ] unit-test
+[ T{ input f "" } ] [ "h" get history-add ] unit-test
+[ T{ input f "" } ] [ "h" get history-add ] unit-test
+[ ] [ "   " "d" get set-doc-string ] unit-test
+[ ] [ "h" get history-recall-previous ] unit-test
+

basis/ui/tools/listener/history/history.factor

@@ -16,9 +16,15 @@ TUPLE: history document elements index ;
 
 <PRIVATE
 
+: (save-history) ( input index elements -- )
+    2dup length > [
+        [ [ T{ input f "" } ] dip push ] keep
+        (save-history)
+    ] [ set-nth ] if ;
+
 : save-history ( history -- )
     [ document>> doc-string ] keep
-    '[ <input> _ [ index>> ] [ elements>> ] bi set-nth ]
+    '[ <input> _ [ index>> ] [ elements>> ] bi (save-history) ]
     unless-empty ;
 
 : update-document ( history -- )

basis/unicode/breaks/breaks-docs.factor

@@ -7,11 +7,16 @@ ARTICLE: "unicode.breaks" "Word and grapheme breaks"
 "The " { $vocab-link "unicode.breaks" "unicode.breaks" } " vocabulary partially implements Unicode Standard Annex #29. This provides for segmentation of a string along grapheme and word boundaries. In Unicode, a grapheme, or a basic unit of display in text, may be more than one code point. For example, in the string \"e\\u000301\" (where U+0301 is a combining acute accent), there is only one grapheme, as the acute accent goes above the e, forming a single grapheme. Word breaks, in general, are more complicated than simply splitting by whitespace, and the Unicode algorithm provides for that."
 $nl "Operations for graphemes:"
 { $subsection first-grapheme }
+{ $subsection first-grapheme-from }
 { $subsection last-grapheme }
+{ $subsection last-grapheme-from }
 { $subsection >graphemes }
 { $subsection string-reverse }
 "Operations on words:"
 { $subsection first-word }
+{ $subsection first-word-from }
+{ $subsection last-word }
+{ $subsection last-word-from }
 { $subsection >words } ;
 
 HELP: first-grapheme
@@ -22,6 +27,14 @@ HELP: last-grapheme
 { $values { "str" string } { "i" "an index" } }
 { $description "Finds the index of the start of the last grapheme of the string. This can be used to traverse the graphemes of a string backwards." } ;
 
+HELP: first-grapheme-from
+{ $values { "start" "an index" } { "str" string } { "i" "an index" } }
+{ $description "Finds the length of the first grapheme of the string, starting from the given index. This can be used repeatedly to efficiently traverse the graphemes of the string, using slices." } ;
+
+HELP: last-grapheme-from
+{ $values { "end" "an index" } { "str" string } { "i" "an index" } }
+{ $description "Finds the index of the start of the last grapheme of the string, starting from the given index. This can be used to traverse the graphemes of a string backwards." } ;
+
 HELP: >graphemes
 { $values { "str" string } { "graphemes" "an array of strings" } }
 { $description "Divides a string into a sequence of individual graphemes." } ;
@@ -32,7 +45,19 @@ HELP: string-reverse
 
 HELP: first-word
 { $values { "str" string } { "i" "index" } }
-{ $description "Finds the length of the first word in the string." } ;
+{ $description "Finds the index of the end of the first word in the string." } ;
+
+HELP: last-word
+{ $values { "str" string } { "i" "index" } }
+{ $description "Finds the index of the beginning of the last word in the string." } ;
+
+HELP: first-word-from
+{ $values { "start" "index" } { "str" string } { "i" "index" } }
+{ $description "Finds the index of the end of the first word in the string, starting from the given index." } ;
+
+HELP: last-word-from
+{ $values { "end" "index" } { "str" string } { "i" "index" } }
+{ $description "Finds the index of the start of the word that the index is contained in." } ;
 
 HELP: >words
 { $values { "str" string } { "words" "an array of strings" } }

basis/unicode/breaks/breaks-tests.factor

@@ -12,6 +12,11 @@ IN: unicode.breaks.tests
 [ 3 ] [ 2 "hello" first-grapheme-from ] unit-test
 [ 1 ] [ 2 "hello" last-grapheme-from ] unit-test
 
+[ 4 ] [ 2 "what am I saying" first-word-from ] unit-test
+[ 0 ] [ 2 "what am I saying" last-word-from ] unit-test
+[ 16 ] [ 11 "what am I saying" first-word-from ] unit-test
+[ 10 ] [ 11 "what am I saying" last-word-from ] unit-test
+
 : grapheme-break-test ( -- filename )
     "vocab:unicode/breaks/GraphemeBreakTest.txt" ;
 

basis/unicode/breaks/breaks.factor

@@ -247,3 +247,12 @@ PRIVATE>
             word-break-next nip
         ]
     } 2|| ;
+
+: first-word-from ( start str -- i )
+    over tail-slice first-word + ;
+
+: last-word ( str -- i )
+    [ length ] keep '[ _ word-break-at? ] find-last drop 0 or ;
+
+: last-word-from ( end str -- i )
+    swap head-slice last-word ;