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

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/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/tree/cleanup/cleanup-tests.factor

@@ -41,13 +41,13 @@ IN: compiler.tree.cleanup.tests
 
 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?

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
-sequences sorting classes ;
+compiler.tree.recursive compiler.tree.def-use
+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
-compiler.tree compiler.tree.def-use ;
+USING: sequences kernel fry vectors accessors namespaces assocs sets
+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
-GENERIC: actually-defined-by* ( value node -- real-usage )
+<PRIVATE
 
-: actually-defined-by ( value -- real-usage )
-    dup defined-by actually-defined-by* ;
+SYMBOLS: visited accum ;
+
+: 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 -- )
-    [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
+: (actually-used-by) ( value -- )
+    [ dup used-by [ actually-used-by* ] with each ] if-not-visited ;
 
 M: #renaming actually-used-by*
-    [ inputs/outputs [ indices ] dip nths ] dip
-    '[ _ (actually-used-by) ] each ;
+    inputs/outputs [ indices ] dip nths
+    [ (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/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
-fry assocs combinators.short-circuit
+classes classes.builtin classes.tuple classes.singleton
+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,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
-compiler.tree.builder
-compiler.tree.normalization
-compiler.tree.debugger
-alien.accessors layouts combinators byte-arrays ;
+prettyprint math.private accessors slots.private sequences
+sequences.private strings sbufs compiler.tree.builder
+compiler.tree.normalization compiler.tree.debugger 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
-accessors assocs words kernel memoize fry combinators
+USING: math math.private math.partial-dispatch namespaces sequences
+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 -- )
-    actually-defined-by [ value>> ] [ node>> ] bi
-    over actually-used-by length 1 = [
-        maybe-modularize*
-    ] [ 2drop ] if ;
+: fixnum-value? ( value -- ? )
+    fixnum-values get key? ;
 
-M: #call maybe-modularize*
-    dup word>> "modular-arithmetic" word-prop [
-        [ modularize-value ]
-        [ in-d>> [ maybe-modularize ] each ] bi*
-    ] [ 2drop ] if ;
+: fixnum-value ( value -- )
+    fixnum-values get conjoin ;
 
-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*
-    dup word>> "low-order" word-prop
-    [ in-d>> first maybe-modularize ] [ drop ] if ;
+M: #call compute-modular-candidates*
+    {
+        {
+            [ 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-modularized-values* ] each-node ;
+: 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 -- ? )
+
+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 = [
-        first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
-        [ drop { } ] when
-    ] [ drop ] if ;
+    dup should-be->fixnum? [ \ >fixnum >>word ] when ;
 
 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-modularized-values
+    dup compute-modular-candidates compute-modular-values
     [ optimize-modular-arithmetic* ] map-nodes ;

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/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
-locals
+combinators.short-circuit words namespaces continuations classes
+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
-                [ ] [ count-nodes ] [ (propagate) ] tri
+                word add-to-history
+                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 ;
 

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

@@ -56,9 +56,9 @@ IN: compiler.tree.propagation.tests
 
 [ float ] [ [ { float real } declare + ] final-math-class ] unit-test
 
-[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test
+! [ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test
 
-[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test
+! [ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test
 
 [ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test
 
@@ -444,6 +444,13 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
     ] final-classes
 ] unit-test
 
+[ V{ f { } } ] [
+    [
+        T{ mixed-mutable-immutable f 3 { } }
+        [ x>> ] [ y>> ] bi
+    ] final-literals
+] unit-test
+
 ! Recursive propagation
 : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
 
@@ -502,8 +509,8 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 ] unit-test
 
 GENERIC: iterate ( obj -- next-obj ? )
-M: fixnum iterate f ;
-M: array iterate first t ;
+M: fixnum iterate f ; inline
+M: array iterate first t ; inline
 
 : dead-loop ( obj -- final-obj )
     iterate [ dead-loop ] when ; inline recursive
@@ -567,7 +574,7 @@ M: array iterate first t ;
 ] unit-test
 
 GENERIC: bad-generic ( a -- b )
-M: fixnum bad-generic 1 fixnum+fast ;
+M: fixnum bad-generic 1 fixnum+fast ; inline
 : bad-behavior ( -- b ) 4 bad-generic ; inline recursive
 
 [ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test
@@ -740,7 +747,7 @@ TUPLE: foo bar ;
 [ t ] [ [ foo new ] { new } inlined? ] unit-test
 
 GENERIC: whatever ( x -- y )
-M: number whatever drop foo ;
+M: number whatever drop foo ; inline
 
 [ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test
 
@@ -749,8 +756,8 @@ M: number whatever drop foo ;
 [ f ] [ [ that-thing new ] { new } inlined? ] unit-test
 
 GENERIC: whatever2 ( x -- y )
-M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ;
-M: f whatever2 ;
+M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline
+M: f whatever2 ; inline
 
 [ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
 [ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test

basis/compiler/tree/propagation/propagation.factor

@@ -19,6 +19,4 @@ IN: compiler.tree.propagation
     H{ } clone copies set
     H{ } clone 1array value-infos set
     H{ } clone 1array constraints set
-    H{ } clone inlining-count set
-    dup compute-node-count
     dup (propagate) ;

basis/grouping/grouping.factor

@@ -18,41 +18,41 @@ GENERIC: group@ ( n groups -- from to seq )
 
 M: chunking-seq set-nth group@ <slice> 0 swap copy ;
 
-M: chunking-seq like drop { } like ;
+M: chunking-seq like drop { } like ; inline
 
 INSTANCE: chunking-seq sequence
 
 MIXIN: subseq-chunking
 
-M: subseq-chunking nth group@ subseq ;
+M: subseq-chunking nth group@ subseq ; inline
 
 MIXIN: slice-chunking
 
-M: slice-chunking nth group@ <slice> ;
+M: slice-chunking nth group@ <slice> ; inline
 
-M: slice-chunking nth-unsafe group@ slice boa ;
+M: slice-chunking nth-unsafe group@ slice boa ; inline
 
 TUPLE: abstract-groups < chunking-seq ;
 
 M: abstract-groups length
-    [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ;
+    [ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline
 
 M: abstract-groups set-length
-    [ n>> * ] [ seq>> ] bi set-length ;
+    [ n>> * ] [ seq>> ] bi set-length ; inline
 
 M: abstract-groups group@
-    [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
+    [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline
 
 TUPLE: abstract-clumps < chunking-seq ;
 
 M: abstract-clumps length
-    [ seq>> length ] [ n>> ] bi - 1 + ;
+    [ seq>> length ] [ n>> ] bi - 1 + ; inline
 
 M: abstract-clumps set-length
-    [ n>> + 1 - ] [ seq>> ] bi set-length ;
+    [ n>> + 1 - ] [ seq>> ] bi set-length ; inline
 
 M: abstract-clumps group@
-    [ n>> over + ] [ seq>> ] bi ;
+    [ n>> over + ] [ seq>> ] bi ; inline
 
 PRIVATE>
 

basis/io/encodings/ascii/ascii.factor

@@ -16,7 +16,7 @@ PRIVATE>
 SINGLETON: ascii
 
 M: ascii encode-char
-    128 encode-if< ;
+    128 encode-if< ; inline
 
 M: ascii decode-char
-    128 decode-if< ;
+    128 decode-if< ; inline

basis/math/bits/bits.factor

@@ -9,9 +9,9 @@ C: <bits> bits
 : make-bits ( number -- bits )
     [ T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if-zero ; inline
 
-M: bits length length>> ;
+M: bits length length>> ; inline
 
-M: bits nth-unsafe number>> swap bit? ;
+M: bits nth-unsafe number>> swap bit? ; inline
 
 INSTANCE: bits immutable-sequence
 

basis/math/complex/complex.factor

@@ -5,29 +5,29 @@ math.libm math.functions arrays math.functions.private sequences
 parser ;
 IN: math.complex.private
 
-M: real real-part ;
-M: real imaginary-part drop 0 ;
-M: complex real-part real>> ;
-M: complex imaginary-part imaginary>> ;
-M: complex absq >rect [ sq ] bi@ + ;
-M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ;
+M: real real-part ; inline
+M: real imaginary-part drop 0 ; inline
+M: complex real-part real>> ; inline
+M: complex imaginary-part imaginary>> ; inline
+M: complex absq >rect [ sq ] bi@ + ; inline
+M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; inline
 : componentwise ( x y quot -- a b ) [ [ >rect ] bi@ ] dip bi-curry@ bi* ; inline
 : complex= ( x y quot -- ? ) componentwise and ; inline
-M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ;
-M: complex number= [ number= ] complex= ;
+M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; inline
+M: complex number= [ number= ] complex= ; inline
 : complex-op ( x y quot -- z ) componentwise rect> ; inline
-M: complex + [ + ] complex-op ;
-M: complex - [ - ] complex-op ;
+M: complex + [ + ] complex-op ; inline
+M: complex - [ - ] complex-op ; inline
 : *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline
 : *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline
-M: complex * [ *re - ] [ *im + ] 2bi rect> ;
+M: complex * [ *re - ] [ *im + ] 2bi rect> ; inline
 : (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
 : complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline
-M: complex / [ / ] complex/ ;
-M: complex /f [ /f ] complex/ ;
-M: complex /i [ /i ] complex/ ;
-M: complex abs absq >float fsqrt ;
-M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ;
+M: complex / [ / ] complex/ ; inline
+M: complex /f [ /f ] complex/ ; inline
+M: complex /i [ /i ] complex/ ; inline
+M: complex abs absq >float fsqrt ; inline
+M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline
 
 IN: syntax
 

basis/math/functions/functions.factor

@@ -13,7 +13,7 @@ IN: math.functions
 GENERIC: sqrt ( x -- y ) foldable
 
 M: real sqrt
-    >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
+    >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; inline
 
 : factor-2s ( n -- r s )
     #! factor an integer into 2^r * s
@@ -120,7 +120,7 @@ ERROR: non-trivial-divisor n ;
 
 GENERIC: absq ( x -- y ) foldable
 
-M: real absq sq ;
+M: real absq sq ; inline
 
 : ~abs ( x y epsilon -- ? )
     [ - abs ] dip < ;
@@ -148,13 +148,13 @@ M: real absq sq ;
 
 GENERIC: exp ( x -- y )
 
-M: real exp fexp ;
+M: real exp fexp ; inline
 
 M: complex exp >rect swap fexp swap polar> ;
 
 GENERIC: log ( x -- y )
 
-M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ;
+M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
 
 M: complex log >polar swap flog swap rect> ;
 
@@ -169,7 +169,7 @@ M: complex cos
     [ [ fcos ] [ fcosh ] bi* * ]
     [ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
 
-M: real cos fcos ;
+M: real cos fcos ; inline
 
 : sec ( x -- y ) cos recip ; inline
 
@@ -180,7 +180,7 @@ M: complex cosh
     [ [ fcosh ] [ fcos ] bi* * ]
     [ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
 
-M: real cosh fcosh ;
+M: real cosh fcosh ; inline
 
 : sech ( x -- y ) cosh recip ; inline
 
@@ -191,7 +191,7 @@ M: complex sin
     [ [ fsin ] [ fcosh ] bi* * ]
     [ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
 
-M: real sin fsin ;
+M: real sin fsin ; inline
 
 : cosec ( x -- y ) sin recip ; inline
 
@@ -202,7 +202,7 @@ M: complex sinh
     [ [ fsinh ] [ fcos ] bi* * ]
     [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
 
-M: real sinh fsinh ;
+M: real sinh fsinh ; inline
 
 : cosech ( x -- y ) sinh recip ; inline
 
@@ -210,13 +210,13 @@ GENERIC: tan ( x -- y ) foldable
 
 M: complex tan [ sin ] [ cos ] bi / ;
 
-M: real tan ftan ;
+M: real tan ftan ; inline
 
 GENERIC: tanh ( x -- y ) foldable
 
 M: complex tanh [ sinh ] [ cosh ] bi / ;
 
-M: real tanh ftanh ;
+M: real tanh ftanh ; inline
 
 : cot ( x -- y ) tan recip ; inline
 
@@ -252,7 +252,7 @@ GENERIC: atan ( x -- y ) foldable
 
 M: complex atan i* atanh i* ;
 
-M: real atan fatan ;
+M: real atan fatan ; inline
 
 : asec ( x -- y ) recip acos ; inline
 

basis/math/ranges/ranges.factor

@@ -12,11 +12,9 @@ TUPLE: range
 : <range> ( a b step -- range )
     [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline
 
-M: range length ( seq -- n )
-    length>> ;
+M: range length ( seq -- n ) length>> ; inline
 
-M: range nth-unsafe ( n range -- obj )
-    [ step>> * ] keep from>> + ;
+M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline
 
 ! For ranges with many elements, the default element-wise methods
 ! sequences define are unsuitable because they're O(n)

basis/math/ratios/ratios.factor

@@ -48,8 +48,8 @@ M: ratio >fixnum >fraction /i >fixnum ;
 M: ratio >bignum >fraction /i >bignum ;
 M: ratio >float >fraction /f ;
 
-M: ratio numerator numerator>> ;
-M: ratio denominator denominator>> ;
+M: ratio numerator numerator>> ; inline
+M: ratio denominator denominator>> ; inline
 
 M: ratio < scale < ;
 M: ratio <= scale <= ;

basis/multiline/multiline-docs.factor

@@ -18,6 +18,25 @@ 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: multiline prettyprint ;"
+               "HEREDOC: END\nx\nEND ."
+               "\"x\\n\""
+    }
+    { $example "USING: multiline prettyprint ;"
+               "HEREDOC: END\nxEND ."
+               "\"x\""
+    }
+    { $example "USING: multiline prettyprint sequences ;"
+               "2 5 HEREDOC: zap\nfoo\nbarzap subseq ."
+               "\"o\\nb\""
+    }
+} ;
+
 { POSTPONE: <" POSTPONE: STRING: } related-words
 
 HELP: parse-multiline-string
@@ -29,6 +48,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 )
-    [
-        lexer get
-        [ 1 + swap (parse-multiline-string) ]
-        change-column drop
-    ] "" make ;
+    1 (parse-multiline-string) ;
 
 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 ;

basis/sorting/functor/functor.factor

@@ -10,7 +10,7 @@ NAME>=< DEFINES ${NAME}>=<
 
 WHERE
 
-: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
+: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ;
 : NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
 
 ;FUNCTOR

basis/specialized-arrays/functor/functor.factor

@@ -39,19 +39,19 @@ TUPLE: A
     dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
     swap A boa ; inline
 
-M: A clone [ length>> ] [ underlying>> clone ] bi A boa ;
+M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; inline
 
-M: A length length>> ;
+M: A length length>> ; inline
 
-M: A nth-unsafe underlying>> NTH call ;
+M: A nth-unsafe underlying>> NTH call ; inline
 
-M: A set-nth-unsafe underlying>> SET-NTH call ;
+M: A set-nth-unsafe underlying>> SET-NTH call ; inline
 
-: >A ( seq -- specialized-array ) A new clone-like ; inline
+: >A ( seq -- specialized-array ) A new clone-like ;
 
-M: A like drop dup A instance? [ >A ] unless ;
+M: A like drop dup A instance? [ >A ] unless ; inline
 
-M: A new-sequence drop (A) ;
+M: A new-sequence drop (A) ; inline
 
 M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
 
@@ -60,9 +60,9 @@ M: A resize
         [ T heap-size * ] [ underlying>> ] bi*
         resize-byte-array
     ] 2bi
-    A boa ;
+    A boa ; inline
 
-M: A byte-length underlying>> length ;
+M: A byte-length underlying>> length ; inline
 
 M: A pprint-delims drop \ A{ \ } ;
 

basis/stack-checker/known-words/known-words.factor

@@ -158,6 +158,8 @@ M: bad-executable summary
 
 \ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
 
+\ <tuple-boa> t "flushable" set-word-prop
+
 : infer-effect-unsafe ( word -- )
     pop-literal nip
     add-effect-input

basis/tuple-arrays/tuple-arrays.factor

@@ -54,17 +54,17 @@ TUPLE: CLASS-array
     [ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
     \ CLASS-array boa ; inline
 
-M: CLASS-array length length>> ;
+M: CLASS-array length length>> ; inline
 
-M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ;
+M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; inline
 
-M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ;
+M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; inline
 
-M: CLASS-array new-sequence drop <CLASS-array> ;
+M: CLASS-array new-sequence drop <CLASS-array> ; inline
 
 : >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
 
-M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ;
+M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; inline
 
 INSTANCE: CLASS-array sequence
 

basis/vectors/functor/functor.factor

@@ -18,11 +18,11 @@ TUPLE: V { underlying A } { length array-capacity } ;
 M: V like
     drop dup V instance? [
         dup A instance? [ dup length V boa ] [ >V ] if
-    ] unless ;
+    ] unless ; inline
 
-M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
+M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ; inline
 
-M: A new-resizable drop <V> ;
+M: A new-resizable drop <V> ; inline
 
 M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
 

basis/windows/ole32/ole32.factor

@@ -1,5 +1,5 @@
 USING: alien alien.syntax alien.c-types alien.strings math
-kernel sequences windows.errors windows.types debugger io
+kernel sequences windows.errors windows.types io
 accessors math.order namespaces make math.parser windows.kernel32
 combinators locals specialized-arrays.direct.uchar ;
 IN: windows.ole32
@@ -116,11 +116,10 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
 : succeeded? ( hresult -- ? )
     0 HEX: 7FFFFFFF between? ;
 
-TUPLE: ole32-error error-code ;
-C: <ole32-error> ole32-error
+TUPLE: ole32-error code message ;
 
-M: ole32-error error.
-    "COM method failed: " print error-code>> n>win32-error-string print ;
+: <ole32-error> ( code -- error )
+    dup n>win32-error-string \ ole32-error boa ;
 
 : ole32-error ( hresult -- )
     dup succeeded? [ drop ] [ <ole32-error> throw ] if ;

build-support/factor.sh

@@ -487,12 +487,12 @@ update_bootstrap() {
 }
 
 refresh_image() {
-    ./$FACTOR_BINARY -script -e="USE: vocabs.loader USE: system refresh-all USE: memory save 0 exit"
+    ./$FACTOR_BINARY -script -e="USING: vocabs.loader system memory ; refresh-all USE: memory save 0 exit"
     check_ret factor
 }
 
 make_boot_image() {
-    ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: system USE: bootstrap.image make-image save 0 exit"
+    ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USING: system bootstrap.image memory ; make-image save 0 exit"
     check_ret factor
 
 }

core/alien/alien.factor

@@ -20,11 +20,11 @@ UNION: pinned-c-ptr
 
 GENERIC: >c-ptr ( obj -- c-ptr )
 
-M: c-ptr >c-ptr ;
+M: c-ptr >c-ptr ; inline
 
 SLOT: underlying
 
-M: object >c-ptr underlying>> ;
+M: object >c-ptr underlying>> ; inline
 
 GENERIC: expired? ( c-ptr -- ? ) flushable
 

core/arrays/arrays.factor

@@ -4,17 +4,17 @@ USING: accessors kernel kernel.private math math.private
 sequences sequences.private ;
 IN: arrays
 
-M: array clone (clone) ;
-M: array length length>> ;
-M: array nth-unsafe [ >fixnum ] dip array-nth ;
-M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ;
-M: array resize resize-array ;
+M: array clone (clone) ; inline
+M: array length length>> ; inline
+M: array nth-unsafe [ >fixnum ] dip array-nth ; inline
+M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline
+M: array resize resize-array ; inline
 
 : >array ( seq -- array ) { } clone-like ;
 
-M: object new-sequence drop 0 <array> ;
+M: object new-sequence drop 0 <array> ; inline
 
-M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ;
+M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ; inline
 
 M: array equal?
     over array? [ sequence= ] [ 2drop f ] if ;

core/assocs/assocs.factor

@@ -17,7 +17,7 @@ GENERIC: assoc-like ( assoc exemplar -- newassoc )
 GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
 GENERIC: >alist ( assoc -- newassoc )
 
-M: assoc assoc-like drop ;
+M: assoc assoc-like drop ; inline
 
 : ?at ( key assoc -- value/key ? )
     2dup at* [ 2nip t ] [ 2drop f ] if ; inline
@@ -87,7 +87,7 @@ PRIVATE>
 
 M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     [ dup assoc-size ] dip new-assoc
-    [ [ set-at ] with-assoc assoc-each ] keep ;
+    [ [ set-at ] with-assoc assoc-each ] keep ; inline
 
 : keys ( assoc -- keys )
     [ drop ] { } assoc>map ;
@@ -189,48 +189,48 @@ M: sequence set-at
     [ 2nip set-second ]
     [ drop [ swap 2array ] dip push ] if ;
 
-M: sequence new-assoc drop <vector> ;
+M: sequence new-assoc drop <vector> ; inline
 
-M: sequence clear-assoc delete-all ;
+M: sequence clear-assoc delete-all ; inline
 
 M: sequence delete-at
     [ nip ] [ search-alist nip ] 2bi
     [ swap delete-nth ] [ drop ] if* ;
 
-M: sequence assoc-size length ;
+M: sequence assoc-size length ; inline
 
 M: sequence assoc-clone-like
-    [ >alist ] dip clone-like ;
+    [ >alist ] dip clone-like ; inline
 
 M: sequence assoc-like
-    [ >alist ] dip like ;
+    [ >alist ] dip like ; inline
 
-M: sequence >alist ;
+M: sequence >alist ; inline
 
 ! Override sequence => assoc instance for f
-M: f clear-assoc drop ;
+M: f clear-assoc drop ; inline
 
-M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
+M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline
 
 INSTANCE: sequence assoc
 
-TUPLE: enum seq ;
+TUPLE: enum { seq read-only } ;
 
 C: <enum> enum
 
 M: enum at*
     seq>> 2dup bounds-check?
-    [ nth t ] [ 2drop f f ] if ;
+    [ nth t ] [ 2drop f f ] if ; inline
 
-M: enum set-at seq>> set-nth ;
+M: enum set-at seq>> set-nth ; inline
 
-M: enum delete-at seq>> delete-nth ;
+M: enum delete-at seq>> delete-nth ; inline
 
 M: enum >alist ( enum -- alist )
-    seq>> [ length ] keep zip ;
+    seq>> [ length ] keep zip ; inline
 
-M: enum assoc-size seq>> length ;
+M: enum assoc-size seq>> length ; inline
 
-M: enum clear-assoc seq>> delete-all ;
+M: enum clear-assoc seq>> delete-all ; inline
 
 INSTANCE: enum assoc

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/byte-arrays/byte-arrays.factor

@@ -4,18 +4,18 @@ USING: accessors kernel kernel.private alien.accessors sequences
 sequences.private math ;
 IN: byte-arrays
 
-M: byte-array clone (clone) ;
-M: byte-array length length>> ;
-M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
-M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
+M: byte-array clone (clone) ; inline
+M: byte-array length length>> ; inline
+M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; inline
+M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; inline
 : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
-M: byte-array new-sequence drop (byte-array) ;
+M: byte-array new-sequence drop (byte-array) ; inline
 
 M: byte-array equal?
     over byte-array? [ sequence= ] [ 2drop f ] if ;
 
 M: byte-array resize
-    resize-byte-array ;
+    resize-byte-array ; inline
 
 INSTANCE: byte-array sequence
 

core/byte-vectors/byte-vectors.factor

@@ -18,15 +18,15 @@ M: byte-vector like
     drop dup byte-vector? [
         dup byte-array?
         [ dup length byte-vector boa ] [ >byte-vector ] if
-    ] unless ;
+    ] unless ; inline
 
 M: byte-vector new-sequence
-    drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;
+    drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; inline
 
 M: byte-vector equal?
     over byte-vector? [ sequence= ] [ 2drop f ] if ;
 
-M: byte-vector contract 2drop ;
+M: byte-vector contract 2drop ; inline
 
 M: byte-array like
     #! If we have an byte-array, we're done.
@@ -39,8 +39,8 @@ M: byte-array like
             2dup length eq?
             [ nip ] [ resize-byte-array ] if
         ] [ >byte-array ] if
-    ] unless ;
+    ] unless ; inline
 
-M: byte-array new-resizable drop <byte-vector> ;
+M: byte-array new-resizable drop <byte-vector> ; inline
 
 INSTANCE: byte-vector growable

core/classes/builtin/builtin.factor

@@ -20,9 +20,9 @@ PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
 
 : bootstrap-type>class ( n -- class ) builtins get nth ;
 
-M: hi-tag class hi-tag type>class ;
+M: hi-tag class hi-tag type>class ; inline
 
-M: object class tag type>class ;
+M: object class tag type>class ; inline
 
 M: builtin-class rank-class drop 0 ;
 

core/classes/tuple/tuple.factor

@@ -29,7 +29,7 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
 : layout-of ( tuple -- layout )
     1 slot { array } declare ; inline
 
-M: tuple class layout-of 2 slot { word } declare ;
+M: tuple class layout-of 2 slot { word } declare ; inline
 
 : tuple-size ( tuple -- size )
     layout-of 3 slot { fixnum } declare ; inline
@@ -323,7 +323,7 @@ M: tuple-class (classes-intersect?)
         [ swap classes-intersect? ]
     } cond ;
 
-M: tuple clone (clone) ;
+M: tuple clone (clone) ; inline
 
 M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
 

core/growable/growable.factor

@@ -9,9 +9,9 @@ MIXIN: growable
 SLOT: length
 SLOT: underlying
 
-M: growable length length>> ;
-M: growable nth-unsafe underlying>> nth-unsafe ;
-M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
+M: growable length length>> ; inline
+M: growable nth-unsafe underlying>> nth-unsafe ; inline
+M: growable set-nth-unsafe underlying>> set-nth-unsafe ; inline
 
 : capacity ( seq -- n ) underlying>> length ; inline
 
@@ -49,21 +49,21 @@ M: growable set-length ( n seq -- )
         [ >fixnum ] dip
     ] if ; inline
 
-M: growable set-nth ensure set-nth-unsafe ;
+M: growable set-nth ensure set-nth-unsafe ; inline
 
-M: growable clone (clone) [ clone ] change-underlying ;
+M: growable clone (clone) [ clone ] change-underlying ; inline
 
 M: growable lengthen ( n seq -- )
     2dup length > [
         2dup capacity > [ over new-size over expand ] when
         2dup (>>length)
-    ] when 2drop ;
+    ] when 2drop ; inline
 
 M: growable shorten ( n seq -- )
     growable-check
     2dup length < [
         2dup contract
         2dup (>>length)
-    ] when 2drop ;
+    ] when 2drop ; inline
 
 INSTANCE: growable sequence

core/hashtables/hashtables.factor

@@ -112,7 +112,7 @@ M: hashtable delete-at ( key hash -- )
     ] if ;
 
 M: hashtable assoc-size ( hash -- n )
-    [ count>> ] [ deleted>> ] bi - ;
+    [ count>> ] [ deleted>> ] bi - ; inline
 
 : rehash ( hash -- )
     dup >alist [
@@ -150,7 +150,7 @@ M: hashtable >alist
     ] keep { } like ;
 
 M: hashtable clone
-    (clone) [ clone ] change-array ;
+    (clone) [ clone ] change-array ; inline
 
 M: hashtable equal?
     over hashtable? [
@@ -159,15 +159,15 @@ M: hashtable equal?
     ] [ 2drop f ] if ;
 
 ! Default method
-M: assoc new-assoc drop <hashtable> ;
+M: assoc new-assoc drop <hashtable> ; inline
 
-M: f new-assoc drop <hashtable> ;
+M: f new-assoc drop <hashtable> ; inline
 
 : >hashtable ( assoc -- hashtable )
     H{ } assoc-clone-like ;
 
 M: hashtable assoc-like
-    drop dup hashtable? [ >hashtable ] unless ;
+    drop dup hashtable? [ >hashtable ] unless ; inline
 
 : ?set-at ( value key assoc/f -- assoc )
     [ [ set-at ] keep ] [ associate ] if* ;

core/io/encodings/utf8/utf8.factor

@@ -40,7 +40,7 @@ SINGLETON: utf8
     dup stream-read1 dup [ begin-utf8 ] when nip ; inline
 
 M: utf8 decode-char
-    drop decode-utf8 ;
+    drop decode-utf8 ; inline
 
 ! Encoding UTF-8
 

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

core/kernel/kernel.factor

@@ -192,19 +192,19 @@ UNION: boolean POSTPONE: t POSTPONE: f ;
 ! Object protocol
 GENERIC: hashcode* ( depth obj -- code )
 
-M: object hashcode* 2drop 0 ;
+M: object hashcode* 2drop 0 ; inline
 
-M: f hashcode* 2drop 31337 ;
+M: f hashcode* 2drop 31337 ; inline
 
 : hashcode ( obj -- code ) 3 swap hashcode* ; inline
 
 GENERIC: equal? ( obj1 obj2 -- ? )
 
-M: object equal? 2drop f ;
+M: object equal? 2drop f ; inline
 
 TUPLE: identity-tuple ;
 
-M: identity-tuple equal? 2drop f ;
+M: identity-tuple equal? 2drop f ; inline
 
 : = ( obj1 obj2 -- ? )
     2dup eq? [ 2drop t ] [
@@ -213,9 +213,9 @@ M: identity-tuple equal? 2drop f ;
 
 GENERIC: clone ( obj -- cloned )
 
-M: object clone ;
+M: object clone ; inline
 
-M: callstack clone (clone) ;
+M: callstack clone (clone) ; inline
 
 ! Tuple construction
 GENERIC: new ( class -- tuple )

core/layouts/layouts.factor

@@ -78,6 +78,6 @@ M: bignum >integer
 
 M: real >integer
     dup most-negative-fixnum most-positive-fixnum between?
-    [ >fixnum ] [ >bignum ] if ;
+    [ >fixnum ] [ >bignum ] if ; inline
 
 UNION: immediate fixnum POSTPONE: f ;

core/math/floats/floats.factor

@@ -3,28 +3,28 @@
 USING: kernel math math.private ;
 IN: math.floats.private
 
-M: fixnum >float fixnum>float ;
-M: bignum >float bignum>float ;
+M: fixnum >float fixnum>float ; inline
+M: bignum >float bignum>float ; inline
 
-M: float >fixnum float>fixnum ;
-M: float >bignum float>bignum ;
-M: float >float ;
+M: float >fixnum float>fixnum ; inline
+M: float >bignum float>bignum ; inline
+M: float >float ; inline
 
-M: float hashcode* nip float>bits ;
-M: float equal? over float? [ float= ] [ 2drop f ] if ;
-M: float number= float= ;
+M: float hashcode* nip float>bits ; inline
+M: float equal? over float? [ float= ] [ 2drop f ] if ; inline
+M: float number= float= ; inline
 
-M: float < float< ;
-M: float <= float<= ;
-M: float > float> ;
-M: float >= float>= ;
+M: float < float< ; inline
+M: float <= float<= ; inline
+M: float > float> ; inline
+M: float >= float>= ; inline
 
-M: float + float+ ;
-M: float - float- ;
-M: float * float* ;
-M: float / float/f ;
-M: float /f float/f ;
-M: float /i float/f >integer ;
-M: float mod float-mod ;
+M: float + float+ ; inline
+M: float - float- ; inline
+M: float * float* ; inline
+M: float / float/f ; inline
+M: float /f float/f ; inline
+M: float /i float/f >integer ; inline
+M: float mod float-mod ; inline
 
-M: real abs dup 0 < [ neg ] when ;
+M: real abs dup 0 < [ neg ] when ; inline

core/math/integers/integers.factor

@@ -5,79 +5,79 @@ USING: kernel kernel.private sequences
 sequences.private math math.private combinators ;
 IN: math.integers.private
 
-M: integer numerator ;
-M: integer denominator drop 1 ;
+M: integer numerator ; inline
+M: integer denominator drop 1 ; inline
 
-M: fixnum >fixnum ;
-M: fixnum >bignum fixnum>bignum ;
-M: fixnum >integer ;
+M: fixnum >fixnum ; inline
+M: fixnum >bignum fixnum>bignum ; inline
+M: fixnum >integer ; inline
 
-M: fixnum hashcode* nip ;
-M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ;
-M: fixnum number= eq? ;
+M: fixnum hashcode* nip ; inline
+M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline
+M: fixnum number= eq? ; inline
 
-M: fixnum < fixnum< ;
-M: fixnum <= fixnum<= ;
-M: fixnum > fixnum> ;
-M: fixnum >= fixnum>= ;
+M: fixnum < fixnum< ; inline
+M: fixnum <= fixnum<= ; inline
+M: fixnum > fixnum> ; inline
+M: fixnum >= fixnum>= ; inline
 
-M: fixnum + fixnum+ ;
-M: fixnum - fixnum- ;
-M: fixnum * fixnum* ;
-M: fixnum /i fixnum/i ;
-M: fixnum /f [ >float ] dip >float float/f ;
+M: fixnum + fixnum+ ; inline
+M: fixnum - fixnum- ; inline
+M: fixnum * fixnum* ; inline
+M: fixnum /i fixnum/i ; inline
+M: fixnum /f [ >float ] dip >float float/f ; inline
 
-M: fixnum mod fixnum-mod ;
+M: fixnum mod fixnum-mod ; inline
 
-M: fixnum /mod fixnum/mod ;
+M: fixnum /mod fixnum/mod ; inline
 
-M: fixnum bitand fixnum-bitand ;
-M: fixnum bitor fixnum-bitor ;
-M: fixnum bitxor fixnum-bitxor ;
-M: fixnum shift >fixnum fixnum-shift ;
+M: fixnum bitand fixnum-bitand ; inline
+M: fixnum bitor fixnum-bitor ; inline
+M: fixnum bitxor fixnum-bitxor ; inline
+M: fixnum shift >fixnum fixnum-shift ; inline
 
-M: fixnum bitnot fixnum-bitnot ;
+M: fixnum bitnot fixnum-bitnot ; inline
 
-M: fixnum bit? neg shift 1 bitand 0 > ;
+M: fixnum bit? neg shift 1 bitand 0 > ; inline
 
 : fixnum-log2 ( x -- n )
     0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ;
 
-M: fixnum (log2) fixnum-log2 ;
+M: fixnum (log2) fixnum-log2 ; inline
 
-M: bignum >fixnum bignum>fixnum ;
-M: bignum >bignum ;
+M: bignum >fixnum bignum>fixnum ; inline
+M: bignum >bignum ; inline
 
 M: bignum hashcode* nip >fixnum ;
 
 M: bignum equal?
     over bignum? [ bignum= ] [
         swap dup fixnum? [ >bignum bignum= ] [ 2drop f ] if
-    ] if ;
+    ] if ; inline
 
-M: bignum number= bignum= ;
+M: bignum number= bignum= ; inline
 
-M: bignum < bignum< ;
-M: bignum <= bignum<= ;
-M: bignum > bignum> ;
-M: bignum >= bignum>= ;
+M: bignum < bignum< ; inline
+M: bignum <= bignum<= ; inline
+M: bignum > bignum> ; inline
+M: bignum >= bignum>= ; inline
 
-M: bignum + bignum+ ;
-M: bignum - bignum- ;
-M: bignum * bignum* ;
-M: bignum /i bignum/i ;
-M: bignum mod bignum-mod ;
+M: bignum + bignum+ ; inline
+M: bignum - bignum- ; inline
+M: bignum * bignum* ; inline
+M: bignum /i bignum/i ; inline
+M: bignum mod bignum-mod ; inline
 
-M: bignum /mod bignum/mod ;
+M: bignum /mod bignum/mod ; inline
 
-M: bignum bitand bignum-bitand ;
-M: bignum bitor bignum-bitor ;
-M: bignum bitxor bignum-bitxor ;
-M: bignum shift >fixnum bignum-shift ;
+M: bignum bitand bignum-bitand ; inline
+M: bignum bitor bignum-bitor ; inline
+M: bignum bitxor bignum-bitxor ; inline
+M: bignum shift >fixnum bignum-shift ; inline
 
-M: bignum bitnot bignum-bitnot ;
-M: bignum bit? bignum-bit? ;
-M: bignum (log2) bignum-log2 ;
+M: bignum bitnot bignum-bitnot ; inline
+M: bignum bit? bignum-bit? ; inline
+M: bignum (log2) bignum-log2 ; inline
 
 ! Converting ratios to floats. Based on FLOAT-RATIO from
 ! sbcl/src/code/float.lisp, which has the following license:

core/math/math.factor

@@ -98,38 +98,38 @@ GENERIC: fp-infinity? ( x -- ? )
 GENERIC: fp-nan-payload ( x -- bits )
 
 M: object fp-special?
-    drop f ;
+    drop f ; inline
 M: object fp-nan?
-    drop f ;
+    drop f ; inline
 M: object fp-qnan?
-    drop f ;
+    drop f ; inline
 M: object fp-snan?
-    drop f ;
+    drop f ; inline
 M: object fp-infinity?
-    drop f ;
+    drop f ; inline
 M: object fp-nan-payload
-    drop f ;
+    drop f ; inline
 
 M: float fp-special?
-    double>bits -52 shift HEX: 7ff [ bitand ] keep = ;
+    double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline
 
 M: float fp-nan-payload
-    double>bits HEX: fffffffffffff bitand ; foldable flushable
+    double>bits HEX: fffffffffffff bitand ; inline
 
 M: float fp-nan?
-    dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ;
+    dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
 
 M: float fp-qnan?
-    dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ;
+    dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; inline
 
 M: float fp-snan?
-    dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ;
+    dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; inline
 
 M: float fp-infinity?
-    dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ;
+    dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
 
 : <fp-nan> ( payload -- nan )
-    HEX: 7ff0000000000000 bitor bits>double ; foldable flushable
+    HEX: 7ff0000000000000 bitor bits>double ; inline
 
 : next-float ( m -- n )
     double>bits
@@ -137,7 +137,7 @@ M: float fp-infinity?
         dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
             1 + bits>double ! positive
         ] if
-    ] if ; foldable flushable
+    ] if ; inline
 
 : prev-float ( m -- n )
     double>bits
@@ -145,7 +145,7 @@ M: float fp-infinity?
         dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
             1 - bits>double ! positive non-zero
         ] if
-    ] if ; foldable flushable
+    ] if ; inline
 
 : next-power-of-2 ( m -- n )
     dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline

core/math/order/order.factor

@@ -15,24 +15,24 @@ GENERIC: <=> ( obj1 obj2 -- <=> )
 
 : >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline
 
-M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
+M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
 
 GENERIC: before? ( obj1 obj2 -- ? )
 GENERIC: after? ( obj1 obj2 -- ? )
 GENERIC: before=? ( obj1 obj2 -- ? )
 GENERIC: after=? ( obj1 obj2 -- ? )
 
-M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ;
-M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ;
-M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ;
-M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ;
+M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; inline
+M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; inline
+M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; inline
+M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; inline
 
-M: real before? ( obj1 obj2 -- ? ) < ;
-M: real after? ( obj1 obj2 -- ? ) > ;
-M: real before=? ( obj1 obj2 -- ? ) <= ;
-M: real after=? ( obj1 obj2 -- ? ) >= ;
+M: real before? ( obj1 obj2 -- ? ) < ; inline
+M: real after? ( obj1 obj2 -- ? ) > ; inline
+M: real before=? ( obj1 obj2 -- ? ) <= ; inline
+M: real after=? ( obj1 obj2 -- ? ) >= ; inline
 
-: min ( x y -- z ) [ before? ] most ; inline 
+: min ( x y -- z ) [ before? ] most ; inline
 : max ( x y -- z ) [ after? ] most ; inline
 : clamp ( x min max -- y ) [ max ] dip min ; inline
 

core/sbufs/sbufs.factor

@@ -11,24 +11,24 @@ TUPLE: sbuf
 : <sbuf> ( n -- sbuf ) 0 <string> 0 sbuf boa ; inline
 
 M: sbuf set-nth-unsafe
-    [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ;
+    [ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; inline
 
 M: sbuf new-sequence
-    drop [ 0 <string> ] [ >fixnum ] bi sbuf boa ;
+    drop [ 0 <string> ] [ >fixnum ] bi sbuf boa ; inline
 
 : >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline
 
 M: sbuf like
     drop dup sbuf? [
         dup string? [ dup length sbuf boa ] [ >sbuf ] if
-    ] unless ;
+    ] unless ; inline
 
-M: sbuf new-resizable drop <sbuf> ;
+M: sbuf new-resizable drop <sbuf> ; inline
 
 M: sbuf equal?
     over sbuf? [ sequence= ] [ 2drop f ] if ;
 
-M: string new-resizable drop <sbuf> ;
+M: string new-resizable drop <sbuf> ; inline
 
 M: string like
     #! If we have a string, we're done.
@@ -41,6 +41,6 @@ M: string like
             2dup length eq?
             [ nip dup reset-string-hashcode ] [ resize-string ] if
         ] [ >string ] if
-    ] unless ;
+    ] unless ; inline
 
 INSTANCE: sbuf growable

