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

basis/alarms/alarms-tests.factor

@@ -1,6 +1,6 @@
-IN: alarms.tests
 USING: alarms alarms.private kernel calendar sequences
 tools.test threads concurrency.count-downs ;
+IN: alarms.tests
 
 [ ] [
     1 <count-down>

basis/alarms/alarms.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators generic init
+USING: accessors assocs boxes calendar
-kernel math namespaces sequences heaps boxes threads
+combinators.short-circuit fry heaps init kernel math.order
-quotations assocs math.order ;
+namespaces quotations threads ;
 IN: alarms
 
 TUPLE: alarm
@@ -21,21 +21,21 @@ SYMBOL: alarm-thread
 
 ERROR: bad-alarm-frequency frequency ;
 : check-alarm ( frequency/f -- frequency/f )
-    dup [ duration? ] [ not ] bi or [ bad-alarm-frequency ] unless ;
+    dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
 
 : <alarm> ( quot time frequency -- alarm )
     check-alarm <box> alarm boa ;
 
 : register-alarm ( alarm -- )
-    dup dup time>> alarms get-global heap-push*
+    [ dup time>> alarms get-global heap-push* ]
-    swap entry>> >box
+    [ entry>> >box ] bi
     notify-alarm-thread ;
 
 : alarm-expired? ( alarm now -- ? )
     [ time>> ] dip before=? ;
 
 : reschedule-alarm ( alarm -- )
-    dup [ swap interval>> time+ now max ] change-time register-alarm ;
+    dup '[ _ interval>> time+ now max ] change-time register-alarm ;
 
 : call-alarm ( alarm -- )
     [ entry>> box> drop ]

basis/alien/c-types/c-types-tests.factor

@@ -1,6 +1,6 @@
-IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc alien.strings io.encodings.utf8 ;
+IN: alien.c-types.tests
 
 CONSTANT: xyz 123
 

basis/alien/complex/functor/functor-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.complex.functor ;
-IN: alien.complex.functor.tests

basis/alien/destructors/destructors-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.destructors ;
-IN: alien.destructors.tests

basis/alien/libraries/libraries-tests.factor

@@ -1,5 +1,5 @@
-IN: alien.libraries.tests
 USING: alien.libraries alien.syntax tools.test kernel ;
+IN: alien.libraries.tests
 
 [ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
 

basis/alien/structs/structs-tests.factor

@@ -1,6 +1,6 @@
-IN: alien.structs.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc words vocabs namespaces layouts ;
+IN: alien.structs.tests
 
 C-STRUCT: bar
     { "int" "x" }

basis/alien/syntax/syntax.factor

@@ -31,8 +31,10 @@ SYNTAX: C-ENUM:
     ";" parse-tokens
     [ [ create-in ] dip define-constant ] each-index ;
 
+ERROR: no-such-symbol name library ;
+
 : address-of ( name library -- value )
-    load-library dlsym [ "No such symbol" throw ] unless* ;
+    2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
 
 SYNTAX: &:
     scan "c-library" get '[ _ _ address-of ] over push-all ;

basis/biassocs/biassocs-tests.factor

@@ -1,5 +1,5 @@
+USING: biassocs assocs namespaces tools.test hashtables kernel ;
 IN: biassocs.tests
-USING: biassocs assocs namespaces tools.test ;
 
 <bihash> "h" set
 
@@ -30,3 +30,13 @@ H{ { "a" "A" } { "b" "B" } } "a" set
 [ "A" ] [ "a" "b" get at ] unit-test
 
 [ "a" ] [ "A" "b" get value-at ] unit-test
+
+[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test
+
+[ ] [ "h" get clone "g" set ] unit-test
+
+[ ] [ 3 4 "g" get set-at ] unit-test
+
+[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test
+
+[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test

basis/biassocs/biassocs.factor

@@ -44,3 +44,6 @@ INSTANCE: biassoc assoc
 
 : >biassoc ( assoc -- biassoc )
     T{ biassoc } assoc-clone-like ;
+
+M: biassoc clone
+    [ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;

basis/binary-search/binary-search-tests.factor

@@ -1,5 +1,5 @@
-IN: binary-search.tests
 USING: binary-search math.order vectors kernel tools.test ;
+IN: binary-search.tests
 
 [ f ] [ 3 { } [ <=> ] with search drop ] unit-test
 [ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
@@ -9,7 +9,7 @@ USING: binary-search math.order vectors kernel tools.test ;
 [ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
 [ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
 
-[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
+[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
-[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
+[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test
-[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "hello" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
-[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test
+[ f ] [ "zebra" { "alligator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test

basis/bit-arrays/bit-arrays.factor

@@ -44,33 +44,33 @@ PRIVATE>
 : <bit-array> ( n -- bit-array )
     dup bits>bytes <byte-array> bit-array boa ; inline
 
-M: bit-array length length>> ;
+M: bit-array length length>> ; inline
 
 M: bit-array nth-unsafe
-    [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
+    [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
 
 M: bit-array set-nth-unsafe
     [ >fixnum ] [ underlying>> ] bi*
     [ byte/bit set-bit ] 2keep
-    swap n>byte set-alien-unsigned-1 ;
+    swap n>byte set-alien-unsigned-1 ; inline
 
 GENERIC: clear-bits ( bit-array -- )
 
-M: bit-array clear-bits 0 (set-bits) ;
+M: bit-array clear-bits 0 (set-bits) ; inline
 
 GENERIC: set-bits ( bit-array -- )
 
-M: bit-array set-bits -1 (set-bits) ;
+M: bit-array set-bits -1 (set-bits) ; inline
 
 M: bit-array clone
-    [ length>> ] [ underlying>> clone ] bi bit-array boa ;
+    [ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
 
 : >bit-array ( seq -- bit-array )
     T{ bit-array f 0 B{ } } clone-like ; inline
 
-M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
+M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
 
-M: bit-array new-sequence drop <bit-array> ;
+M: bit-array new-sequence drop <bit-array> ; inline
 
 M: bit-array equal?
     over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
@@ -81,7 +81,7 @@ M: bit-array resize
         resize-byte-array
     ] 2bi
     bit-array boa
-    dup clean-up ;
+    dup clean-up ; inline
 
 M: bit-array byte-length length 7 + -3 shift ;
 

basis/bit-sets/bit-sets-tests.factor

@@ -1,5 +1,5 @@
-IN: bit-sets.tests
 USING: bit-sets tools.test bit-arrays ;
+IN: bit-sets.tests
 
 [ ?{ t f t f t f } ] [
     ?{ t f f f t f }

basis/bit-vectors/bit-vectors-tests.factor

@@ -1,5 +1,5 @@
-IN: bit-vectors.tests
 USING: tools.test bit-vectors vectors sequences kernel math ;
+IN: bit-vectors.tests
 
 [ 0 ] [ 123 <bit-vector> length ] unit-test
 

basis/bitstreams/bitstreams-tests.factor

@@ -5,7 +5,6 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
 io.streams.byte-array ;
 IN: bitstreams.tests
 
-
 [ BIN: 1111111111 ]
 [
     B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>

basis/bootstrap/compiler/compiler.factor

@@ -35,6 +35,8 @@ gc
 : compile-unoptimized ( words -- )
     [ optimized? not ] filter compile ;
 
+"debug-compiler" get [
+    
     nl
     "Compiling..." write flush
 
@@ -74,7 +76,7 @@ nl
     "." write flush
 
     {
-    + 1+ 1- 2/ < <= > >= shift
+        + 2/ < <= > >= shift
     } compile-unoptimized
 
     "." write flush
@@ -115,3 +117,5 @@ nl
     vocabs [ words compile-unoptimized "." write flush ] each
 
     " done" print flush
+
+] unless

basis/bootstrap/image/image-tests.factor

@@ -1,6 +1,6 @@
-IN: bootstrap.image.tests
 USING: bootstrap.image bootstrap.image.private tools.test
 kernel math ;
+IN: bootstrap.image.tests
 
 [ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
 

basis/bootstrap/tools/tools.factor

@@ -14,6 +14,7 @@ IN: bootstrap.tools
     "tools.test"
     "tools.time"
     "tools.threads"
+    "tools.deprecation"
     "vocabs.hierarchy"
     "vocabs.refresh"
     "vocabs.refresh.monitor"

basis/boxes/boxes-tests.factor

@@ -1,5 +1,5 @@
-IN: boxes.tests
 USING: boxes namespaces tools.test accessors ;
+IN: boxes.tests
 
 [ ] [ <box> "b" set ] unit-test
 

basis/byte-arrays/hex/hex.factor

@@ -8,4 +8,3 @@ SYNTAX: HEX{
     [ blank? not ] filter
     2 group [ hex> ] B{ } map-as
     parsed ;
-

basis/cache/cache-tests.factor

@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test cache ;
-IN: cache.tests

basis/cairo/cairo-tests.factor

@@ -1,5 +1,5 @@
-IN: cairo.tests
 USING: cairo tools.test math.rectangles accessors ;
+IN: cairo.tests
 
 [ { 10 20 } ] [
     { 10 20 } [

basis/calendar/calendar-docs.factor

@@ -27,7 +27,7 @@ HELP: <date>
 } ;
 
 HELP: month-names
-{ $values { "array" array } }
+{ $values { "value" object } }
 { $description "Returns an array with the English names of all the months." }
 { $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
 

basis/calendar/calendar.factor

@@ -34,22 +34,22 @@ C: <timestamp> timestamp
 : <date> ( year month day -- timestamp )
     0 0 0 gmt-offset-duration <timestamp> ;
 
-ERROR: not-a-month n ;
+ERROR: not-a-month ;
 M: not-a-month summary
     drop "Months are indexed starting at 1" ;
 
 <PRIVATE
 
 : check-month ( n -- n )
-    dup zero? [ not-a-month ] when ;
+    [ not-a-month ] when-zero ;
 
 PRIVATE>
 
-: month-names ( -- array )
+CONSTANT: month-names 
     {
         "January" "February" "March" "April" "May" "June"
         "July" "August" "September" "October" "November" "December"
-    } ;
+    }
 
 : month-name ( n -- string )
     check-month 1 - month-names nth ;
@@ -186,9 +186,6 @@ GENERIC: +second ( timestamp x -- timestamp )
     { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&&
     [ 3 >>month 1 >>day ] when ;
 
-: unless-zero ( n quot -- )
-    [ dup zero? [ drop ] ] dip if ; inline
-
 M: integer +year ( timestamp n -- timestamp )
     [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
 
@@ -196,7 +193,7 @@ M: real +year ( timestamp n -- timestamp )
     [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
 
 : months/years ( n -- months years )
-    12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
+    12 /rem [ 1 - 12 ] when-zero swap ; inline
 
 M: integer +month ( timestamp n -- timestamp )
     [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;

basis/calendar/format/format.factor

@@ -162,7 +162,7 @@ M: timestamp year. ( timestamp -- )
 
 : read-rfc3339-seconds ( s -- s' ch )
     "+-Z" read-until [
-        [ string>number ] [ length 10 swap ^ ] bi / +
+        [ string>number ] [ length 10^ ] bi / +
     ] dip ;
 
 : (rfc3339>timestamp) ( -- timestamp )

basis/checksums/fnv1/fnv1.factor

@@ -1,9 +1,7 @@
 ! Copyright (C) 2009 Alaric Snell-Pym
 ! See http://factorcode.org/license.txt for BSD license.
-
 USING: checksums classes.singleton kernel math math.ranges
 math.vectors sequences ;
-
 IN: checksums.fnv1
 
 SINGLETON: fnv1-32

basis/checksums/md5/md5-tests.factor

@@ -1,6 +1,8 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: byte-arrays checksums checksums.md5 io.encodings.binary
 io.streams.byte-array kernel math namespaces tools.test ;
-
+IN: checksums.md5.tests 
 
 [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
 [ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test

basis/circular/circular-tests.factor

@@ -2,6 +2,7 @@
 ! See http;//factorcode.org/license.txt for BSD license
 USING: arrays kernel tools.test sequences sequences.private
 circular strings ;
+IN: circular.tests
 
 [ 0 ] [ { 0 1 2 3 4 } <circular> 0 swap virtual@ drop ] unit-test
 [ 2 ] [ { 0 1 2 3 4 } <circular> 2 swap virtual@ drop ] unit-test

basis/cocoa/callbacks/callbacks.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Kevin Reid.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: cocoa.callbacks
 USING: assocs kernel namespaces cocoa cocoa.classes
 cocoa.subclassing debugger ;
+IN: cocoa.callbacks
 
 SYMBOL: callbacks
 

basis/cocoa/cocoa-tests.factor

@@ -1,7 +1,7 @@
-IN: cocoa.tests
 USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
 compiler kernel namespaces cocoa.classes tools.test memory
 compiler.units math core-graphics.types ;
+IN: cocoa.tests
 
 CLASS: {
     { +superclass+ "NSObject" }

basis/cocoa/plists/plists-tests.factor

@@ -1,7 +1,7 @@
-IN: cocoa.plists.tests
 USING: tools.test cocoa.plists colors kernel hashtables
 core-foundation.utilities core-foundation destructors
 assocs cocoa.enumeration ;
+IN: cocoa.plists.tests
 
 [
     [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test

basis/colors/hsv/hsv-tests.factor

@@ -1,5 +1,5 @@
-IN: colors.hsv.tests
 USING: accessors kernel colors colors.hsv tools.test math ;
+IN: colors.hsv.tests
 
 : hsv>rgb ( h s v -- r g b )
     [ 360 * ] 2dip

basis/columns/columns-tests.factor

@@ -1,5 +1,5 @@
-IN: columns.tests
 USING: columns sequences kernel namespaces arrays tools.test math ;
+IN: columns.tests
 
 ! Columns
 { { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set

basis/combinators/short-circuit/smart/smart-tests.factor

@@ -1,32 +1,18 @@
-
 USING: kernel math tools.test combinators.short-circuit.smart ;
-
 IN: combinators.short-circuit.smart.tests
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [       { [ 1 ] [ 2 ] [ 3 ] }          &&  3 = ] unit-test
+[ t ] [ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    &&  5 = ] unit-test
+[ t ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] unit-test
 
-: must-be-t ( in -- ) [ t ] swap unit-test ;
+[ f ] [       { [ 1 ] [ f ] [ 3 ] } &&  3 = ]          unit-test
-: must-be-f ( in -- ) [ f ] swap unit-test ;
+[ f ] [ 3     { [ 0 > ] [ even? ] [ 2 + ] } && ]       unit-test
+[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] unit-test
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ t ] [ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] unit-test
 
-[       { [ 1 ] [ 2 ] [ 3 ] }          &&  3 = ] must-be-t
+[ t ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ]       unit-test
-[ 3     { [ 0 > ] [ odd? ] [ 2 + ] }    &&  5 = ] must-be-t
-[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t
 
-[       { [ 1 ] [ f ] [ 3 ] } &&  3 = ]          must-be-f
+[ t ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ]  unit-test
-[ 3     { [ 0 > ] [ even? ] [ 2 + ] } && ]       must-be-f
-[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t
-
-[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ]       must-be-t
-
-[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ]  must-be-t
-
-[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] unit-test

basis/combinators/short-circuit/smart/smart.factor

@@ -1,12 +1,14 @@
-USING: kernel sequences math stack-checker effects accessors macros
+USING: kernel sequences math stack-checker effects accessors
-fry combinators.short-circuit ;
+macros fry combinators.short-circuit ;
 IN: combinators.short-circuit.smart
 
 <PRIVATE
 
+ERROR: cannot-determine-arity ;
+
 : arity ( quots -- n )
     first infer
-    dup terminated?>> [ "Cannot determine arity" throw ] when
+    dup terminated?>> [ cannot-determine-arity ] when
     effect-height neg 1 + ;
 
 PRIVATE>

basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor

@@ -1 +0,0 @@
-IN: compiler.cfg.alias-analysis.tests

basis/compiler/cfg/builder/builder-tests.factor

@@ -1,11 +1,11 @@
-IN: compiler.cfg.builder.tests
 USING: tools.test kernel sequences words sequences.private fry
 prettyprint alien alien.accessors math.private compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
 compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
 compiler.cfg arrays locals byte-arrays kernel.private math
 slots.private vectors sbufs strings math.partial-dispatch
-strings.private ;
+strings.private accessors compiler.cfg.instructions ;
+IN: compiler.cfg.builder.tests
 
 ! Just ensure that various CFGs build correctly.
 : unit-test-cfg ( quot -- )
@@ -157,3 +157,26 @@ strings.private ;
     { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
     { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
 ] each
+
+: contains-insn? ( quot insn-check -- ? )
+    [ test-mr [ instructions>> ] map ] dip
+    '[ _ any? ] any? ; inline
+
+[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
+
+[ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
+
+[ t ] [
+    [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
+    [ ##set-alien-integer-1? ] contains-insn?
+] unit-test
+
+[ t ] [
+    [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
+    [ ##set-alien-integer-1? ] contains-insn?
+] unit-test
+
+[ f ] [
+    [ { byte-array fixnum } declare set-alien-unsigned-1 ]
+    [ ##set-alien-integer-1? ] contains-insn?
+] unit-test

basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor

@@ -5,7 +5,7 @@ namespaces functors compiler.cfg.rpo compiler.cfg.utilities
 compiler.cfg.predecessors compiler.cfg ;
 IN: compiler.cfg.dataflow-analysis
 
-GENERIC: join-sets ( sets dfa -- set )
+GENERIC: join-sets ( sets bb dfa -- set )
 GENERIC: transfer-set ( in-set bb dfa -- out-set )
 GENERIC: block-order ( cfg dfa -- bbs )
 GENERIC: successors ( bb dfa -- seq )
@@ -23,7 +23,11 @@ GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
 M: kill-block compute-in-set 3drop f ;
 
 M:: basic-block compute-in-set ( bb out-sets dfa -- set )
-    bb dfa predecessors [ out-sets at ] map dfa join-sets ;
+    ! Only consider initialized sets.
+    bb dfa predecessors
+    [ out-sets key? ] filter
+    [ out-sets at ] map
+    bb dfa join-sets ;
 
 :: update-in-set ( bb in-sets out-sets dfa -- ? )
     bb out-sets dfa compute-in-set
@@ -56,7 +60,7 @@ M:: basic-block compute-out-set ( bb in-sets dfa -- set )
     in-sets
     out-sets ; inline
 
-M: dataflow-analysis join-sets drop assoc-refine ;
+M: dataflow-analysis join-sets 2drop assoc-refine ;
 
 FUNCTOR: define-analysis ( name -- )
 

basis/compiler/cfg/def-use/def-use-tests.factor

@@ -8,6 +8,7 @@ compiler.cfg
 compiler.cfg.debugger
 compiler.cfg.instructions
 compiler.cfg.registers ;
+IN: compiler.cfg.def-use.tests
 
 V{
     T{ ##peek f 0 D 0 }

basis/compiler/cfg/dominance/dominance-tests.factor

@@ -1,7 +1,7 @@
-IN: compiler.cfg.dominance.tests
 USING: tools.test sequences vectors namespaces kernel accessors assocs sets
 math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
 compiler.cfg.predecessors ;
+IN: compiler.cfg.dominance.tests
 
 : test-dominance ( -- )
     cfg new 0 get >>entry

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

@@ -1,8 +1,8 @@
-IN: compiler.cfg.gc-checks.tests
 USING: compiler.cfg.gc-checks compiler.cfg.debugger
 compiler.cfg.registers compiler.cfg.instructions compiler.cfg
 compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
 namespaces accessors sequences ;
+IN: compiler.cfg.gc-checks.tests
 
 : test-gc-checks ( -- )
     H{ } clone representations set

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

@@ -1,9 +1,9 @@
-IN: compiler.cfg.linear-scan.resolve.tests
 USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
 accessors
 compiler.cfg
 compiler.cfg.instructions cpu.architecture make sequences
 compiler.cfg.linear-scan.allocation.state ;
+IN: compiler.cfg.linear-scan.resolve.tests
 
 [
     {

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

@@ -65,7 +65,7 @@ SYMBOL: temp
 
 : perform-mappings ( bb to mappings -- )
     dup empty? [ 3drop ] [
-        mapping-instructions <simple-block> insert-basic-block
+        mapping-instructions insert-simple-basic-block
         cfg get cfg-changed drop
     ] if ;
 

basis/compiler/cfg/linearization/linearization-tests.factor

@@ -1,4 +0,0 @@
-IN: compiler.cfg.linearization.tests
-USING: compiler.cfg.linearization tools.test ;
-
-

basis/compiler/cfg/liveness/liveness.factor

@@ -28,4 +28,4 @@ M: live-analysis transfer-set
     drop instructions>> transfer-liveness ;
 
 M: live-analysis join-sets
-    drop assoc-combine ;
+    2drop assoc-combine ;

basis/compiler/cfg/loop-detection/loop-detection-tests.factor

@@ -1,8 +1,8 @@
-IN: compiler.cfg.loop-detection.tests
 USING: compiler.cfg compiler.cfg.loop-detection
 compiler.cfg.predecessors
 compiler.cfg.debugger
 tools.test kernel namespaces accessors ;
+IN: compiler.cfg.loop-detection.tests
 
 V{ } 0 test-bb
 V{ } 1 test-bb

basis/compiler/cfg/loop-detection/loop-detection.factor

@@ -6,10 +6,10 @@ IN: compiler.cfg.loop-detection
 
 TUPLE: natural-loop header index ends blocks ;
 
-<PRIVATE
-
 SYMBOL: loops
 
+<PRIVATE
+
 : <natural-loop> ( header index -- loop )
     H{ } clone H{ } clone natural-loop boa ;
 

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -45,7 +45,7 @@ ERROR: bad-peek dst loc ;
     ! computing anything.
     2dup [ kill-block? ] both? [ 2drop ] [
         2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
-        [ 2drop ] [ <simple-block> insert-basic-block ] if-empty
+        [ 2drop ] [ insert-simple-basic-block ] if-empty
     ] if ;
 
 : visit-block ( bb -- )

basis/compiler/cfg/stacks/global/global.factor

@@ -21,7 +21,7 @@ BACKWARD-ANALYSIS: live
 
 M: live-analysis transfer-set drop transfer-peeked-locs ;
 
-M: live-analysis join-sets drop assoc-combine ;
+M: live-analysis join-sets 2drop assoc-combine ;
 
 ! A stack location is available at a location if all paths from
 ! the entry block to the location load the location into a

basis/compiler/cfg/stacks/local/local.factor

@@ -69,18 +69,11 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
 
 : peek-loc ( loc -- vreg )
     translate-local-loc
-    dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
+    dup replace-mapping get at
-    dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
+    [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
 
 : replace-loc ( vreg loc -- )
-    translate-local-loc
+    translate-local-loc replace-mapping get set-at ;
-    2dup loc>vreg =
-    [ nip replace-mapping get delete-at ]
-    [
-        [ local-replace-set get conjoin ]
-        [ replace-mapping get set-at ]
-        bi
-    ] if ;
 
 : compute-local-kill-set ( -- assoc )
     basic-block get current-height get
@@ -90,13 +83,17 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
 
 : begin-local-analysis ( -- )
     H{ } clone local-peek-set set
-    H{ } clone local-replace-set set
     H{ } clone replace-mapping set
     current-height get
     [ 0 >>emit-d 0 >>emit-r drop ]
     [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
 
+: remove-redundant-replaces ( -- )
+    replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
+    [ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
+
 : end-local-analysis ( -- )
+    remove-redundant-replaces
     emit-changes
     basic-block get {
         [ [ local-peek-set get ] dip peek-sets get set-at ]

basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor

@@ -1,8 +1,8 @@
-IN: compiler.cfg.stacks.uninitialized.tests
 USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger
 compiler.cfg.registers compiler.cfg.instructions compiler.cfg
 compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
 namespaces accessors sequences ;
+IN: compiler.cfg.stacks.uninitialized.tests
 
 : test-uninitialized ( -- )
     cfg new 0 get >>entry

basis/compiler/cfg/stacks/uninitialized/uninitialized.factor

@@ -65,7 +65,7 @@ M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
     drop [ prepare ] dip visit-block finish ;
 
 M: uninitialized-analysis join-sets ( sets analysis -- pair )
-    drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
+    2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
 
 : uninitialized-locs ( bb -- locs )
     uninitialized-in dup [

basis/compiler/cfg/two-operand/two-operand-tests.factor

@@ -1,6 +1,6 @@
-IN: compiler.cfg.two-operand.tests
 USING: kernel compiler.cfg.two-operand compiler.cfg.instructions
 compiler.cfg.registers cpu.architecture namespaces tools.test ;
+IN: compiler.cfg.two-operand.tests
 
 3 vreg-counter set-global
 

basis/compiler/cfg/utilities/utilities.factor

@@ -3,7 +3,7 @@
 USING: accessors assocs combinators combinators.short-circuit
 cpu.architecture kernel layouts locals make math namespaces sequences
 sets vectors fry compiler.cfg compiler.cfg.instructions
-compiler.cfg.rpo ;
+compiler.cfg.rpo arrays ;
 IN: compiler.cfg.utilities
 
 PREDICATE: kill-block < basic-block
@@ -37,16 +37,16 @@ SYMBOL: visited
 : skip-empty-blocks ( bb -- bb' )
     H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
 
-:: insert-basic-block ( from to bb -- )
+:: insert-basic-block ( froms to bb -- )
-    bb from 1vector >>predecessors drop
+    bb froms V{ } like >>predecessors drop
     bb to 1vector >>successors drop
-    to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
+    to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each
-    from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
+    froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
 
 : add-instructions ( bb quot -- )
     [ instructions>> building ] dip '[
         building get pop
-        @
+        [ @ ] dip
         ,
     ] with-variable ; inline
 
@@ -56,6 +56,9 @@ SYMBOL: visited
     \ ##branch new-insn over push
     >>instructions ;
 
+: insert-simple-basic-block ( from to insns -- )
+    [ 1vector ] 2dip <simple-block> insert-basic-block ;
+
 : has-phis? ( bb -- ? )
     instructions>> first ##phi? ;
 

basis/compiler/cfg/write-barrier/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Daniel Ehrenberg

basis/compiler/cfg/write-barrier/write-barrier-tests.factor

@@ -1,7 +1,16 @@
-USING: compiler.cfg.write-barrier compiler.cfg.instructions
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
-compiler.cfg.registers compiler.cfg.debugger cpu.architecture
+! See http://factorcode.org/license.txt for BSD license.
-arrays tools.test vectors compiler.cfg kernel accessors
+USING: accessors arrays assocs compiler.cfg
-compiler.cfg.utilities ;
+compiler.cfg.alias-analysis compiler.cfg.block-joining
+compiler.cfg.branch-splitting compiler.cfg.copy-prop
+compiler.cfg.dce compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.loop-detection
+compiler.cfg.registers compiler.cfg.ssa.construction
+compiler.cfg.tco compiler.cfg.useless-conditionals
+compiler.cfg.utilities compiler.cfg.value-numbering
+compiler.cfg.write-barrier cpu.architecture kernel
+kernel.private math namespaces sequences sequences.private
+tools.test vectors ;
 IN: compiler.cfg.write-barrier.tests
 
 : test-write-barrier ( insns -- insns )
@@ -70,3 +79,112 @@ IN: compiler.cfg.write-barrier.tests
         T{ ##write-barrier f 19 30 3 }
     } test-write-barrier
 ] unit-test
+
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 1 test-bb
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+} ] [ 2 get instructions>> ] unit-test
+
+V{
+    T{ ##allot f 1 }
+} 1 test-bb
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+    T{ ##allot f 1 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+} ] [ 2 get instructions>> ] unit-test
+
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 1 test-bb
+V{
+    T{ ##allot }
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{
+    T{ ##allot }
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 2 get instructions>> ] unit-test
+
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 1 test-bb
+V{
+    T{ ##allot }
+} 2 test-bb
+1 get 2 get 1vector >>successors drop
+V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} 3 test-bb
+2 get 3 get 1vector >>successors drop
+cfg new 1 get >>entry 0 set
+[ ] [ 0 [ eliminate-write-barriers ] change ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 1 get instructions>> ] unit-test
+[ V{ T{ ##allot } } ] [ 2 get instructions>> ] unit-test
+[ V{
+    T{ ##set-slot-imm f 2 1 3 4 }
+    T{ ##write-barrier f 1 2 3 }
+} ] [ 3 get instructions>> ] unit-test
+
+: reverse-here' ( seq -- )
+    { array } declare
+    [ length 2/ iota ] [ length ] [ ] tri
+    [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
+
+: write-barrier-stats ( word -- cfg )
+    test-cfg first [
+        optimize-tail-calls
+        delete-useless-conditionals
+        split-branches
+        join-blocks
+        construct-ssa
+        alias-analysis
+        value-numbering
+        copy-propagation
+        eliminate-dead-code
+        eliminate-write-barriers
+    ] with-cfg
+    post-order>> write-barriers
+    [ [ loop-nesting-at ] [ length ] bi* ] assoc-map ;
+
+[ { { 0 1 } } ] [ \ reverse-here' write-barrier-stats ] unit-test

basis/compiler/cfg/write-barrier/write-barrier.factor

@@ -1,7 +1,16 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces assocs sets sequences
-compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+fry combinators.short-circuit locals make arrays
+compiler.cfg
+compiler.cfg.dominance
+compiler.cfg.predecessors
+compiler.cfg.loop-detection
+compiler.cfg.rpo
+compiler.cfg.instructions 
+compiler.cfg.registers
+compiler.cfg.dataflow-analysis 
+compiler.cfg.utilities ;
 IN: compiler.cfg.write-barrier
 
 ! Eliminate redundant write barrier hits.
@@ -19,21 +28,112 @@ M: ##allot eliminate-write-barrier
     dst>> safe get conjoin t ;
 
 M: ##write-barrier eliminate-write-barrier
-    src>> dup [ safe get key? not ] [ mutated get key? ] bi and
+    src>> dup safe get key? not
     [ safe get conjoin t ] [ drop f ] if ;
 
-M: ##set-slot eliminate-write-barrier
-    obj>> mutated get conjoin t ;
-
-M: ##set-slot-imm eliminate-write-barrier
-    obj>> mutated get conjoin t ;
-
 M: insn eliminate-write-barrier drop t ;
 
+! This doesn't actually benefit from being a dataflow analysis
+! might as well be dominator-based
+! Dealing with phi functions would help, though
+FORWARD-ANALYSIS: safe
+
+: has-allocation? ( bb -- ? )
+    instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;
+
+M: safe-analysis transfer-set
+    drop [ H{ } assoc-clone-like safe set ] dip
+    instructions>> [
+        eliminate-write-barrier drop
+    ] each safe get ;
+
+M: safe-analysis join-sets
+    drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
+
 : write-barriers-step ( bb -- )
-    H{ } clone safe set
+    dup safe-in H{ } assoc-clone-like safe set
-    H{ } clone mutated set
     instructions>> [ eliminate-write-barrier ] filter-here ;
 
+GENERIC: remove-dead-barrier ( insn -- ? )
+
+M: ##write-barrier remove-dead-barrier
+    src>> mutated get key? ;
+
+M: ##set-slot remove-dead-barrier
+    obj>> mutated get conjoin t ;
+
+M: ##set-slot-imm remove-dead-barrier
+    obj>> mutated get conjoin t ;
+
+M: insn remove-dead-barrier drop t ;
+
+: remove-dead-barriers ( bb -- )
+    H{ } clone mutated set
+    instructions>> [ remove-dead-barrier ] filter-here ;
+
+! Availability of slot
+! Anticipation of this and set-slot would help too, maybe later
+FORWARD-ANALYSIS: slot
+
+UNION: access ##read ##write ;
+
+M: slot-analysis transfer-set
+    drop [ H{ } assoc-clone-like ] dip
+    instructions>> over '[
+        dup access? [
+            obj>> _ conjoin
+        ] [ drop ] if
+    ] each ;
+
+: slot-available? ( vreg bb -- ? )
+    slot-in key? ;
+
+: make-barriers ( vregs -- bb )
+    [ [ next-vreg next-vreg ##write-barrier ] each ] V{ } make <simple-block> ;
+
+: emit-barriers ( vregs loop -- )
+    swap [
+        [ [ header>> predecessors>> ] [ ends>> keys ] bi diff ]
+        [ header>> ] bi
+    ] [ make-barriers ] bi*
+    insert-basic-block ;
+
+: write-barriers ( bbs -- bb=>barriers )
+    [
+        dup instructions>>
+        [ ##write-barrier? ] filter
+        [ src>> ] map
+    ] { } map>assoc
+    [ nip empty? not ] assoc-filter ;
+
+: filter-dominant ( bb=>barriers bbs -- barriers )
+    '[ drop _ [ dominates? ] with all? ] assoc-filter
+    values concat prune ;
+
+: dominant-write-barriers ( loop -- vregs )
+    [ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ;
+
+: safe-loops ( -- loops )
+    loops get values
+    [ blocks>> keys [ has-allocation? not ] all? ] filter ;
+
+:: insert-extra-barriers ( cfg -- )
+    safe-loops [| loop |
+        cfg needs-dominance needs-predecessors drop
+        loop dominant-write-barriers
+        loop header>> '[ _ slot-available? ] filter
+        [ loop emit-barriers cfg cfg-changed drop ] unless-empty
+    ] each ;
+
+: contains-write-barrier? ( cfg -- ? )
+    post-order [ instructions>> [ ##write-barrier? ] any? ] any? ;
+
 : eliminate-write-barriers ( cfg -- cfg' )
-    dup [ write-barriers-step ] each-basic-block ;
+    dup contains-write-barrier? [
+        needs-loops
+        dup [ remove-dead-barriers ] each-basic-block
+        dup compute-slot-sets
+        dup insert-extra-barriers
+        dup compute-safe-sets
+        dup [ write-barriers-step ] each-basic-block
+    ] when ;

basis/compiler/codegen/codegen-tests.factor

@@ -1,6 +1,6 @@
-IN: compiler.codegen.tests
 USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
 compiler.constants ;
+IN: compiler.codegen.tests
 
 [ ] [ [ ] with-fixup drop ] unit-test
 [ ] [ [ \ + %call ] with-fixup drop ] unit-test

basis/compiler/compiler.factor

@@ -120,7 +120,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
     } cond ;
 
 : optimize? ( word -- ? )
-    { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
+    single-generic? not ;
 
 : contains-breakpoints? ( -- ? )
     dependencies get keys [ "break?" word-prop ] any? ;

basis/compiler/tests/call-effect.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.call-effect
 USING: tools.test combinators generic.single sequences kernel ;
+IN: compiler.tests.call-effect
 
 : execute-ic-test ( a b -- c ) execute( a -- c ) ;
 

basis/compiler/tests/float.factor

@@ -1,6 +1,6 @@
-IN: compiler.tests.float
 USING: compiler.units compiler kernel kernel.private memory math
 math.private tools.test math.floats.private ;
+IN: compiler.tests.float
 
 [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
 [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test

basis/compiler/tests/generic.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.generic
 USING: tools.test math kernel compiler.units definitions ;
+IN: compiler.tests.generic
 
 GENERIC: bad ( -- )
 M: integer bad ;

basis/compiler/tests/optimizer.factor

@@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private
 quotations classes classes.algebra classes.tuple.private
 continuations growable namespaces hints alien.accessors
 compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler definitions ;
+compiler definitions generic.single ;
 IN: compiler.tests.optimizer
 
 GENERIC: xyz ( obj -- obj )
@@ -423,3 +423,6 @@ M: object bad-dispatch-position-test* ;
         \ bad-dispatch-position-test* forget
     ] with-compilation-unit
 ] unit-test
+
+! Not sure if I want to fix this...
+! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with

basis/compiler/tests/peg-regression-2.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.peg-regression-2
 USING: peg.ebnf strings tools.test ;
+IN: compiler.tests.peg-regression-2
 
 GENERIC: <times> ( times -- term' )
 M: string <times> ;

basis/compiler/tests/pic-problem-1.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.pic-problem-1
 USING: kernel sequences prettyprint memory tools.test ;
+IN: compiler.tests.pic-problem-1
 
 TUPLE: x ;
 

basis/compiler/tests/redefine0.factor

@@ -1,6 +1,6 @@
-IN: compiler.tests.redefine0
 USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
 namespaces macros assocs ;
+IN: compiler.tests.redefine0
 
 ! Test ripple-up behavior
 : test-1 ( -- a ) 3 ;

basis/compiler/tests/redefine16.factor

@@ -1,6 +1,6 @@
-IN: compiler.tests.redefine16
 USING: eval tools.test definitions words compiler.units
 quotations stack-checker ;
+IN: compiler.tests.redefine16
 
 [ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
 

basis/compiler/tests/redefine17.factor

@@ -1,6 +1,6 @@
-IN: compiler.tests.redefine17
 USING: tools.test classes.mixin compiler.units arrays kernel.private
 strings sequences vocabs definitions kernel ;
+IN: compiler.tests.redefine17
 
 << "compiler.tests.redefine17" words forget-all >>
 

basis/compiler/tests/redefine2.factor

@@ -1,7 +1,7 @@
-IN: compiler.tests.redefine2
 USING: compiler compiler.units tools.test math parser kernel
 sequences sequences.private classes.mixin generic definitions
 arrays words assocs eval words.symbol ;
+IN: compiler.tests.redefine2
 
 DEFER: redefine2-test
 

basis/compiler/tests/redefine3.factor

@@ -1,15 +1,15 @@
-IN: compiler.tests.redefine3
 USING: accessors compiler compiler.units tools.test math parser
 kernel sequences sequences.private classes.mixin generic
 definitions arrays words assocs eval ;
+IN: compiler.tests.redefine3
 
 GENERIC: sheeple ( obj -- x )
 
-M: object sheeple drop "sheeple" ;
+M: object sheeple drop "sheeple" ; inline
 
 MIXIN: empty-mixin
 
-M: empty-mixin sheeple drop "wake up" ;
+M: empty-mixin sheeple drop "wake up" ; inline
 
 : sheeple-test ( -- string ) { } sheeple ;
 

basis/compiler/tests/redefine4.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.redefine4
 USING: io.streams.string kernel tools.test eval ;
+IN: compiler.tests.redefine4
 
 : declaration-test-1 ( -- a ) 3 ; flushable
 

basis/compiler/tests/reload.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.reload
 USE: vocabs.loader
+IN: compiler.tests.reload
 
 ! "parser" reload
 ! "sequences" reload

basis/compiler/tests/stack-trace.factor

@@ -1,7 +1,7 @@
-IN: compiler.tests.stack-trace
 USING: compiler tools.test namespaces sequences
 kernel.private kernel math continuations continuations.private
 words splitting grouping sorting accessors ;
+IN: compiler.tests.stack-trace
 
 : symbolic-stack-trace ( -- newseq )
     error-continuation get call>> callstack>array
@@ -13,7 +13,7 @@ words splitting grouping sorting accessors ;
 [ baz ] [ 3 = ] must-fail-with
 [ t ] [
     symbolic-stack-trace
-    [ word? ] filter
+    2 head*
     { baz bar foo } tail?
 ] unit-test
 

basis/compiler/tests/tuples.factor

@@ -1,5 +1,5 @@
-IN: compiler.tests.tuples
 USING: kernel tools.test compiler.units compiler ;
+IN: compiler.tests.tuples
 
 TUPLE: color red green blue ;
 

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

@@ -1,6 +1,6 @@
-IN: compiler.tree.builder.tests
 USING: compiler.tree.builder tools.test sequences kernel
 compiler.tree stack-checker stack-checker.errors ;
+IN: compiler.tree.builder.tests
 
 : inline-recursive ( -- ) inline-recursive ; inline recursive
 

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

@@ -1,4 +0,0 @@
-IN: compiler.tree.checker.tests
-USING: compiler.tree.checker tools.test ;
-
-

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

@@ -1,4 +1,3 @@
-IN: compiler.tree.cleanup.tests
 USING: tools.test kernel.private kernel arrays sequences
 math.private math generic words quotations alien alien.c-types
 strings sbufs sequences.private slots.private combinators
@@ -17,6 +16,7 @@ compiler.tree.propagation
 compiler.tree.propagation.info
 compiler.tree.checker
 compiler.tree.debugger ;
+IN: compiler.tree.cleanup.tests
 
 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
 
@@ -41,13 +41,13 @@ compiler.tree.debugger ;
 
 GENERIC: mynot ( x -- y )
 
-M: f mynot drop t ;
+M: f mynot drop t ; inline
 
-M: object mynot drop f ;
+M: object mynot drop f ; inline
 
 GENERIC: detect-f ( x -- y )
 
-M: f detect-f ;
+M: f detect-f ; inline
 
 [ t ] [
     [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
@@ -55,9 +55,9 @@ M: f detect-f ;
 
 GENERIC: xyz ( n -- n )
 
-M: integer xyz ;
+M: integer xyz ; inline
 
-M: object xyz ;
+M: object xyz ; inline
 
 [ t ] [
     [ { integer } declare xyz ] \ xyz inlined?
@@ -115,10 +115,6 @@ M: object xyz ;
     [ { fixnum } declare [ ] times ] \ >= inlined?
 ] unit-test
 
-[ t ] [
-    [ { fixnum } declare [ ] times ] \ 1+ inlined?
-] unit-test
-
 [ t ] [
     [ { fixnum } declare [ ] times ] \ + inlined?
 ] unit-test
@@ -172,19 +168,6 @@ M: object xyz ;
     [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
 ] unit-test
 
-[ t ] [
-    [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
-] unit-test
-
-[ t ] [
-    [ 5000 [ [ ] times ] each ] \ 1+ inlined?
-] unit-test
-
-[ t ] [
-    [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
-    \ 1+ inlined?
-] unit-test
-
 GENERIC: annotate-entry-test-1 ( x -- )
 
 M: fixnum annotate-entry-test-1 drop ;
@@ -305,10 +288,6 @@ cell-bits 32 = [
     ] \ + inlined?
 ] unit-test
 
-[ t ] [
-    [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
-] unit-test
-
 : rec ( a -- b )
     dup 0 > [ 1 - rec ] when ; inline recursive
 

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

@@ -1,5 +1,5 @@
-IN: compiler.tree.combinators.tests
 USING: compiler.tree.combinators tools.test kernel ;
+IN: compiler.tree.combinators.tests
 
 { 1 0 } [ [ drop ] each-node ] must-infer-as
 { 1 1 } [ [ ] map-nodes ] must-infer-as

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

@@ -3,8 +3,7 @@
 USING: sequences namespaces kernel accessors assocs sets fry
 arrays combinators columns stack-checker.backend
 stack-checker.branches compiler.tree compiler.tree.combinators
-compiler.tree.dead-code.liveness compiler.tree.dead-code.simple
+compiler.tree.dead-code.liveness compiler.tree.dead-code.simple ;
-;
 IN: compiler.tree.dead-code.branches
 
 M: #if mark-live-values* look-at-inputs ;

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

@@ -1,5 +1,5 @@
-IN: compiler.tree.debugger.tests
 USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
+IN: compiler.tree.debugger.tests
 
 [ [ <=> ] sort ] optimized.
 [ <reversed> [ print ] each ] optimizer-report.

basis/compiler/tree/debugger/debugger.factor

@@ -11,6 +11,8 @@ compiler.tree.normalization
 compiler.tree.cleanup
 compiler.tree.propagation
 compiler.tree.propagation.info
+compiler.tree.escape-analysis
+compiler.tree.tuple-unboxing
 compiler.tree.def-use
 compiler.tree.builder
 compiler.tree.optimizer
@@ -209,6 +211,8 @@ SYMBOL: node-count
         normalize
         propagate
         cleanup
+        escape-analysis
+        unbox-tuples
         apply-identities
         compute-def-use
         remove-dead-code

basis/compiler/tree/def-use/def-use.factor

@@ -21,7 +21,7 @@ TUPLE: definition value node uses ;
 ERROR: no-def-error value ;
 
 : def-of ( value -- definition )
-    dup def-use get at* [ nip ] [ no-def-error ] if ;
+    def-use get ?at [ no-def-error ] unless ;
 
 ERROR: multiple-defs-error ;
 

basis/compiler/tree/def-use/simplified/simplified-tests.factor

@@ -1,6 +1,6 @@
 USING: kernel tools.test compiler.tree compiler.tree.builder
-compiler.tree.def-use compiler.tree.def-use.simplified accessors
+compiler.tree.recursive compiler.tree.def-use
-sequences sorting classes ;
+compiler.tree.def-use.simplified accessors sequences sorting classes ;
 IN: compiler.tree.def-use.simplified
 
 [ { #call #return } ] [
@@ -8,3 +8,17 @@ IN: compiler.tree.def-use.simplified
     first out-d>> first actually-used-by
     [ node>> class ] map natural-sort
 ] unit-test
+
+: word-1 ( a -- b ) dup [ word-1 ] when ; inline recursive
+
+[ { #introduce } ] [
+    [ word-1 ] build-tree analyze-recursive compute-def-use
+    last in-d>> first actually-defined-by
+    [ node>> class ] map natural-sort
+] unit-test
+
+[ { #if #return } ] [
+    [ word-1 ] build-tree analyze-recursive compute-def-use
+    first out-d>> first actually-used-by
+    [ node>> class ] map natural-sort
+] unit-test

basis/compiler/tree/def-use/simplified/simplified.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel fry vectors
+USING: sequences kernel fry vectors accessors namespaces assocs sets
-compiler.tree compiler.tree.def-use ;
+stack-checker.branches compiler.tree compiler.tree.def-use ;
 IN: compiler.tree.def-use.simplified
 
 ! Simplified def-use follows chains of copies.
@@ -9,32 +9,85 @@ IN: compiler.tree.def-use.simplified
 ! A 'real' usage is a usage of a value that is not a #renaming.
 TUPLE: real-usage value node ;
 
-! Def
+<PRIVATE
-GENERIC: actually-defined-by* ( value node -- real-usage )
 
-: actually-defined-by ( value -- real-usage )
+SYMBOLS: visited accum ;
-    dup defined-by actually-defined-by* ;
+
+: if-not-visited ( value quot -- )
+    over visited get key?
+    [ 2drop ] [ over visited get conjoin call ] if ; inline
+
+: with-simplified-def-use ( quot -- real-usages )
+    [
+        H{ } clone visited set
+        H{ } clone accum set
+        call
+        accum get keys
+    ] with-scope ; inline
+
+PRIVATE>
+
+! Def
+GENERIC: actually-defined-by* ( value node -- )
+
+: (actually-defined-by) ( value -- )
+    [ dup defined-by actually-defined-by* ] if-not-visited ;
 
 M: #renaming actually-defined-by*
-    inputs/outputs swap [ index ] dip nth actually-defined-by ;
+    inputs/outputs swap [ index ] dip nth (actually-defined-by) ;
 
-M: #return-recursive actually-defined-by* real-usage boa ;
+M: #call-recursive actually-defined-by*
+    [ out-d>> index ] [ label>> return>> in-d>> nth ] bi
+    (actually-defined-by) ;
 
-M: node actually-defined-by* real-usage boa ;
+M: #enter-recursive actually-defined-by*
+    [ out-d>> index ] keep
+    [ in-d>> nth (actually-defined-by) ]
+    [ label>> calls>> [ node>> in-d>> nth (actually-defined-by) ] with each ] 2bi ;
+
+M: #phi actually-defined-by*
+    [ out-d>> index ] [ phi-in-d>> ] bi
+    [
+        nth dup +bottom+ eq?
+        [ drop ] [ (actually-defined-by) ] if
+    ] with each ;
+
+M: node actually-defined-by*
+    real-usage boa accum get conjoin ;
+
+: actually-defined-by ( value -- real-usages )
+    [ (actually-defined-by) ] with-simplified-def-use ;
 
 ! Use
-GENERIC# actually-used-by* 1 ( value node accum -- )
+GENERIC: actually-used-by* ( value node -- )
 
-: (actually-used-by) ( value accum -- )
+: (actually-used-by) ( value -- )
-    [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
+    [ dup used-by [ actually-used-by* ] with each ] if-not-visited ;
 
 M: #renaming actually-used-by*
-    [ inputs/outputs [ indices ] dip nths ] dip
+    inputs/outputs [ indices ] dip nths
-    '[ _ (actually-used-by) ] each ;
+    [ (actually-used-by) ] each ;
 
-M: #return-recursive actually-used-by* [ real-usage boa ] dip push ;
+M: #return-recursive actually-used-by*
+    [ in-d>> index ] keep
+    [ out-d>> nth (actually-used-by) ]
+    [ label>> calls>> [ node>> out-d>> nth (actually-used-by) ] with each ] 2bi ;
 
-M: node actually-used-by* [ real-usage boa ] dip push ;
+M: #call-recursive actually-used-by*
+    [ in-d>> index ] [ label>> enter-out>> nth ] bi
+    (actually-used-by) ;
+
+M: #enter-recursive actually-used-by*
+    [ in-d>> index ] [ out-d>> nth ] bi (actually-used-by) ;
+
+M: #phi actually-used-by*
+    [ phi-in-d>> [ index ] with map-find drop ] [ out-d>> nth ] bi
+    (actually-used-by) ;
+
+M: #recursive actually-used-by* 2drop ;
+
+M: node actually-used-by*
+    real-usage boa accum get conjoin ;
 
 : actually-used-by ( value -- real-usages )
-    10 <vector> [ (actually-used-by) ] keep ;
+    [ (actually-used-by) ] with-simplified-def-use ;

basis/compiler/tree/escape-analysis/check/check-tests.factor

@@ -1,7 +1,7 @@
-IN: compiler.tree.escape-analysis.check.tests
 USING: compiler.tree.escape-analysis.check tools.test accessors kernel
 kernel.private math compiler.tree.builder compiler.tree.normalization
 compiler.tree.propagation compiler.tree.cleanup ;
+IN: compiler.tree.escape-analysis.check.tests
 
 : test-checker ( quot -- ? )
     build-tree normalize propagate cleanup run-escape-analysis? ;

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -1,4 +1,3 @@
-IN: compiler.tree.escape-analysis.tests
 USING: compiler.tree.escape-analysis
 compiler.tree.escape-analysis.allocations compiler.tree.builder
 compiler.tree.recursive compiler.tree.normalization
@@ -10,6 +9,7 @@ classes.tuple namespaces
 compiler.tree.propagation.info stack-checker.errors
 compiler.tree.checker
 kernel.private vectors ;
+IN: compiler.tree.escape-analysis.tests
 
 GENERIC: count-unboxed-allocations* ( m node -- n )
 

basis/compiler/tree/escape-analysis/recursive/recursive-tests.factor

@@ -1,7 +1,7 @@
-IN: compiler.tree.escape-analysis.recursive.tests
 USING: kernel tools.test namespaces sequences
 compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.allocations ;
+IN: compiler.tree.escape-analysis.recursive.tests
 
 H{ } clone allocations set
 <escaping-values> escaping-values set

basis/compiler/tree/finalization/finalization.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences words memoize combinators
-classes classes.builtin classes.tuple math.partial-dispatch
+classes classes.builtin classes.tuple classes.singleton
-fry assocs combinators.short-circuit
+math.partial-dispatch fry assocs combinators.short-circuit
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -45,6 +45,7 @@ M: predicate finalize-word
     "predicating" word-prop {
         { [ dup builtin-class? ] [ drop word>> cached-expansion ] }
         { [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
+        { [ dup singleton-class? ] [ drop word>> def>> splice-final ] }
         [ drop ]
     } cond ;
 

basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor

@@ -1,12 +1,11 @@
 ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.modular-arithmetic.tests
 USING: kernel kernel.private tools.test math math.partial-dispatch
-math.private accessors slots.private sequences sequences.private strings sbufs
+prettyprint math.private accessors slots.private sequences
-compiler.tree.builder
+sequences.private strings sbufs compiler.tree.builder
-compiler.tree.normalization
+compiler.tree.normalization compiler.tree.debugger alien.accessors
-compiler.tree.debugger
+layouts combinators byte-arrays arrays ;
-alien.accessors layouts combinators byte-arrays ;
+IN: compiler.tree.modular-arithmetic.tests
 
 : test-modular-arithmetic ( quot -- quot' )
     cleaned-up-tree nodes>quot ;
@@ -93,8 +92,6 @@ TUPLE: declared-fixnum { x fixnum } ;
     [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
 ] unit-test
 
-
-
 [ t ] [
     [
         { integer } declare [ 256 mod ] map
@@ -137,9 +134,14 @@ TUPLE: declared-fixnum { x fixnum } ;
     ] { mod fixnum-mod rem } inlined?
 ] unit-test
 
-[ [ >fixnum 255 fixnum-bitand ] ]
+[ [ >fixnum 255 >R R> fixnum-bitand ] ]
 [ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
 
+[ t ] [
+    [ { fixnum fixnum } declare + [ 1 + >fixnum ] [ 2 + >fixnum ] bi ]
+    { >fixnum } inlined?
+] unit-test
+
 [ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-1 ] ]
 [ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-1 ] test-modular-arithmetic ] unit-test
 
@@ -176,3 +178,115 @@ cell {
     [ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
     { >fixnum } inlined?
 ] unit-test
+
+[ f ] [ [ + >fixnum ] { >fixnum } inlined? ] unit-test
+
+[ t ] [
+    [ >integer [ >fixnum ] [ >fixnum ] bi ]
+    { >integer } inlined?
+] unit-test
+
+[ f ] [
+    [ >integer [ >fixnum ] [ >fixnum ] bi ]
+    { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ]
+    { >integer } inlined?
+] unit-test
+
+[ f ] [
+    [ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ]
+    { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ >integer [ >fixnum ] [ >fixnum ] bi ]
+    { >integer } inlined?
+] unit-test
+
+[ f ] [
+    [ >bignum [ >fixnum ] [ >fixnum ] bi ]
+    { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ >bignum [ >fixnum ] [ >fixnum ] bi ]
+    { >bignum } inlined?
+] unit-test
+
+[ f ] [
+    [ [ { fixnum } declare 2 fixnum+ ] dip [ >fixnum 2 - ] [ ] if ]
+    { fixnum+ } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum boolean } declare [ 1 + ] [ "HI" throw ] if >fixnum ]
+    { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum boolean } declare [ 1 + ] [ drop 5 ] if >fixnum ]
+    { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum boolean } declare [ 1 + ] [ 2 + ] if >fixnum ]
+    { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ [ [ 1 ] [ 4 ] if ] ] [
+    [ [ 1.5 ] [ 4 ] if >fixnum ] test-modular-arithmetic
+] unit-test
+
+[ [ [ 1 ] [ 2 ] if ] ] [
+    [ [ 1.5 ] [ 2.3 ] if >fixnum ] test-modular-arithmetic
+] unit-test
+
+[ f ] [
+    [ { fixnum fixnum boolean } declare [ [ 3 * ] [ 1 + ] dip ] [ [ 4 - ] [ 2 + ] dip ] if >fixnum ]
+    { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ 0 1000 [ 1 + dup >fixnum . ] times drop ]
+    { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare 3 + [ 1000 ] dip [ >fixnum . ] curry times ]
+    { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ 0 1000 [ 1 + ] times >fixnum ]
+    { fixnum+ >fixnum } inlined?
+] unit-test
+
+[ f ] [
+    [ f >fixnum ]
+    { >fixnum } inlined?
+] unit-test
+
+[ f ] [
+    [ [ >fixnum ] 2dip set-alien-unsigned-1 ]
+    { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare 123 >bignum bitand >fixnum ]
+    { >bignum fixnum>bignum bignum-bitand } inlined?
+] unit-test
+
+! Shifts
+[ t ] [
+    [
+        [ 0 ] 2dip { array } declare [
+            hashcode* >fixnum swap [
+                [ -2 shift ] [ 5 shift ] bi
+                + +
+            ] keep bitxor >fixnum
+        ] with each
+    ] { + bignum+ fixnum-shift bitxor bignum-bitxor } inlined?
+] unit-test

basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math math.partial-dispatch namespaces sequences sets
+USING: math math.intervals math.private math.partial-dispatch
-accessors assocs words kernel memoize fry combinators
+namespaces sequences sets accessors assocs words kernel memoize fry
-combinators.short-circuit layouts alien.accessors
+combinators combinators.short-circuit layouts alien.accessors
 compiler.tree
 compiler.tree.combinators
+compiler.tree.propagation.info
 compiler.tree.def-use
 compiler.tree.def-use.simplified
 compiler.tree.late-optimizations ;
@@ -19,17 +20,24 @@ IN: compiler.tree.modular-arithmetic
 !    ==>
 !        [ >fixnum ] bi@ fixnum+fast
 
+! Words where the low-order bits of the output only depends on the
+! low-order bits of the input. If the output is only used for its
+! low-order bits, then the word can be converted into a form that is
+! cheaper to compute.
 { + - * bitand bitor bitxor } [
     [
         t "modular-arithmetic" set-word-prop
     ] each-integer-derived-op
 ] each
 
-{ bitand bitor bitxor bitnot }
+{ bitand bitor bitxor bitnot >integer >bignum fixnum>bignum }
 [ t "modular-arithmetic" set-word-prop ] each
 
+! Words that only use the low-order bits of their input. If the input
+! is a modular arithmetic word, then the input can be converted into
+! a form that is cheaper to compute.
 {
-    >fixnum
+    >fixnum bignum>fixnum float>fixnum
     set-alien-unsigned-1 set-alien-signed-1
     set-alien-unsigned-2 set-alien-signed-2
 }
@@ -38,80 +46,156 @@ cell 8 = [
 ] when
 [ t "low-order" set-word-prop ] each
 
-SYMBOL: modularize-values
+! Values which only have their low-order bits used. This set starts out
+! big and is gradually refined.
+SYMBOL: modular-values
 
 : modular-value? ( value -- ? )
-    modularize-values get key? ;
+    modular-values get key? ;
 
-: modularize-value ( value -- ) modularize-values get conjoin ;
+: modular-value ( value -- )
+    modular-values get conjoin ;
 
-GENERIC: maybe-modularize* ( value node -- )
+! Values which are known to be fixnums.
+SYMBOL: fixnum-values
 
-: maybe-modularize ( value -- )
+: fixnum-value? ( value -- ? )
-    actually-defined-by [ value>> ] [ node>> ] bi
+    fixnum-values get key? ;
-    over actually-used-by length 1 = [
-        maybe-modularize*
-    ] [ 2drop ] if ;
 
-M: #call maybe-modularize*
+: fixnum-value ( value -- )
-    dup word>> "modular-arithmetic" word-prop [
+    fixnum-values get conjoin ;
-        [ modularize-value ]
-        [ in-d>> [ maybe-modularize ] each ] bi*
-    ] [ 2drop ] if ;
 
-M: node maybe-modularize* 2drop ;
+GENERIC: compute-modular-candidates* ( node -- )
 
-GENERIC: compute-modularized-values* ( node -- )
+M: #push compute-modular-candidates*
+    [ out-d>> first ] [ literal>> ] bi
+    real? [ [ modular-value ] [ fixnum-value ] bi ] [ drop ] if ;
 
-M: #call compute-modularized-values*
+: small-shift? ( interval -- ? )
-    dup word>> "low-order" word-prop
+    0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ;
-    [ in-d>> first maybe-modularize ] [ drop ] if ;
 
-M: node compute-modularized-values* drop ;
+: modular-word? ( #call -- ? )
+    dup word>> { shift fixnum-shift bignum-shift } memq?
+    [ node-input-infos second interval>> small-shift? ]
+    [ word>> "modular-arithmetic" word-prop ]
+    if ;
 
-: compute-modularized-values ( nodes -- )
+: output-candidate ( #call -- )
-    [ compute-modularized-values* ] each-node ;
+    out-d>> first [ modular-value ] [ fixnum-value ] bi ;
+
+: low-order-word? ( #call -- ? )
+    word>> "low-order" word-prop ;
+
+: input-candidiate ( #call -- )
+    in-d>> first modular-value ;
+
+M: #call compute-modular-candidates*
+    {
+        { [ dup modular-word? ] [ output-candidate ] }
+        { [ dup low-order-word? ] [ input-candidiate ] }
+        [ drop ]
+    } cond ;
+
+M: node compute-modular-candidates*
+    drop ;
+
+: compute-modular-candidates ( nodes -- )
+    H{ } clone modular-values set
+    H{ } clone fixnum-values set
+    [ compute-modular-candidates* ] each-node ;
+
+GENERIC: only-reads-low-order? ( node -- ? )
+
+: output-modular? ( #call -- ? )
+    out-d>> first modular-values get key? ;
+
+M: #call only-reads-low-order?
+    {
+        [ low-order-word? ]
+        [ { [ modular-word? ] [ output-modular? ] } 1&& ]
+    } 1|| ;
+
+M: node only-reads-low-order? drop f ;
+
+SYMBOL: changed?
+
+: only-used-as-low-order? ( value -- ? )
+    actually-used-by [ node>> only-reads-low-order? ] all? ;
+
+: (compute-modular-values) ( -- )
+    modular-values get keys [
+        dup only-used-as-low-order?
+        [ drop ] [ modular-values get delete-at changed? on ] if
+    ] each ;
+
+: compute-modular-values ( -- )
+    [ changed? off (compute-modular-values) changed? get ] loop ;
 
 GENERIC: optimize-modular-arithmetic* ( node -- nodes )
 
+M: #push optimize-modular-arithmetic*
+    dup [ out-d>> first modular-value? ] [ literal>> real? ] bi and
+    [ [ >fixnum ] change-literal ] when ;
+
 : redundant->fixnum? ( #call -- ? )
-    in-d>> first actually-defined-by value>> modular-value? ;
+    in-d>> first actually-defined-by
+    [ value>> { [ modular-value? ] [ fixnum-value? ] } 1&& ] all? ;
 
 : optimize->fixnum ( #call -- nodes )
     dup redundant->fixnum? [ drop f ] when ;
 
+: should-be->fixnum? ( #call -- ? )
+    out-d>> first modular-value? ;
+
 : optimize->integer ( #call -- nodes )
-    dup out-d>> first actually-used-by dup length 1 = [
+    dup should-be->fixnum? [ \ >fixnum >>word ] when ;
-        first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
-        [ drop { } ] when
-    ] [ drop ] if ;
 
 MEMO: fixnum-coercion ( flags -- nodes )
+    ! flags indicate which input parameters are already known to be fixnums,
+    ! and don't need a coercion as a result.
     [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
 
+: modular-value-info ( #call -- alist )
+    [ in-d>> ] [ out-d>> ] bi append
+    fixnum <class-info> '[ _ ] { } map>assoc ;
+
 : optimize-modular-op ( #call -- nodes )
     dup out-d>> first modular-value? [
         [ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri
         [
             [
-                [ actually-defined-by value>> modular-value? ]
+                [ actually-defined-by [ value>> modular-value? ] all? ]
                 [ fixnum eq? ]
                 bi* or
             ] 2map fixnum-coercion
         ] [ [ modular-variant ] change-word ] bi* suffix
     ] when ;
 
+: optimize-low-order-op ( #call -- nodes )
+    dup in-d>> first actually-defined-by [ value>> fixnum-value? ] all? [
+        [ ] [ in-d>> first ] [ info>> ] tri
+        [ drop fixnum <class-info> ] change-at
+    ] when ;
+
+: like->fixnum? ( #call -- ? )
+    word>> { >fixnum bignum>fixnum float>fixnum } memq? ;
+
+: like->integer? ( #call -- ? )
+    word>> { >integer >bignum fixnum>bignum } memq? ;
+
 M: #call optimize-modular-arithmetic*
-    dup word>> {
+    {
-        { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
+        { [ dup like->fixnum? ] [ optimize->fixnum ] }
-        { [ dup \ >integer eq? ] [ drop optimize->integer ] }
+        { [ dup like->integer? ] [ optimize->integer ] }
-        { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
+        { [ dup modular-word? ] [ optimize-modular-op ] }
-        [ drop ]
+        { [ dup low-order-word? ] [ optimize-low-order-op ] }
+        [ ]
     } cond ;
 
 M: node optimize-modular-arithmetic* ;
 
 : optimize-modular-arithmetic ( nodes -- nodes' )
-    H{ } clone modularize-values set
+    dup compute-modular-candidates compute-modular-values
-    dup compute-modularized-values
+    modular-values get assoc-empty? [
-    [ optimize-modular-arithmetic* ] map-nodes ;
+        [ optimize-modular-arithmetic* ] map-nodes
+    ] unless ;

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

@@ -1,10 +1,10 @@
-IN: compiler.tree.normalization.tests
 USING: compiler.tree.builder compiler.tree.recursive
 compiler.tree.normalization
 compiler.tree.normalization.introductions
 compiler.tree.normalization.renaming
 compiler.tree compiler.tree.checker
 sequences accessors tools.test kernel math ;
+IN: compiler.tree.normalization.tests
 
 [ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
 

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

@@ -1,4 +0,0 @@
-USING: compiler.tree.optimizer tools.test ;
-IN: compiler.tree.optimizer.tests
-
-

basis/compiler/tree/propagation/call-effect/call-effect.factor

@@ -153,7 +153,7 @@ ERROR: uninferable ;
 
 : (value>quot) ( value-info -- quot )
     dup class>> {
-        { \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] }
+        { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
         { \ curry [
             slots>> third (value>quot)
             '[ [ obj>> ] [ quot>> @ ] bi ]

basis/compiler/tree/propagation/copy/copy-tests.factor

@@ -1,6 +1,6 @@
-IN: compiler.tree.propagation.copy.tests
 USING: compiler.tree.propagation.copy tools.test namespaces kernel
 assocs ;
+IN: compiler.tree.propagation.copy.tests
 
 H{ } clone copies set
 

basis/compiler/tree/propagation/info/info.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs classes classes.algebra classes.tuple
 classes.tuple.private kernel accessors math math.intervals namespaces
-sequences sequences.private words combinators
+sequences sequences.private words combinators memoize
 combinators.short-circuit byte-arrays strings arrays layouts
 cpu.architecture compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.info
@@ -78,21 +78,37 @@ UNION: fixed-length array byte-array string ;
 : empty-set? ( info -- ? )
     {
         [ class>> null-class? ]
-        [ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ]
+        [ [ interval>> empty-interval eq? ] [ class>> real class<= ] bi and ]
     } 1|| ;
 
-: min-value ( class -- n ) fixnum eq? [ most-negative-fixnum ] [ -1/0. ] if ;
+: min-value ( class -- n )
+    {
+        { fixnum [ most-negative-fixnum ] }
+        { array-capacity [ 0 ] }
+        [ drop -1/0. ]
+    } case ;
 
-: max-value ( class -- n ) fixnum eq? [ most-positive-fixnum ] [ 1/0. ] if ;
+: max-value ( class -- n )
+    {
+        { fixnum [ most-positive-fixnum ] }
+        { array-capacity [ max-array-capacity ] }
+        [ drop 1/0. ]
+    } case ;
 
-: class-interval ( class -- i ) fixnum eq? [ fixnum-interval ] [ full-interval ] if ;
+: class-interval ( class -- i )
+    {
+        { fixnum [ fixnum-interval ] }
+        { array-capacity [ array-capacity-interval ] }
+        [ drop full-interval ]
+    } case ;
 
 : wrap-interval ( interval class -- interval' )
     {
-        { fixnum [ interval->fixnum ] }
+        { [ over empty-interval eq? ] [ drop ] }
-        { array-capacity [ max-array-capacity [a,a] interval-rem ] }
+        { [ over full-interval eq? ] [ nip class-interval ] }
+        { [ 2dup class-interval interval-subset? not ] [ nip class-interval ] }
         [ drop ]
-    } case ;
+    } cond ;
 
 : init-interval ( info -- info )
     dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -3,8 +3,8 @@
 USING: accessors kernel arrays sequences math math.order
 math.partial-dispatch generic generic.standard generic.single generic.math
 classes.algebra classes.union sets quotations assocs combinators
-words namespaces continuations classes fry combinators.smart hints
+combinators.short-circuit words namespaces continuations classes
-locals
+fry hints locals
 compiler.tree
 compiler.tree.builder
 compiler.tree.recursive
@@ -14,19 +14,6 @@ compiler.tree.propagation.info
 compiler.tree.propagation.nodes ;
 IN: compiler.tree.propagation.inlining
 
-! We count nodes up-front; if there are relatively few nodes,
-! we are more eager to inline
-SYMBOL: node-count
-
-: count-nodes ( nodes -- n )
-    0 swap [ drop 1+ ] each-node ;
-
-: compute-node-count ( nodes -- ) count-nodes node-count set ;
-
-! We try not to inline the same word too many times, to avoid
-! combinatorial explosion
-SYMBOL: inlining-count
-
 ! Splicing nodes
 : splicing-call ( #call word -- nodes )
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
@@ -101,99 +88,28 @@ M: callable splicing-nodes splicing-body ;
     dupd inlining-math-partial eliminate-dispatch ;
 
 ! Method body inlining
-SYMBOL: recursive-calls
-DEFER: (flat-length)
-
-: word-flat-length ( word -- n )
-    {
-        ! special-case
-        { [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
-        ! not inline
-        { [ dup inline? not ] [ drop 1 ] }
-        ! recursive and inline
-        { [ dup recursive-calls get key? ] [ drop 10 ] }
-        ! inline
-        [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
-    } cond ;
-
-: (flat-length) ( seq -- n )
-    [
-        {
-            { [ dup quotation? ] [ (flat-length) 2 + ] }
-            { [ dup array? ] [ (flat-length) ] }
-            { [ dup word? ] [ word-flat-length ] }
-            [ drop 0 ]
-        } cond
-    ] sigma ;
-
-: flat-length ( word -- n )
-    H{ } clone recursive-calls [
-        [ recursive-calls get conjoin ]
-        [ def>> (flat-length) 5 /i ]
-        bi
-    ] with-variable ;
-
-: classes-known? ( #call -- ? )
-    in-d>> [
-        value-info class>>
-        [ class-types length 1 = ]
-        [ union-class? not ]
-        bi and
-    ] any? ;
-
-: node-count-bias ( -- n )
-    45 node-count get [-] 8 /i ;
-
-: body-length-bias ( word -- n )
-    [ flat-length ] [ inlining-count get at 0 or ] bi
-    over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
-
-: inlining-rank ( #call word -- n )
-    [
-        [ classes-known? 2 0 ? ]
-        [
-            [ body-length-bias ]
-            [ "specializer" word-prop 1 0 ? ]
-            [ method-body? 1 0 ? ]
-            tri
-            node-count-bias
-            loop-nesting get 0 or 2 *
-        ] bi*
-    ] sum-outputs ;
-
-: should-inline? ( #call word -- ? )
-    dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
-
 SYMBOL: history
 
 : already-inlined? ( obj -- ? ) history get memq? ;
 
 : add-to-history ( obj -- ) history [ swap suffix ] change ;
 
-: remember-inlining ( word -- )
-    [ inlining-count get inc-at ]
-    [ add-to-history ]
-    bi ;
-
 :: inline-word ( #call word -- ? )
     word already-inlined? [ f ] [
         #call word splicing-body [
             [
-                word remember-inlining
+                word add-to-history
-                [ ] [ count-nodes ] [ (propagate) ] tri
+                dup (propagate)
             ] with-scope
-            [ #call (>>body) ] [ node-count +@ ] bi* t
+            #call (>>body) t
         ] [ f ] if*
     ] if ;
 
-: inline-method-body ( #call word -- ? )
-    2dup should-inline? [ inline-word ] [ 2drop f ] if ;
-
 : always-inline-word? ( word -- ? )
     { curry compose } memq? ;
 
 : never-inline-word? ( word -- ? )
-    [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
+    { [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ;
 
 : custom-inlining? ( word -- ? )
     "custom-inlining" word-prop ;
@@ -217,7 +133,7 @@ SYMBOL: history
         { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }
-        { [ dup method-body? ] [ inline-method-body ] }
+        { [ dup inline? ] [ inline-word ] }
         [ 2drop f ]
     } cond ;