Various minor compiler tweaks

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

@@ -48,3 +48,5 @@ TYPEDEF: uchar* MyLPBYTE
 [
     0 B{ 1 2 3 4 } <displaced-alien> <void*>
 ] must-fail
+
+[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test

core/alien/c-types/c-types.factor

@@ -348,7 +348,7 @@ M: long-long-type box-return ( type -- )
 
     <c-type>
         [ alien-unsigned-4 zero? not ] >>getter
-        [ 1 0 ? set-alien-unsigned-4 ] >>setter
+        [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
         4 >>size
         4 >>align
         "box_boolean" >>boxer
@@ -357,7 +357,7 @@ M: long-long-type box-return ( type -- )
 
     <c-type>
         [ alien-float ] >>getter
-        [ >r >r >float r> r> set-alien-float ] >>setter
+        [ [ >float ] 2dip set-alien-float ] >>setter
         4 >>size
         4 >>align
         "box_float" >>boxer
@@ -368,7 +368,7 @@ M: long-long-type box-return ( type -- )
 
     <c-type>
         [ alien-double ] >>getter
-        [ >r >r >float r> r> set-alien-double ] >>setter
+        [ [ >float ] 2dip set-alien-double ] >>setter
         8 >>size
         8 >>align
         "box_double" >>boxer

core/classes/algebra/algebra-tests.factor

@@ -306,3 +306,9 @@ INTERSECTION: empty-intersection ;
 [ t ] [ object \ f class-not \ f class-or class<= ] unit-test
 
 [ ] [ object flatten-builtin-class drop ] unit-test
+
+SINGLETON: sa
+SINGLETON: sb
+SINGLETON: sc
+
+[ sa ] [ sa { sa sb sc } min-class ] unit-test

core/classes/singleton/singleton.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.predicate kernel sequences words ;
+USING: classes classes.algebra classes.predicate kernel
+sequences words ;
 IN: classes.singleton
 
 PREDICATE: singleton-class < predicate-class
@@ -11,3 +12,6 @@ PREDICATE: singleton-class < predicate-class
     \ word over [ eq? ] curry define-predicate-class ;
 
 M: singleton-class instance? eq? ;
+
+M: singleton-class (classes-intersect?)
+    over singleton-class? [ eq? ] [ call-next-method ] if ;

core/classes/tuple/tuple.factor

@@ -336,6 +336,8 @@ M: tuple-class boa
     [ tuple-layout ]
     bi <tuple-boa> ;
 
+M: tuple-class initial-value* new ;
+
 ! Deprecated
 M: object get-slots ( obj slots -- ... )
     [ execute ] with each ;

core/growable/growable.factor

@@ -59,4 +59,11 @@ M: growable lengthen ( n seq -- )
         2dup (>>length)
     ] when 2drop ;
 
+M: growable shorten ( n seq -- )
+    growable-check
+    2dup length < [
+        2dup contract
+        2dup (>>length)
+    ] when 2drop ;
+
 INSTANCE: growable sequence

core/inference/class/class-tests.factor

@@ -5,8 +5,9 @@ sequences words inference.class quotations alien
 alien.c-types strings sbufs sequences.private
 slots.private combinators definitions compiler.units
 system layouts vectors optimizer.math.partial
-optimizer.inlining optimizer.backend math.order
+optimizer.inlining optimizer.backend math.order math.functions
-accessors hashtables classes assocs ;
+accessors hashtables classes assocs io.encodings.utf8
+io.encodings.ascii io.encodings ;
 
 [ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
 
@@ -193,19 +194,15 @@ M: fixnum detect-fx ;
 
 
 [ t ] [
-    [ { string sbuf } declare push-all ] \ push-all inlined?
+    [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
 ] unit-test
 
 [ t ] [
-    [ { string sbuf } declare push-all ] \ + inlined?
+    [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
 ] unit-test
 
 [ t ] [
-    [ { string sbuf } declare push-all ] \ fixnum+ inlined?
+    [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
-] unit-test
-
-[ t ] [
-    [ { string sbuf } declare push-all ] \ >fixnum inlined?
 ] unit-test
 
 [ t ] [
@@ -600,6 +597,29 @@ TUPLE: declared-fixnum { x fixnum } ;
     { slot } inlined?
 ] unit-test
 
+[ t ] [
+    [
+        { array } declare length
+        1 + dup 100 fixnum> [ 1 fixnum+ ] when
+    ] \ fixnum+ inlined?
+] unit-test
+ 
+[ t ] [
+    [ [ resize-array ] keep length ] \ length inlined?
+] unit-test
+
+[ t ] [
+    [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
+] unit-test
+
+[ t ] [
+    [ { utf8 } declare decode-char ] \ decode-char inlined?
+] unit-test
+
+[ t ] [
+    [ { ascii } declare decode-char ] \ decode-char inlined?
+] unit-test
+
 ! Later
 
 ! [ t ] [

core/inference/class/class.factor

@@ -129,8 +129,12 @@ GENERIC: infer-classes-before ( node -- )
 
 GENERIC: infer-classes-around ( node -- )
 
+GENERIC: infer-classes-after ( node -- )
+
 M: node infer-classes-before drop ;
 
+M: node infer-classes-after drop ;
+
 M: node child-constraints
     children>> length
     dup zero? [ drop f ] [ f <repetition> ] if ;
@@ -203,11 +207,19 @@ M: pair constraint-satisfied?
     [ ] [ param>> "default-output-classes" word-prop ] ?if
     r> ;
 
-M: #call infer-classes-before
+: intersect-values ( classes intervals values -- )
-    [ compute-constraints ] keep
-    [ output-classes ] [ out-d>> ] bi
     tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
 
+M: #call infer-classes-before
+    [ compute-constraints ]
+    [ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
+
+: input-classes ( #call -- classes )
+    param>> "input-classes" word-prop ;
+
+M: #call infer-classes-after
+    [ input-classes ] [ in-d>> ] bi intersect-classes ;
+
 M: #push infer-classes-before
     out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
 
@@ -340,6 +352,7 @@ M: object infer-classes-around
     {
         [ infer-classes-before ]
         [ annotate-node ]
+        [ infer-classes-after ]
         [ infer-children ]
         [ merge-children ]
     } cleave ;

core/inference/known-words/known-words.factor

@@ -153,8 +153,10 @@ M: object infer-call
 ] "infer" set-word-prop
 
 :  set-primitive-effect ( word effect -- )
-    2dup effect-out "default-output-classes" set-word-prop
+    [ in>> "input-classes" set-word-prop ]
-    dupd [ make-call-node ] 2curry "infer" set-word-prop ;
+    [ out>> "default-output-classes" set-word-prop ]
+    [ dupd [ make-call-node ] 2curry "infer" set-word-prop ]
+    2tri ;
 
 ! Stack effects for all primitives
 \ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect

core/io/encodings/encodings.factor

@@ -99,14 +99,20 @@ M: decoder stream-read-partial stream-read ;
     [ >r drop "" like r> ]
     [ pick push ((read-until)) ] if ; inline
 
-: (read-until) ( seps stream -- string/f sep/f )
+: (read-until) ( quot -- string/f sep/f )
-    SBUF" " clone -rot >decoder<
+    100 <sbuf> swap ((read-until)) ; inline
+
+: decoder-read-until ( seps stream encoding -- string/f sep/f )
     [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry
-    ((read-until)) ; inline
+    (read-until) ;
 
-M: decoder stream-read-until (read-until) ;
+M: decoder stream-read-until >decoder< decoder-read-until ;
 
-M: decoder stream-readln "\r\n" over (read-until) handle-readln ;
+: decoder-readln ( stream encoding -- string/f sep/f )
+    [ decode-char dup [ dup "\r\n" member? ] [ drop f t ] if ] 2curry
+    (read-until) ;
+
+M: decoder stream-readln dup >decoder< decoder-readln handle-readln ;
 
 M: decoder dispose stream>> dispose ;
 
@@ -119,8 +125,11 @@ M: object <encoder> encoder boa ;
 M: encoder stream-write1
     >encoder< encode-char ;
 
+: decoder-write ( string stream encoding -- )
+    [ encode-char ] 2curry each ;
+
 M: encoder stream-write
-    >encoder< [ encode-char ] 2curry each ;
+    >encoder< decoder-write ;
 
 M: encoder dispose encoder-stream dispose ;
 

core/io/encodings/utf8/utf8.factor

@@ -11,21 +11,21 @@ SINGLETON: utf8
 <PRIVATE 
 
 : starts-2? ( char -- ? )
-    dup [ -6 shift BIN: 10 number= ] when ;
+    dup [ -6 shift BIN: 10 number= ] when ; inline
 
 : append-nums ( stream byte -- stream char )
     over stream-read1 dup starts-2?
     [ swap 6 shift swap BIN: 111111 bitand bitor ]
-    [ 2drop replacement-char ] if ;
+    [ 2drop replacement-char ] if ; inline
 
 : double ( stream byte -- stream char )
-    BIN: 11111 bitand append-nums ;
+    BIN: 11111 bitand append-nums ; inline
 
 : triple ( stream byte -- stream char )
-    BIN: 1111 bitand append-nums append-nums ;
+    BIN: 1111 bitand append-nums append-nums ; inline
 
 : quad ( stream byte -- stream char )
-    BIN: 111 bitand append-nums append-nums append-nums ;
+    BIN: 111 bitand append-nums append-nums append-nums ; inline
 
 : begin-utf8 ( stream byte -- stream char )
     {
@@ -34,10 +34,10 @@ SINGLETON: utf8
         { [ dup -4 shift BIN: 1110 number= ] [ triple ] }
         { [ dup -3 shift BIN: 11110 number= ] [ quad ] }
         [ drop replacement-char ]
-    } cond ;
+    } cond ; inline
 
 : decode-utf8 ( stream -- char/f )
-    dup stream-read1 dup [ begin-utf8 ] when nip ;
+    dup stream-read1 dup [ begin-utf8 ] when nip ; inline
 
 M: utf8 decode-char
     drop decode-utf8 ;

core/optimizer/inlining/inlining-tests.factor

@@ -7,14 +7,3 @@ sequences growable sbufs vectors sequences.private accessors kernel ;
 \ optimistic-inline? must-infer
 \ find-identity must-infer
 \ dispatching-class must-infer
-
-! Make sure we have sane heuristics
-[ t ] [ \ fixnum \ shift method should-inline? ] unit-test
-[ f ] [ \ array \ equal? method should-inline? ] unit-test
-[ f ] [ \ sequence \ hashcode* method should-inline? ] unit-test
-[ t ] [ \ array \ nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ sbuf \ set-nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ set-nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ set-nth method should-inline? ] unit-test
-[ t ] [ \ vector \ (>>length) method should-inline? ] unit-test

core/optimizer/inlining/inlining.factor

@@ -2,12 +2,13 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generic assocs inference inference.class
 inference.dataflow inference.backend inference.state io kernel
-math namespaces sequences vectors words quotations hashtables
+math math.order namespaces sequences vectors words quotations
-combinators classes classes.algebra generic.math
+hashtables combinators effects classes classes.union
-optimizer.math.partial continuations optimizer.def-use
+classes.algebra generic.math optimizer.math.partial
-optimizer.backend generic.standard optimizer.specializers
+continuations optimizer.def-use optimizer.backend
-optimizer.def-use optimizer.pattern-match generic.standard
+generic.standard optimizer.specializers optimizer.def-use
-optimizer.control kernel.private definitions sets ;
+optimizer.pattern-match generic.standard optimizer.control
+kernel.private definitions sets summary ;
 IN: optimizer.inlining
 
 : remember-inlining ( node history -- )
@@ -31,9 +32,9 @@ DEFER: (flat-length)
 : word-flat-length ( word -- n )
     {
         ! not inline
-        { [ dup inline? not ] [ drop 0 ] }
+        { [ dup inline? not ] [ drop 1 ] }
         ! recursive and inline
-        { [ dup recursive-calls get key? ] [ drop 4 ] }
+        { [ dup recursive-calls get key? ] [ drop 10 ] }
         ! inline
         [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
     } cond ;
@@ -41,7 +42,7 @@ DEFER: (flat-length)
 : (flat-length) ( seq -- n )
     [
         {
-            { [ dup quotation? ] [ (flat-length) 1+ ] }
+            { [ dup quotation? ] [ (flat-length) 2 + ] }
             { [ dup array? ] [ (flat-length) ] }
             { [ dup word? ] [ word-flat-length ] }
             [ drop 0 ]
@@ -51,7 +52,7 @@ DEFER: (flat-length)
 : flat-length ( word -- n )
     H{ } clone recursive-calls [
         [ recursive-calls get conjoin ]
-        [ def>> (flat-length) ]
+        [ def>> (flat-length) 5 /i ]
         bi
     ] with-variable ;
 
@@ -102,7 +103,7 @@ DEFER: (flat-length)
     [ f splice-quot ] [ 2drop t ] if ;
 
 : inline-method ( #call -- node )
-    dup node-param {
+    dup param>> {
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }
         { [ dup math-partial? ] [ inline-math-partial ] }
@@ -155,15 +156,35 @@ DEFER: (flat-length)
     (optimize-predicate) optimize-check ;
 
 : flush-eval? ( #call -- ? )
-    dup node-param "flushable" word-prop [
+    dup node-param "flushable" word-prop
-        node-out-d [ unused? ] all?
+    [ node-out-d [ unused? ] all? ] [ drop f ] if ;
-    ] [
+
-        drop f
+ERROR: flushed-eval-error word ;
-    ] if ;
+
+M: flushed-eval-error summary
+    drop "Flushed evaluation of word would have thrown an error" ;
+
+: flushed-eval-quot ( #call -- quot )
+    #! A quotation to replace flushed evaluations with. We can't
+    #! just remove the code altogether, because if the optimizer
+    #! knows the input types of a word, it assumes the inputs are
+    #! of this type after the word returns, since presumably
+    #! the word would have checked input types itself. However,
+    #! if the word gets flushed, then it won't do this checking;
+    #! so we have to do it here.
+    [
+        dup param>> "input-classes" word-prop [
+            make-specializer %
+            [ dup param>> literalize , \ flushed-eval-error , ] [ ] make ,
+            \ unless ,
+        ] when*
+        dup in-d>> length [ \ drop , ] times
+        out-d>> length [ f , ] times
+    ] [ ] make ;
 
 : flush-eval ( #call -- node )
-    dup node-param +inlined+ depends-on
+    dup param>> +inlined+ depends-on
-    dup node-out-d length f <repetition> inline-literals ;
+    dup flushed-eval-quot f splice-quot ;
 
 : partial-eval? ( #call -- ? )
     dup node-param "foldable" word-prop [
@@ -195,13 +216,28 @@ DEFER: (flat-length)
     [ drop +inlined+ depends-on ] [ swap 1array ] 2bi
     splice-quot ;
 
+: classes-known? ( #call -- ? )
+    node-input-classes [
+        [ class-types length 1 = ]
+        [ union-class? not ]
+        bi and
+    ] contains? ;
+
+: inlining-rank ( #call -- n )
+    {
+        [ param>> flat-length 24 swap [-] 4 /i ]
+        [ param>> "default" word-prop -4 0 ? ]
+        [ param>> "specializer" word-prop 1 0 ? ]
+        [ param>> method-body? 1 0 ? ]
+        [ classes-known? 2 0 ? ]
+    } cleave + + + + ;
+
+: should-inline? ( #call -- ? )
+    inlining-rank 5 >= ;
+
 : optimistic-inline? ( #call -- ? )
-    dup node-param "specializer" word-prop dup [
+    dup param>> "specializer" word-prop
-        >r node-input-classes r> specialized-length tail*
+    [ should-inline? ] [ drop f ] if ;
-        [ class-types length 1 = ] all?
-    ] [
-        2drop f
-    ] if ;
 
 : already-inlined? ( #call -- ? )
     [ param>> ] [ history>> ] bi memq? ;
@@ -211,11 +247,8 @@ DEFER: (flat-length)
         dup param>> dup def>> splice-word-def
     ] if ;
 
-: should-inline? ( word -- ? )
-    flat-length 11 <= ;
-
 : method-body-inline? ( #call -- ? )
-    param>> dup [ method-body? ] [ "default" word-prop not ] bi and
+    dup param>> method-body?
     [ should-inline? ] [ drop f ] if ;
 
 M: #call optimize-node*

core/optimizer/math/math.factor

@@ -1,14 +1,15 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: effects alien alien.accessors arrays generic hashtables
+kernel assocs math math.libm math.private kernel.private
+sequences words parser inference.class inference.dataflow
+vectors strings sbufs io namespaces assocs quotations
+math.intervals sequences.private combinators splitting layouts
+math.parser classes classes.algebra generic.math
+optimizer.pattern-match optimizer.backend optimizer.def-use
+optimizer.inlining optimizer.math.partial generic.standard
+system accessors ;
 IN: optimizer.math
-USING: alien alien.accessors arrays generic hashtables kernel
-assocs math math.private kernel.private sequences words parser
-inference.class inference.dataflow vectors strings sbufs io
-namespaces assocs quotations math.intervals sequences.private
-combinators splitting layouts math.parser classes
-classes.algebra generic.math optimizer.pattern-match
-optimizer.backend optimizer.def-use optimizer.inlining
-optimizer.math.partial generic.standard system accessors ;
 
 : define-math-identities ( word identities -- )
     >r all-derived-ops r> define-identities ;
@@ -169,6 +170,22 @@ optimizer.math.partial generic.standard system accessors ;
     ] 2curry each-derived-op
 ] each
 
+: math-output-class/interval-2-fast ( node word -- classes intervals )
+    math-output-interval-2 fixnum [ 1array ] bi@ swap ; inline
+
+[
+    { + interval+ }
+    { - interval- }
+    { * interval* }
+    { shift interval-shift-safe }
+] [
+    first2 [
+        [
+            math-output-class/interval-2-fast
+        ] curry "output-classes" set-word-prop
+    ] curry each-fast-derived-op
+] each
+
 : real-value? ( value -- n ? )
     dup value? [ value-literal dup real? ] [ drop f f ] if ;
 
@@ -420,3 +437,37 @@ most-negative-fixnum most-positive-fixnum [a,b]
         [ fixnumify-bitand ]
     }
 } define-optimizers
+
+{ + - * / }
+[ { number number } "input-classes" set-word-prop ] each
+
+{ /f < > <= >= }
+[ { real real } "input-classes" set-word-prop ] each
+
+{ /i bitand bitor bitxor bitnot shift }
+[ { integer integer } "input-classes" set-word-prop ] each
+
+{
+    fcosh
+    flog
+    fsinh
+    fexp
+    fasin
+    facosh
+    fasinh
+    ftanh
+    fatanh
+    facos
+    fpow
+    fatan
+    fatan2
+    fcos
+    ftan
+    fsin
+    fsqrt
+} [
+    dup stack-effect
+    [ in>> length real <repetition> "input-classes" set-word-prop ]
+    [ out>> length float <repetition> "default-output-classes" set-word-prop ]
+    2bi
+] each

core/optimizer/math/partial/partial.factor

@@ -170,3 +170,6 @@ SYMBOL: fast-math-ops
 
 : each-derived-op ( word quot -- )
     >r derived-ops r> each ; inline
+
+: each-fast-derived-op ( word quot -- )
+    >r fast-derived-ops r> each ; inline

core/optimizer/optimizer-tests.factor

@@ -375,3 +375,12 @@ PREDICATE: list < improper-list
 [ 2 3 ] [ 2 interval-inference-bug ] unit-test
 [ 1 4 ] [ 1 interval-inference-bug ] unit-test
 [ 0 5 ] [ 0 interval-inference-bug ] unit-test
+
+: aggressive-flush-regression ( a -- b )
+    f over >r <array> drop r> 1 + ;
+
+[ 1.0 aggressive-flush-regression drop ] must-fail
+
+[ 1 [ "hi" + drop ] compile-call ] must-fail
+
+[ "hi" f [ <array> drop ] compile-call ] must-fail

core/sequences/sequences.factor

@@ -21,9 +21,12 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable
 M: sequence like drop ;
 
 GENERIC: lengthen ( n seq -- )
+GENERIC: shorten ( n seq -- )
 
 M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
 
+M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
+
 : empty? ( seq -- ? ) length zero? ; inline
 : delete-all ( seq -- ) 0 swap set-length ;
 
@@ -530,7 +533,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
 
 : peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
 
-: pop* ( seq -- ) [ length 1- ] [ set-length ] bi ;
+: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
 
 : move-backward ( shift from to seq -- )
     2over number= [
@@ -575,7 +578,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
     copy ;
 
 : pop ( seq -- elt )
-    [ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ;
+    [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
 
 : all-equal? ( seq -- ? ) [ = ] monotonic? ;
 

core/slots/slots.factor

@@ -125,6 +125,10 @@ ERROR: bad-slot-value value class ;
 
 ERROR: no-initial-value class ;
 
+GENERIC: initial-value* ( class -- object )
+
+M: class initial-value* no-initial-value ;
+
 : initial-value ( class -- object )
     {
         { [ \ f bootstrap-word over class<= ] [ f ] }
@@ -134,7 +138,7 @@ ERROR: no-initial-value class ;
         { [ array bootstrap-word over class<= ] [ { } ] }
         { [ byte-array bootstrap-word over class<= ] [ B{ } ] }
         { [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
-        [ no-initial-value ]
+        [ dup initial-value* ]
     } cond nip ;
 
 GENERIC: make-slot ( desc -- slot-spec )

extra/benchmark/stack/stack.factor

@@ -0,0 +1,19 @@
+USING: kernel sequences math math.functions vectors ;
+IN: benchmark.stack
+
+: stack-loop ( vec -- )
+    1000 [
+        10000 [
+            dup pop dup ! dup 10 > [ sqrt dup 1 + ] [ dup 2 * ] if
+            pick push
+            over push
+        ] times
+        10000 [ dup pop* ] times
+    ] times
+    drop ;
+
+: stack-benchmark ( -- )
+    V{ 123456 } clone stack-loop
+    20000 <vector> 123456 over set-first stack-loop ;
+
+MAIN: stack-benchmark

extra/float-arrays/float-arrays.factor

@@ -72,3 +72,20 @@ INSTANCE: float-array sequence
 M: float-array pprint-delims drop \ F{ \ } ;
 
 M: float-array >pprint-sequence ;
+
+USING: hints math.vectors arrays ;
+
+HINTS: vneg { float-array } { array } ;
+HINTS: v*n { float-array object } { array object } ;
+HINTS: v/n { float-array object } { array object } ;
+HINTS: n/v { object float-array } { object array } ;
+HINTS: v+ { float-array float-array } { array array } ;
+HINTS: v- { float-array float-array } { array array } ;
+HINTS: v* { float-array float-array } { array array } ;
+HINTS: v/ { float-array float-array } { array array } ;
+HINTS: vmax { float-array float-array } { array array } ;
+HINTS: vmin { float-array float-array } { array array } ;
+HINTS: v. { float-array float-array } { array array } ;
+HINTS: norm-sq { float-array } { array } ;
+HINTS: norm { float-array } { array } ;
+HINTS: normalize { float-array } { array } ;

extra/hints/hints.factor

@@ -1,6 +1,10 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser words definitions kernel ;
 IN: hints
-USING: parser words ;
 
-: HINTS: 
+: HINTS:
-    scan-word parse-definition "specializer" set-word-prop ;
+    scan-word
+    [ +inlined+ changed-definition ]
+    [ parse-definition "specializer" set-word-prop ] bi ;
     parsing

extra/io/buffers/buffers.factor

@@ -25,7 +25,7 @@ M: buffer dispose* ptr>> free ;
     [ size>> ] [ fill>> ] bi - ; inline
 
 : buffer-empty? ( buffer -- ? )
-    fill>> zero? ;
+    fill>> zero? ; inline
 
 : buffer-consume ( n buffer -- )
     [ + ] change-pos

extra/io/ports/ports.factor

@@ -19,7 +19,7 @@ M: port set-timeout (>>timeout) ;
 : <port> ( handle class -- port )
     new swap >>handle ; inline
 
-TUPLE: buffered-port < port buffer ;
+TUPLE: buffered-port < port { buffer buffer } ;
 
 : <buffered-port> ( handle class -- port )
     <port>
@@ -35,7 +35,7 @@ HOOK: (wait-to-read) io-backend ( port -- )
 : wait-to-read ( port -- eof? )
     dup buffer>> buffer-empty? [
         dup (wait-to-read) buffer>> buffer-empty?
-    ] [ drop f ] if ;
+    ] [ drop f ] if ; inline
 
 M: input-port stream-read1
     dup check-disposed
@@ -140,9 +140,7 @@ M: output-port dispose*
     ] with-destructors ;
 
 M: buffered-port dispose*
-    [ call-next-method ]
+    [ call-next-method ] [ buffer>> dispose ] bi ;
-    [ [ [ dispose ] when* f ] change-buffer drop ]
-    bi ;
 
 M: port cancel-operation handle>> cancel-operation ;
 
@@ -152,3 +150,13 @@ M: port dispose*
         [ handle>> shutdown ]
         bi
     ] with-destructors ;
+
+! Fast-path optimization
+USING: hints strings io.encodings.utf8 io.encodings.ascii
+io.encodings.private ;
+
+HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } ;
+
+HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
+
+HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ;

extra/tools/deploy/shaker/shaker.factor

@@ -101,6 +101,7 @@ IN: tools.deploy.shaker
                 "if-intrinsics"
                 "infer"
                 "inferred-effect"
+                "input-classes"
                 "interval"
                 "intrinsics"
                 "loc"