core/sequences/sequences-docs.factor

@@ -1392,7 +1392,7 @@ $nl
 "More elaborate counted loops can be performed with " { $link "math.ranges" } "." ;
 
 ARTICLE: "sequences-if" "Control flow with sequences"
-"To reduce the boilerplate of checking if a sequence is empty or a number is zero, several combinators are provided."
+"To reduce the boilerplate of checking if a sequence is empty, several combinators are provided."
 $nl
 "Checking if a sequence is empty:"
 { $subsection if-empty }

core/sequences/sequences.factor

@@ -18,14 +18,14 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable
 : new-like ( len exemplar quot -- seq )
     over [ [ new-sequence ] dip call ] dip like ; inline
 
-M: sequence like drop ;
+M: sequence like drop ; inline
 
 GENERIC: lengthen ( n seq -- )
 GENERIC: shorten ( n seq -- )
 
-M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
+M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; inline
 
-M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
+M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline
 
 : empty? ( seq -- ? ) length 0 = ; inline
 
@@ -82,25 +82,25 @@ GENERIC: resize ( n seq -- newseq ) flushable
 GENERIC: nth-unsafe ( n seq -- elt ) flushable
 GENERIC: set-nth-unsafe ( elt n seq -- )
 
-M: sequence nth bounds-check nth-unsafe ;
-M: sequence set-nth bounds-check set-nth-unsafe ;
+M: sequence nth bounds-check nth-unsafe ; inline
+M: sequence set-nth bounds-check set-nth-unsafe ; inline
 
