Merge git://github.com/mncharity/factor into mncharity

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/modular-arithmetic/modular-arithmetic-tests.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 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 ;
-alien.accessors layouts combinators byte-arrays ;
 IN: compiler.tree.modular-arithmetic.tests
 
 : test-modular-arithmetic ( quot -- 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
@@ -140,6 +137,11 @@ TUPLE: declared-fixnum { x fixnum } ;
 [ [ >fixnum 255 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,83 @@ 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
+
+[ 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

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.private math.partial-dispatch namespaces sequences
-accessors assocs words kernel memoize fry combinators
+sets accessors assocs words kernel memoize fry 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 }
 [ 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,138 @@ 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*
+M: #call compute-modular-candidates*
-    dup word>> "low-order" word-prop
+    {
-    [ in-d>> first maybe-modularize ] [ drop ] if ;
+        {
+            [ dup word>> "modular-arithmetic" word-prop ]
+            [ out-d>> first [ modular-value ] [ fixnum-value ] bi ]
+        }
+        {
+            [ dup word>> "low-order" word-prop ]
+            [ in-d>> first modular-value ]
+        }
+        [ drop ]
+    } cond ;
 
-M: node compute-modularized-values* drop ;
+M: node compute-modular-candidates*
+    drop ;
 
-: compute-modularized-values ( nodes -- )
+: compute-modular-candidates ( nodes -- )
-    [ compute-modularized-values* ] each-node ;
+    H{ } clone modular-values set
+    H{ } clone fixnum-values set
+    [ compute-modular-candidates* ] each-node ;
+
+GENERIC: only-reads-low-order? ( node -- ? )
+
+M: #call only-reads-low-order?
+    {
+        [ word>> "low-order" word-prop ]
+        [
+            {
+                [ word>> "modular-arithmetic" word-prop ]
+                [ out-d>> first modular-values get key? ]
+            } 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 fixnum-value? [
+        [ ] [ in-d>> first ] [ info>> ] tri
+        [ drop fixnum <class-info> ] change-at
+    ] when ;
+
 M: #call optimize-modular-arithmetic*
     dup word>> {
-        { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
+        { [ dup { >fixnum bignum>fixnum float>fixnum } memq? ] [ drop optimize->fixnum ] }
         { [ dup \ >integer eq? ] [ drop optimize->integer ] }
         { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
+        { [ dup "low-order" word-prop ] [ drop optimize-low-order-op ] }
         [ drop ]
     } 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
     [ optimize-modular-arithmetic* ] map-nodes ;

basis/multiline/multiline-docs.factor

@@ -18,6 +18,16 @@ HELP: /*
            ""
 } ;
 
+HELP: HEREDOC:
+{ $syntax "HEREDOC: marker\n...text...marker" }
+{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "" "a string" } }
+{ $description "A multiline string syntax with a user-specified terminating delimiter.  HEREDOC: reads the next word, and uses it as the 'close quote'.  All input from the beginning of the HEREDOC:'s next line, until the first appearance of the word's name, becomes a string.  The terminating word does not need to be at the beginning of a line.\n\nThe HEREDOC: line should not have anything after the delimiting word.  The delimiting word should be an alphanumeric token.  It should not be, as in some other languages, a \"quoted string\"." }
+{ $examples
+    { $example "USING: heredoc ;" "HEREDOC: END\nx\nEND" "! \"x\\n\"" }
+    { $example "HEREDOC: END\nxEND" "! \"x\"" }
+    { $example "2 5 HEREDOC: zap\nfoo\nbarzap subseq" "! \"o\\nb\"" }
+} ;
+
 { POSTPONE: <" POSTPONE: STRING: } related-words
 
 HELP: parse-multiline-string
@@ -29,6 +39,7 @@ ARTICLE: "multiline" "Multiline"
 "Multiline strings:"
 { $subsection POSTPONE: STRING: }
 { $subsection POSTPONE: <" }
+{ $subsection POSTPONE: HEREDOC: }
 "Multiline comments:"
 { $subsection POSTPONE: /* }
 "Writing new multiline parsing words:"

basis/multiline/multiline-tests.factor

@@ -19,3 +19,43 @@ world"> ] unit-test
 
 [ "\nhi" ] [ <"
 hi"> ] unit-test
+
+
+! HEREDOC:
+
+[ "foo\nbar\n" ] [ HEREDOC: END
+foo
+bar
+END ] unit-test
+
+[ "foo\nbar" ] [ HEREDOC: END
+foo
+barEND ] unit-test
+
+[ "" ] [ HEREDOC: END
+END ] unit-test
+
+[ " " ] [ HEREDOC: END
+ END ] unit-test
+
+[ "\n" ] [ HEREDOC: END
+
+END ] unit-test
+
+[ "x" ] [ HEREDOC: END
+xEND ] unit-test
+
+[ "xyz " ] [ HEREDOC: END
+xyz END ] unit-test
+
+[ "} ! * # \" «\n" ] [ HEREDOC: END
+} ! * # " «
+END ] unit-test
+
+[ 21 "foo\nbar" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X
+foo
+barX HEREDOC: END ! mumble
+ HEREDOC: FOO
+ FOO
+END 22 ] unit-test
+

basis/multiline/multiline.factor

@@ -27,7 +27,7 @@ SYNTAX: STRING:
 
 <PRIVATE
 
-:: (parse-multiline-string) ( i end -- j )
+:: (scan-multiline-string) ( i end -- j )
     lexer get line-text>> :> text
     text [
         end text i start* [| j |
@@ -35,18 +35,21 @@ SYNTAX: STRING:
         ] [
             text i short tail % CHAR: \n ,
             lexer get next-line
-            0 end (parse-multiline-string)
+            0 end (scan-multiline-string)
         ] if*
     ] [ end unexpected-eof ] if ;
         
+:: (parse-multiline-string) ( end-text skip-n-chars -- str )
+    [
+        lexer get
+        [ skip-n-chars + end-text (scan-multiline-string) ]
+        change-column drop
+    ] "" make ;
+
 PRIVATE>
 
 : parse-multiline-string ( end-text -- str )
-    [
+    1 (parse-multiline-string) ;
-        lexer get
-        [ 1 + swap (parse-multiline-string) ]
-        change-column drop
-    ] "" make ;
 
 SYNTAX: <"
     "\">" parse-multiline-string parsed ;
@@ -61,3 +64,9 @@ SYNTAX: {"
     "\"}" parse-multiline-string parsed ;
 
 SYNTAX: /* "*/" parse-multiline-string drop ;
+
+SYNTAX: HEREDOC:
+    scan
+    lexer get next-line
+    0 (parse-multiline-string)
+    parsed ;

core/byte-arrays/byte-arrays-tests.factor

@@ -1,4 +1,4 @@
-USING: tools.test byte-arrays sequences kernel ;
+USING: tools.test byte-arrays sequences kernel math ;
 IN: byte-arrays.tests
 
 [ 6 B{ 1 2 3 } ] [
@@ -11,3 +11,7 @@ IN: byte-arrays.tests
 [ -10 B{ } resize-byte-array ] must-fail
 
 [ B{ 123 } ] [ 123 1byte-array ] unit-test
+
+[ B{ 123 } ] [ 123 0 B{ 0 } [ set-nth ] keep ] unit-test
+
+[ B{ 123 } ] [ 123 >bignum 0 B{ 0 } [ set-nth ] keep ] unit-test

core/io/streams/byte-array/byte-array-tests.factor

@@ -1,5 +1,5 @@
 USING: tools.test io.streams.byte-array io.encodings.binary
-io.encodings.utf8 io kernel arrays strings namespaces ;
+io.encodings.utf8 io kernel arrays strings namespaces math ;
 
 [ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test
 [ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
@@ -28,3 +28,8 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
         read1
     ] with-byte-reader
 ] unit-test
+
+! Overly aggressive compiler optimizations
+[ B{ 123 } ] [
+    binary [ 123 >bignum write1 ] with-byte-writer
+] unit-test

extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor

@@ -36,8 +36,7 @@ C-STRUCT: yuv_buffer
     255 min 0 max ; inline
 
 : stride ( line yuv  -- uvy yy )
-    [ yuv_buffer-uv_stride swap 2/ * >fixnum ]
+    [ yuv_buffer-uv_stride swap 2/ * ] [ yuv_buffer-y_stride * ] 2bi ; inline
-    [ yuv_buffer-y_stride * >fixnum ] 2bi ; inline
 
 : compute-y ( yuv uvy yy x -- y )
     + >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline
@@ -74,16 +73,16 @@ C-STRUCT: yuv_buffer
     drop ; inline
 
 : yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
-    compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
+    compute-yuv compute-rgb store-rgb 3 + ; inline
 
 : yuv>rgb-row ( index rgb yuv y -- index )
     over stride
-    pick yuv_buffer-y_width >fixnum
+    pick yuv_buffer-y_width
     [ yuv>rgb-pixel ] with with with with each ; inline
 
 : yuv>rgb ( rgb yuv -- )
     [ 0 ] 2dip
-    dup yuv_buffer-y_height >fixnum
+    dup yuv_buffer-y_height
     [ yuv>rgb-row ] with with each
     drop ;
 

extra/multi-methods/multi-methods.factor

@@ -21,7 +21,7 @@ SYMBOL: total
 : canonicalize-specializer-1 ( specializer -- specializer' )
     [
         [ class? ] filter
-        [ length <reversed> [ 1+ neg ] map ] keep zip
+        [ length <reversed> [ 1 + neg ] map ] keep zip
         [ length args [ max ] change ] keep
     ]
     [
@@ -104,7 +104,7 @@ SYMBOL: total
         { 0 [ [ dup ] ] }
         { 1 [ [ over ] ] }
         { 2 [ [ pick ] ] }
-        [ 1- picker [ dip swap ] curry ]
+        [ 1 - picker [ dip swap ] curry ]
     } case ;
 
 : (multi-predicate) ( class picker -- quot )

extra/multi-methods/tests/syntax.factor

@@ -2,8 +2,9 @@ IN: multi-methods.tests
 USING: multi-methods tools.test math sequences namespaces system
 kernel strings definitions prettyprint debugger arrays
 hashtables continuations classes assocs accessors see ;
+RENAME: GENERIC: multi-methods => multi-methods:GENERIC:
 
-GENERIC: first-test ( -- )
+multi-methods:GENERIC: first-test ( -- )
 
 [ t ] [ \ first-test generic? ] unit-test
 
@@ -13,14 +14,14 @@ SINGLETON: paper    INSTANCE: paper thing
 SINGLETON: scissors INSTANCE: scissors thing
 SINGLETON: rock     INSTANCE: rock thing
 
-GENERIC: beats? ( obj1 obj2 -- ? )
+multi-methods:GENERIC: beats? ( obj1 obj2 -- ? )
 
-METHOD: beats? { paper scissors } t ;
+METHOD: beats? { paper scissors } 2drop t ;
-METHOD: beats? { scissors rock } t ;
+METHOD: beats? { scissors rock } 2drop t ;
-METHOD: beats? { rock paper } t ;
+METHOD: beats? { rock paper } 2drop t ;
-METHOD: beats? { thing thing } f ;
+METHOD: beats? { thing thing } 2drop f ;
 
-: play ( obj1 obj2 -- ? ) beats? 2nip ;
+: play ( obj1 obj2 -- ? ) beats? ;
 
 [ { } 3 play ] must-fail
 [ t ] [ error get no-method? ] unit-test
@@ -34,7 +35,7 @@ METHOD: beats? { thing thing } f ;
 
 SYMBOL: some-var
 
-GENERIC: hook-test ( -- obj )
+multi-methods:GENERIC: hook-test ( obj -- obj )
 
 METHOD: hook-test { array { some-var array } } reverse ;
 METHOD: hook-test { { some-var array } } class ;
@@ -57,7 +58,7 @@ TUPLE: busted-1 ;
 TUPLE: busted-2 ; INSTANCE: busted-2 busted
 TUPLE: busted-3 ;
 
-GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
+multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
 
 METHOD: busted-sort { busted-1 busted-2 } ;
 METHOD: busted-sort { busted-2 busted-3 } ;