-M: sequence nth-unsafe nth ;
-M: sequence set-nth-unsafe set-nth ;
+M: sequence nth-unsafe nth ; inline
+M: sequence set-nth-unsafe set-nth ; inline
 
 : change-nth-unsafe ( i seq quot -- )
     [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline
 
 ! The f object supports the sequence protocol trivially
-M: f length drop 0 ;
-M: f nth-unsafe nip ;
-M: f like drop [ f ] when-empty ;
+M: f length drop 0 ; inline
+M: f nth-unsafe nip ; inline
+M: f like drop [ f ] when-empty ; inline
 
 INSTANCE: f immutable-sequence
 
 ! Integers support the sequence protocol
-M: integer length ;
-M: integer nth-unsafe drop ;
+M: integer length ; inline
+M: integer nth-unsafe drop ; inline
 
 INSTANCE: integer immutable-sequence
 
@@ -113,8 +113,8 @@ TUPLE: iota { n integer read-only } ;
 
 <PRIVATE
 
-M: iota length n>> ;
-M: iota nth-unsafe drop ;
+M: iota length n>> ; inline
+M: iota nth-unsafe drop ; inline
 
 INSTANCE: iota immutable-sequence
 
@@ -185,12 +185,12 @@ MIXIN: virtual-sequence
 GENERIC: virtual-seq ( seq -- seq' )
 GENERIC: virtual@ ( n seq -- n' seq' )
 
-M: virtual-sequence nth virtual@ nth ;
-M: virtual-sequence set-nth virtual@ set-nth ;
-M: virtual-sequence nth-unsafe virtual@ nth-unsafe ;
-M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ;
-M: virtual-sequence like virtual-seq like ;
-M: virtual-sequence new-sequence virtual-seq new-sequence ;
+M: virtual-sequence nth virtual@ nth ; inline
+M: virtual-sequence set-nth virtual@ set-nth ; inline
+M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; inline
+M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; inline
+M: virtual-sequence like virtual-seq like ; inline
+M: virtual-sequence new-sequence virtual-seq new-sequence ; inline
 
 INSTANCE: virtual-sequence sequence
 
@@ -199,11 +199,9 @@ TUPLE: reversed { seq read-only } ;
 
 C: <reversed> reversed
 
-M: reversed virtual-seq seq>> ;
-
-M: reversed virtual@ seq>> [ length swap - 1 - ] keep ;
-
-M: reversed length seq>> length ;
+M: reversed virtual-seq seq>> ; inline
+M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; inline
+M: reversed length seq>> length ; inline
 
 INSTANCE: reversed virtual-sequence
 
@@ -233,11 +231,11 @@ TUPLE: slice-error from to seq reason ;
     check-slice
     slice boa ; inline
 
-M: slice virtual-seq seq>> ;
+M: slice virtual-seq seq>> ; inline
 
-M: slice virtual@ [ from>> + ] [ seq>> ] bi ;
+M: slice virtual@ [ from>> + ] [ seq>> ] bi ; inline
 
-M: slice length [ to>> ] [ from>> ] bi - ;
+M: slice length [ to>> ] [ from>> ] bi - ; inline
 
 : short ( seq n -- seq n' ) over length min ; inline
 
@@ -260,8 +258,8 @@ TUPLE: repetition { len read-only } { elt read-only } ;
 
 C: <repetition> repetition
 
-M: repetition length len>> ;
-M: repetition nth-unsafe nip elt>> ;
+M: repetition length len>> ; inline
+M: repetition nth-unsafe nip elt>> ; inline
 
 INSTANCE: repetition immutable-sequence
 
@@ -316,9 +314,9 @@ PRIVATE>
     (copy) drop ; inline
 
 M: sequence clone-like
-    [ dup length ] dip new-sequence [ 0 swap copy ] keep ;
+    [ dup length ] dip new-sequence [ 0 swap copy ] keep ; inline
 
-M: immutable-sequence clone-like like ;
+M: immutable-sequence clone-like like ; inline
 
 : push-all ( src dest -- ) [ length ] [ copy ] bi ;
 

core/slots/slots.factor

@@ -24,7 +24,8 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
     [ create-method ] 2dip
     [ [ props>> ] [ drop ] [ ] tri* update ]
     [ drop define ]
-    3bi ;
+    [ 2drop make-inline ]
+    3tri ;
 
 GENERIC# reader-quot 1 ( class slot-spec -- quot )
 
@@ -41,11 +42,7 @@ M: object reader-quot
     dup t "reader" set-word-prop ;
 
 : reader-props ( slot-spec -- assoc )
-    [
-        [ "reading" set ]
-        [ read-only>> [ t "foldable" set ] when ] bi
-        t "flushable" set
-    ] H{ } make-assoc ;
+    "reading" associate ;
 
 : define-reader-generic ( name -- )
     reader-word (( object -- value )) define-simple-generic ;

core/strings/strings.factor

@@ -37,24 +37,24 @@ M: string hashcode*
     [ ] [ dup rehash-string string-hashcode ] ?if ;
 
 M: string length
-    length>> ;
+    length>> ; inline
 
 M: string nth-unsafe
-    [ >fixnum ] dip string-nth ;
+    [ >fixnum ] dip string-nth ; inline
 
 M: string set-nth-unsafe
     dup reset-string-hashcode
-    [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ;
+    [ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; inline
 
 M: string clone
-    (clone) [ clone ] change-aux ;
+    (clone) [ clone ] change-aux ; inline
 
-M: string resize resize-string ;
+M: string resize resize-string ; inline
 
 : 1string ( ch -- str ) 1 swap <string> ;
 
 : >string ( seq -- str ) "" clone-like ;
 
-M: string new-sequence drop 0 <string> ;
+M: string new-sequence drop 0 <string> ; inline
 
 INSTANCE: string sequence

core/vectors/vectors.factor

@@ -15,10 +15,10 @@ TUPLE: vector
 M: vector like
     drop dup vector? [
         dup array? [ dup length vector boa ] [ >vector ] if
-    ] unless ;
+    ] unless ; inline
 
 M: vector new-sequence
-    drop [ f <array> ] [ >fixnum ] bi vector boa ;
+    drop [ f <array> ] [ >fixnum ] bi vector boa ; inline
 
 M: vector equal?
     over vector? [ sequence= ] [ 2drop f ] if ;
@@ -34,9 +34,9 @@ M: array like
             2dup length eq?
             [ nip ] [ resize-array ] if
         ] [ >array ] if
-    ] unless ;
+    ] unless ; inline
 
-M: sequence new-resizable drop <vector> ;
+M: sequence new-resizable drop <vector> ; inline
 
 INSTANCE: vector growable
 

core/words/words.factor

@@ -12,7 +12,7 @@ IN: words
 
 M: word execute (execute) ;
 
-M: word ?execute execute( -- value ) ;
+M: word ?execute execute( -- value ) ; inline
 
 M: word <=>
     [ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
@@ -213,7 +213,7 @@ M: word forget*
     ] if ;
 
 M: word hashcode*
-    nip 1 slot { fixnum } declare ; foldable
+    nip 1 slot { fixnum } declare ; inline foldable
 
 M: word literalize <wrapper> ;
 

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-y_stride * >fixnum ] 2bi ; inline
+    [ yuv_buffer-uv_stride swap 2/ * ] [ yuv_buffer-y_stride * ] 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/canonicalize.factor

@@ -1,6 +1,6 @@
-IN: multi-methods.tests
 USING: multi-methods tools.test math sequences namespaces system
 kernel strings ;
+IN: multi-methods.tests
 
 [ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
 

extra/multi-methods/tests/definitions.factor

@@ -1,9 +1,10 @@
-IN: multi-methods.tests
 USING: multi-methods tools.test math sequences namespaces system
 kernel strings words compiler.units quotations ;
+IN: multi-methods.tests
 
 DEFER: fake
 \ fake H{ } clone "multi-methods" set-word-prop
+<< (( -- )) \ fake set-stack-effect >>
 
 [ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
 

extra/multi-methods/tests/legacy.factor

@@ -1,5 +1,5 @@
-IN: multi-methods.tests
 USING: math strings sequences tools.test ;
+IN: multi-methods.tests
 
 GENERIC: legacy-test ( a -- b )
 

extra/multi-methods/tests/syntax.factor

@@ -1,9 +1,10 @@
-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:
+IN: multi-methods.tests
 
-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? { scissors rock } t ;
-METHOD: beats? { rock paper } t ;
-METHOD: beats? { thing thing } f ;
+METHOD: beats? { paper scissors } 2drop t ;
+METHOD: beats? { scissors rock } 2drop t ;
+METHOD: beats? { rock paper } 2drop t ;
+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 } ;

extra/rpn/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/rpn/rpn.factor

@@ -0,0 +1,45 @@
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators io kernel lists math math.parser
+sequences splitting ;
+IN: rpn
+
+SINGLETONS: add-insn sub-insn mul-insn div-insn ;
+TUPLE: push-insn value ;
+
+GENERIC: eval-insn ( stack insn -- stack )
+
+: binary-op ( stack quot: ( x y -- z ) -- stack )
+    [ uncons uncons ] dip dip cons ; inline
+
+M: add-insn eval-insn drop [ + ] binary-op ;
+M: sub-insn eval-insn drop [ - ] binary-op ;
+M: mul-insn eval-insn drop [ * ] binary-op ;
+M: div-insn eval-insn drop [ / ] binary-op ;
+M: push-insn eval-insn value>> swons ;
+
+: rpn-tokenize ( string -- string' )
+    " " split harvest sequence>list ;
+
+: rpn-parse ( string -- tokens )
+    rpn-tokenize [
+        {
+            { "+" [ add-insn ] }
+            { "-" [ sub-insn ] }
+            { "*" [ mul-insn ] }
+            { "/" [ div-insn ] }
+            [ string>number push-insn boa ]
+        } case
+    ] lmap ;
+
+: print-stack ( list -- )
+    [ number>string print ] leach ;
+
+: rpn-eval ( tokens -- )
+    nil [ eval-insn ] foldl print-stack ;
+
+: rpn ( -- )
+    "RPN> " write flush
+    readln [ rpn-parse rpn-eval rpn ] when* ;
+
+MAIN: rpn

extra/rpn/summary.txt

@@ -0,0 +1 @@
+Simple RPN calculator

extra/rpn/tags.txt

@@ -0,0 +1 @@
+demos