Fixing remaining issues

basis/compiler/generator/generator.factor

@@ -4,7 +4,7 @@ USING: accessors arrays assocs classes combinators
 cpu.architecture effects generic hashtables io kernel
 kernel.private layouts math math.parser namespaces prettyprint
 quotations sequences system threads words vectors sets dequeues
-cursors continuations.private summary alien alien.c-types
+continuations.private summary alien alien.c-types
 alien.structs alien.strings alien.arrays libc compiler.errors
 stack-checker.inlining
 compiler.tree compiler.tree.builder compiler.tree.combinators
@@ -60,7 +60,6 @@ SYMBOL: current-label-start
 GENERIC: generate-node ( node -- next )
 
 : generate-nodes ( nodes -- )
-    <sequence-cursor>
     [ current-node generate-node ] iterate-nodes
     end-basic-block ;
 
@@ -216,20 +215,17 @@ M: #dispatch generate-node
     2array 1array define-if-intrinsics ;
 
 : do-if-intrinsic ( pair -- next )
-    <label> [
+    <label> [ swap do-template skip-next ] keep generate-if ;
-        swap do-template
-        node> next dup >node
-    ] keep generate-if ;
 
 : find-intrinsic ( #call -- pair/f )
     intrinsics find-template ;
 
 : find-if-intrinsic ( #call -- pair/f )
-    node@ next #if? [
+    node@ {
-        if-intrinsics find-template
+        { [ dup length 2 < ] [ 2drop f ] }
-    ] [
+        { [ dup second #if? ] [ drop if-intrinsics find-template ] }
-        drop f
+        [ 2drop f ]
-    ] if ;
+    } cond ;
 
 M: #call generate-node
     dup node-input-infos [ class>> ] map set-operand-classes

basis/compiler/generator/iterator/iterator.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences cursors kernel compiler.tree ;
+USING: namespaces sequences kernel compiler.tree ;
 IN: compiler.generator.iterator
 
 SYMBOL: node-stack
@@ -8,15 +8,15 @@ SYMBOL: node-stack
 : >node ( cursor -- ) node-stack get push ;
 : node> ( -- cursor ) node-stack get pop ;
 : node@ ( -- cursor ) node-stack get peek ;
-: current-node ( -- node ) node@ value ;
+: current-node ( -- node ) node@ first ;
-
+: iterate-next ( -- cursor ) node@ rest-slice ;
-: iterate-next ( -- cursor ) node@ next ;
+: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
 
 : iterate-nodes ( cursor quot: ( -- ) -- )
-    over [
+    over empty? [
-        [ swap >node call node> drop ] keep iterate-nodes
-    ] [
         2drop
+    ] [
+        [ swap >node call node> drop ] keep iterate-nodes
     ] if ; inline recursive
 
 : with-node-iterator ( quot -- )
@@ -25,21 +25,21 @@ SYMBOL: node-stack
 DEFER: (tail-call?)
 
 : tail-phi? ( cursor -- ? )
-    [ value #phi? ] [ next (tail-call?) ] bi and ;
+    [ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
 
 : (tail-call?) ( cursor -- ? )
-    dup [
+    dup empty? [ drop t ] [
-        [ value [ #return? ] [ #terminate? ] bi or ]
+        [ first [ #return? ] [ #terminate? ] bi or ]
         [ tail-phi? ]
         bi or
-    ] [ drop t ] if ;
+    ] if ;
 
 : tail-call? ( -- ? )
     node-stack get [
-        next
+        rest-slice
         dup [
             [ (tail-call?) ]
-            [ value #terminate? not ]
+            [ first #terminate? not ]
             bi and
         ] [ drop t ] if
     ] all? ;

basis/compiler/tests/alien.factor

@@ -1,9 +1,9 @@
 IN: compiler.tests
 USING: alien alien.c-types alien.syntax compiler kernel
-namespaces namespaces tools.test sequences inference words
+namespaces namespaces tools.test sequences stack-checker
-arrays parser quotations continuations inference.backend effects
+stack-checker.errors words arrays parser quotations
-namespaces.private io io.streams.string memory system threads
+continuations effects namespaces.private io io.streams.string
-tools.test math ;
+memory system threads tools.test math ;
 
 FUNCTION: void ffi_test_0 ;
 [ ] [ ffi_test_0 ] unit-test

basis/compiler/tests/optimizer.factor

@@ -0,0 +1,358 @@
+USING: accessors arrays compiler.units generic hashtables
+stack-checker kernel kernel.private math prettyprint sequences
+sbufs strings tools.test vectors words sequences.private
+quotations classes classes.algebra classes.tuple.private
+continuations growable namespaces hints
+compiler.tree.builder compiler.tree.optimizer ;
+IN: optimizer.tests
+
+GENERIC: xyz ( obj -- obj )
+M: array xyz xyz ;
+
+[ t ] [ \ xyz compiled>> ] unit-test
+
+! Test predicate inlining
+: pred-test-1
+    dup fixnum? [
+        dup integer? [ "integer" ] [ "nope" ] if
+    ] [
+        "not a fixnum"
+    ] if ;
+
+[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
+
+TUPLE: pred-test ;
+
+: pred-test-2
+    dup tuple? [
+        dup pred-test? [ "pred-test" ] [ "nope" ] if
+    ] [
+        "not a tuple"
+    ] if ;
+
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
+
+: pred-test-3
+    dup pred-test? [
+        dup tuple? [ "pred-test" ] [ "nope" ] if
+    ] [
+        "not a tuple"
+    ] if ;
+
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
+
+: inline-test
+    "nom" = ;
+
+[ t ] [ "nom" inline-test ] unit-test
+[ f ] [ "shayin" inline-test ] unit-test
+[ f ] [ 3 inline-test ] unit-test
+
+: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
+
+[ ] [ 1000000 fixnum-declarations . ] unit-test
+
+! regression
+
+: literal-not-branch 0 not [ ] [ ] if ;
+
+[ ] [ literal-not-branch ] unit-test
+
+! regression
+
+: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
+: bad-kill-2 bad-kill-1 drop ;
+
+[ 3 ] [ t bad-kill-2 ] unit-test
+
+! regression
+: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
+: the-test ( -- x y ) 2 dup (the-test) ;
+
+[ 2 0 ] [ the-test ] unit-test
+
+! regression
+: (double-recursion) ( start end -- )
+    < [
+        6 1 (double-recursion)
+        3 2 (double-recursion)
+    ] when ; inline
+
+: double-recursion ( -- ) 0 2 (double-recursion) ;
+
+[ ] [ double-recursion ] unit-test
+
+! regression
+: double-label-1 ( a b c -- d )
+    [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
+
+: double-label-2 ( a -- b )
+    dup array? [ ] [ ] if 0 t double-label-1 ;
+
+[ 0 ] [ 10 double-label-2 ] unit-test
+
+! regression
+GENERIC: void-generic ( obj -- * )
+: breakage ( -- * ) "hi" void-generic ;
+[ t ] [ \ breakage compiled>> ] unit-test
+[ breakage ] must-fail
+
+! regression
+: branch-fold-regression-0 ( m -- n )
+    t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
+
+: branch-fold-regression-1 ( -- m )
+    10 branch-fold-regression-0 ;
+
+[ 10 ] [ branch-fold-regression-1 ] unit-test
+
+! another regression
+: constant-branch-fold-0 "hey" ; foldable
+: constant-branch-fold-1 ( -- ? ) constant-branch-fold-0 "hey" = ; inline
+[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
+
+! another regression
+: foo f ;
+: bar ( -- ? ) foo 4 4 = and ;
+[ f ] [ bar ] unit-test
+
+! compiling <tuple> with a non-literal class failed
+: <tuple>-regression ( class -- tuple ) <tuple> ;
+
+[ t ] [ \ <tuple>-regression compiled>> ] unit-test
+
+GENERIC: foozul ( a -- b )
+M: reversed foozul ;
+M: integer foozul ;
+M: slice foozul ;
+
+[ t ] [
+    reversed \ foozul specific-method
+    reversed \ foozul method
+    eq?
+] unit-test
+
+! regression
+: constant-fold-2 f ; foldable
+: constant-fold-3 4 ; foldable
+
+[ f t ] [
+    [ constant-fold-2 constant-fold-3 4 = ] compile-call
+] unit-test
+
+: constant-fold-4 f ; foldable
+: constant-fold-5 f ; foldable
+
+[ f ] [
+    [ constant-fold-4 constant-fold-5 or ] compile-call
+] unit-test
+
+[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
+[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
+[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
+[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
+[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
+[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
+
+[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
+[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
+[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
+[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
+[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
+[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
+[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
+[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
+[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
+[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
+
+[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
+
+[ f ] [ 5 [ dup < ] compile-call ] unit-test
+[ t ] [ 5 [ dup <= ] compile-call ] unit-test
+[ f ] [ 5 [ dup > ] compile-call ] unit-test
+[ t ] [ 5 [ dup >= ] compile-call ] unit-test
+
+[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
+[ t ] [ 5 [ dup = ] compile-call ] unit-test
+[ t ] [ 5 [ dup number= ] compile-call ] unit-test
+[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
+
+GENERIC: detect-number ( obj -- obj )
+M: number detect-number ;
+
+[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
+
+! Regression
+[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
+
+! Regression
+USE: sorting
+USE: binary-search
+USE: binary-search.private
+
+: old-binsearch ( elt quot seq -- elt quot i )
+    dup length 1 <= [
+        slice-from
+    ] [
+        [ midpoint swap call ] 3keep roll dup zero?
+        [ drop dup slice-from swap midpoint@ + ]
+        [ dup midpoint@ cut-slice old-binsearch ] if
+    ] if ; inline
+
+[ 10 ] [
+    10 20 >vector <flat-slice>
+    [ [ - ] swap old-binsearch ] compile-call 2nip
+] unit-test
+
+! Regression
+TUPLE: silly-tuple a b ;
+
+[ 1 2 { silly-tuple-a silly-tuple-b } ] [
+    T{ silly-tuple f 1 2 }
+    [
+        { silly-tuple-a silly-tuple-b } [ get-slots ] keep
+    ] compile-call
+] unit-test
+
+! Regression
+: empty-compound ;
+
+: node-successor-f-bug ( x -- * )
+    [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
+
+[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
+
+[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
+
+[ ] [ [ <tuple> ] build-tree optimize-tree drop ] unit-test
+
+! Regression
+: lift-throw-tail-regression ( obj -- obj str )
+    dup integer? [ "an integer" ] [
+        dup string? [ "a string" ] [
+            "error" throw
+        ] if
+    ] if ;
+
+[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
+[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
+[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
+
+: lift-loop-tail-test-1 ( a quot -- )
+    over even? [
+        [ >r 3 - r> call ] keep lift-loop-tail-test-1
+    ] [
+        over 0 < [
+            2drop
+        ] [
+            [ >r 2 - r> call ] keep lift-loop-tail-test-1
+        ] if
+    ] if ; inline
+
+: lift-loop-tail-test-2
+    10 [ ] lift-loop-tail-test-1 1 2 3 ;
+
+[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
+
+! Forgot a recursive inline check
+: recursive-inline-hang ( a -- a )
+    dup array? [ recursive-inline-hang ] when ;
+
+HINTS: recursive-inline-hang array ;
+
+: recursive-inline-hang-1 ( -- a )
+    { } recursive-inline-hang ;
+
+[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
+
+DEFER: recursive-inline-hang-3
+
+: recursive-inline-hang-2 ( a -- a )
+    dup array? [ recursive-inline-hang-3 ] when ;
+
+HINTS: recursive-inline-hang-2 array ;
+
+: recursive-inline-hang-3 ( a -- a )
+    dup array? [ recursive-inline-hang-2 ] when ;
+
+HINTS: recursive-inline-hang-3 array ;
+
+! Regression
+USE: sequences.private
+
+[ ] [ { (3append) } compile ] unit-test
+
+! Wow
+: counter-example ( a b c d -- a' b' c' d' )
+    dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline
+
+: counter-example' ( -- a' b' c' d' )
+    1 2 3.0 3 counter-example ;
+
+[ 2 4 6.0 0 ] [ counter-example' ] unit-test
+
+: member-test ( obj -- ? ) { + - * / /i } member? ;
+
+\ member-test must-infer
+[ ] [ \ member-test build-tree-from-word optimize-tree 2drop ] unit-test
+[ t ] [ \ + member-test ] unit-test
+[ f ] [ \ append member-test ] unit-test
+
+! Infinite expansion
+TUPLE: cons car cdr ;
+
+UNION: improper-list cons POSTPONE: f ;
+
+PREDICATE: list < improper-list
+    [ cdr>> list instance? ] [ t ] if* ;
+
+[ t ] [
+    T{ cons f 1 T{ cons f 2 T{ cons f 3 f } } }
+    [ list instance? ] compile-call
+] unit-test
+
+! Regression
+: interval-inference-bug ( obj -- obj x )
+    dup "a" get { array-capacity } declare >=
+    [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
+
+\ interval-inference-bug must-infer
+
+[ ] [ 1 "a" set 2 "b" set ] unit-test
+[ 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
+
+TUPLE: some-tuple x ;
+
+: allot-regression ( a -- b )
+    [ ] curry some-tuple boa ;
+
+[ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test

basis/compiler/tests/redefine1.factor

@@ -1,7 +1,7 @@
-IN: compiler.tests
 USING: accessors compiler compiler.units tools.test math parser
 kernel sequences sequences.private classes.mixin generic
 definitions arrays words assocs eval ;
+IN: compiler.tests
 
 GENERIC: method-redefine-test ( a -- b )
 
@@ -31,15 +31,6 @@ M: integer method-redefine-test 3 + ;
 [ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
 [ t ] [ \ there compiled>> ] unit-test
 
-! Just changing the stack effect didn't mark a word for recompilation
-DEFER: change-effect
-
-[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- b )" eval ] unit-test
-{ 1 1 } [ change-effect ] must-infer-as
-
-[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- )" eval ] unit-test
-{ 1 0 } [ change-effect ] must-infer-as
-
 : good ( -- ) ;
 : bad ( -- ) good ;
 : ugly ( -- ) bad ;

basis/compiler/tests/simple.factor

@@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
 10 [
     [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
     [ t ] [
-        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) (  -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
+        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
     ] unit-test
 ] times

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

@@ -2,26 +2,6 @@ USING: help.markup help.syntax sequences quotations words
 compiler.tree stack-checker.errors ;
 IN: compiler.tree.builder
 
-ARTICLE: "specializers" "Word specializers"
-"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
-$nl
-"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint."
-$nl
-"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
-$nl
-"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
-$nl
-"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
-$nl
-"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
-{ $code
-"\\ append"
-"{ { string string } { array array } }"
-"\"specializer\" set-word-prop"
-}
-"The specialized version of a word which will be compiled by the compiler can be inspected:"
-{ $subsection specialized-def } ;
-
 HELP: build-tree
 { $values { "quot" quotation } { "nodes" "a sequence of nodes" } }
 { $description "Attempts to construct tree SSA IR from a quotation." }
@@ -30,9 +10,5 @@ HELP: build-tree
 
 HELP: build-tree-with
 { $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } }
-{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values, and outputting stack resulting at the end." }
+{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values, and outputting stack resulting at the end." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
-
-HELP: specialized-def
-{ $values { "word" word } { "quot" quotation } }
-{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;

basis/compiler/tree/builder/builder.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors quotations kernel sequences namespaces assocs
+USING: fry accessors quotations kernel sequences namespaces
-words generic generic.standard generic.standard.engines arrays
+assocs words arrays vectors hints combinators stack-checker
-kernel.private combinators vectors stack-checker
 stack-checker.state stack-checker.visitor stack-checker.errors
 stack-checker.backend compiler.tree ;
 IN: compiler.tree.builder
@@ -29,49 +28,6 @@ IN: compiler.tree.builder
     [ rot #copy suffix ]
     if ;
 
-: (make-specializer) ( class picker -- quot )
-    swap "predicate" word-prop append ;
-
-: make-specializer ( classes -- quot )
-    dup length <reversed>
-    [ (picker) 2array ] 2map
-    [ drop object eq? not ] assoc-filter
-    dup empty? [ drop [ t ] ] [
-        [ (make-specializer) ] { } assoc>map
-        unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
-    ] if ;
-
-: specializer-cases ( quot word -- default alist )
-    dup [ array? ] all? [ 1array ] unless [
-        [ make-specializer ] keep
-        '[ , declare ] pick append
-    ] { } map>assoc ;
-
-: method-declaration ( method -- quot )
-    dup "method-generic" word-prop dispatch# object <array>
-    swap "method-class" word-prop prefix ;
-
-: specialize-method ( quot method -- quot' )
-    method-declaration '[ , declare ] prepend ;
-
-: specialize-quot ( quot specializer -- quot' )
-    specializer-cases alist>quot ;
-
-: standard-method? ( method -- ? )
-    dup method-body? [
-        "method-generic" word-prop standard-generic?
-    ] [ drop f ] if ;
-
-: specialized-def ( word -- quot )
-    dup def>> swap {
-        { [ dup standard-method? ] [ specialize-method ] }
-        {
-            [ dup "specializer" word-prop ]
-            [ "specializer" word-prop specialize-quot ]
-        }
-        [ drop ]
-    } cond ;
-
 : (build-tree-from-word) ( word -- )
     dup
     [ "inline" word-prop ]
@@ -99,6 +55,3 @@ IN: compiler.tree.builder
             } cleave
         ] maybe-cannot-infer
     ] with-tree-builder ;
-
-: specialized-length ( specializer -- n )
-    dup [ array? ] all? [ first ] when length ;

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

@@ -433,7 +433,7 @@ cell-bits 32 = [
     ] { >= fixnum>= } inlined?
 ] unit-test
 
-[ ] [
+[ t ] [
     [
         4 pick array-capacity?
         [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
@@ -451,3 +451,8 @@ cell-bits 32 = [
         if
     ] cleaned-up-tree drop
 ] unit-test
+
+[ t ] [
+    [ [ 2array ] [ 0 3array ] if first ]
+    { nth-unsafe < <= > >= } inlined?
+] unit-test

basis/compiler/tree/cleanup/cleanup.factor

@@ -3,7 +3,7 @@
 USING: kernel accessors sequences sequences.deep combinators fry
 classes.algebra namespaces assocs math math.private
 math.partial-dispatch classes.tuple classes.tuple.private
-stack-checker.branches
+definitions stack-checker.state stack-checker.branches
 compiler.tree
 compiler.tree.intrinsics
 compiler.tree.combinators
@@ -42,14 +42,18 @@ GENERIC: cleanup* ( node -- node/nodes )
 : cleanup-folding ( #call -- nodes )
     #! Replace a #call having a known result with a #drop of its
     #! inputs followed by #push nodes for the outputs.
+    [ word>> +inlined+ depends-on ]
     [
         [ node-output-infos ] [ out-d>> ] bi
         [ [ literal>> ] dip #push ] 2map
     ]
-    [ in-d>> #drop ] bi prefix ;
+    [ in-d>> #drop ]
+    tri prefix ;
 
 : cleanup-inlining ( #call -- nodes )
-    body>> cleanup ;
+    [ dup method>> [ drop ] [ word>> +inlined+ depends-on ] if ]
+    [ body>> cleanup ]
+    bi ;
 
 ! Removing overflow checks
 : no-overflow-variant ( op -- fast-op )

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

@@ -5,7 +5,8 @@ compiler.tree.cleanup compiler.tree.escape-analysis
 compiler.tree.tuple-unboxing compiler.tree.debugger
 compiler.tree.normalization compiler.tree.checker tools.test
 kernel math stack-checker.state accessors combinators io
-prettyprint words sequences.deep sequences.private ;
+prettyprint words sequences.deep sequences.private arrays
+classes kernel.private ;
 IN: compiler.tree.dead-code.tests
 
 \ remove-dead-code must-infer
@@ -173,3 +174,11 @@ IN: compiler.tree.dead-code.tests
 [ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test
 
 [ ] [ [ [ ] rot [ . ] curry pick [ roll 2drop call ] [ 2nip call ] if ] optimize-quot drop ] unit-test
+
+[ [ drop ] ] [ [ array? drop ] optimize-quot ] unit-test
+
+[ [ drop ] ] [ [ array instance? drop ] optimize-quot ] unit-test
+
+[ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
+
+[ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test

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

@@ -1,13 +1,25 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors words assocs sequences arrays namespaces
-fry locals compiler.tree stack-checker.backend
+fry locals classes.algebra stack-checker.backend
+compiler.tree
+compiler.tree.propagation.info
 compiler.tree.dead-code.liveness ;
 IN: compiler.tree.dead-code.simple
 
+: flushable? ( word -- ? )
+    [ "flushable" word-prop ] [ "predicating" word-prop ] bi or ;
+
+: flushable-call? ( #call -- ? )
+    dup word>> dup flushable? [
+        "input-classes" word-prop dup [
+            [ node-input-infos ] dip
+            [ [ class>> ] dip class<= ] 2all?
+        ] [ 2drop t ] if
+    ] [ 2drop f ] if ;
+
 M: #call mark-live-values*
-    dup word>> "flushable" word-prop
+    dup flushable-call? [ drop ] [ look-at-inputs ] if ;
-    [ drop ] [ look-at-inputs ] if ;
 
 M: #alien-invoke mark-live-values* look-at-inputs ;
 
@@ -80,8 +92,9 @@ M: #push remove-dead-code*
     dup out-d>> first live-value? [ drop f ] unless ;
 
 : dead-flushable-call? ( #call -- ? )
-    [ word>> "flushable" word-prop ]
+    dup flushable-call? [
-    [ out-d>> [ live-value? not ] all? ] bi and ;
+        out-d>> [ live-value? not ] all?
+    ] [ drop f ] if ;
 
 : remove-flushable-call ( #call -- node )
     in-d>> #drop remove-dead-code* ;

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

@@ -143,10 +143,6 @@ IN: compiler.tree.propagation.tests
     [ dup string? not not >boolean [ ] [ "Oops" throw ] if ] final-classes
 ] unit-test
 
-[ V{ string } ] [
-    [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
-] unit-test
-
 [ f ] [ [ t xor ] final-classes first null-class? ] unit-test
 
 [ t ] [ [ t or ] final-classes first true-class? ] unit-test
@@ -159,20 +155,12 @@ IN: compiler.tree.propagation.tests
 
 [ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
 
-[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
-
 [ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
 
-[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
-
 [ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
 
-[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
-
 [ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
 
-[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
-
 [ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
 
 [ V{ fixnum } ] [
@@ -571,3 +559,15 @@ M: integer infinite-loop infinite-loop ;
 : fold-throw-test ( a -- b ) "A" throw ; foldable
 
 [ ] [ [ 0 fold-throw-test ] final-info drop ] unit-test
+
+! [ V{ string } ] [
+!     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
+! ] unit-test
+
+! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
+
+! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
+
+! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
+
+! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test

basis/compiler/tree/strength-reduction/strength-reduction-tests.factor

@@ -1,119 +1,119 @@
-TUPLE: declared-fixnum { x fixnum } ;
+! TUPLE: declared-fixnum { x fixnum } ;
-
+! 
-[ t ] [
+! [ t ] [
-    [ { declared-fixnum } declare [ 1 + ] change-x ]
+!     [ { declared-fixnum } declare [ 1 + ] change-x ]
-    { + fixnum+ >fixnum } inlined?
+!     { + fixnum+ >fixnum } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [ { declared-fixnum } declare x>> drop ]
+!     [ { declared-fixnum } declare x>> drop ]
-    { slot } inlined?
+!     { slot } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [ hashtable new ] \ new inlined?
+!     [ hashtable new ] \ new inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [ dup hashtable eq? [ new ] when ] \ new inlined?
+!     [ dup hashtable eq? [ new ] when ] \ new inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ f ] [
+! [ f ] [
-    [ { integer } declare -63 shift 4095 bitand ]
+!     [ { integer } declare -63 shift 4095 bitand ]
-    \ shift inlined?
+!     \ shift inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [ { integer } declare 127 bitand 3 + ]
+!     [ { integer } declare 127 bitand 3 + ]
-    { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
+!     { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ f ] [
+! [ f ] [
-    [ { integer } declare 127 bitand 3 + ]
+!     [ { integer } declare 127 bitand 3 + ]
-    { >fixnum } inlined?
+!     { >fixnum } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [
+!     [
-        { integer } declare
+!         { integer } declare
-        dup 0 >= [
+!         dup 0 >= [
-            615949 * 797807 + 20 2^ mod dup 19 2^ -
+!             615949 * 797807 + 20 2^ mod dup 19 2^ -
-        ] [ dup ] if
+!         ] [ dup ] if
-    ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+!     ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [
+!     [
-        { fixnum } declare
+!         { fixnum } declare
-        615949 * 797807 + 20 2^ mod dup 19 2^ -
+!         615949 * 797807 + 20 2^ mod dup 19 2^ -
-    ] { >fixnum } inlined?
+!     ] { >fixnum } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [
+!     [
-        { integer } declare 0 swap
+!         { integer } declare 0 swap
-        [
+!         [
-            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+!             drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
-        ] map
+!         ] map
-    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+!     ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [
+!     [
-        { fixnum } declare 0 swap
+!         { fixnum } declare 0 swap
-        [
+!         [
-            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+!             drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
-        ] map
+!         ] map
-    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
+!     ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
+!     [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
+!     [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
+!     [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
-] unit-test
+! ] unit-test
-
+! 
-
+! 
-
+! 
-[ t ] [
+! [ t ] [
-    [
+!     [
-        { integer } declare [ 256 mod ] map
+!         { integer } declare [ 256 mod ] map
-    ] { mod fixnum-mod } inlined?
+!     ] { mod fixnum-mod } inlined?
-] unit-test
+! ] unit-test
-
+! 
-
+! 
-[ f ] [
+! [ f ] [
-    [
+!     [
-        256 mod
+!         256 mod
-    ] { mod fixnum-mod } inlined?
+!     ] { mod fixnum-mod } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ f ] [
+! [ f ] [
-    [
+!     [
-        dup 0 >= [ 256 mod ] when
+!         dup 0 >= [ 256 mod ] when
-    ] { mod fixnum-mod } inlined?
+!     ] { mod fixnum-mod } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [
+!     [
-        { integer } declare dup 0 >= [ 256 mod ] when
+!         { integer } declare dup 0 >= [ 256 mod ] when
-    ] { mod fixnum-mod } inlined?
+!     ] { mod fixnum-mod } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [
+!     [
-        { integer } declare 256 rem
+!         { integer } declare 256 rem
-    ] { mod fixnum-mod } inlined?
+!     ] { mod fixnum-mod } inlined?
-] unit-test
+! ] unit-test
-
+! 
-[ t ] [
+! [ t ] [
-    [
+!     [
-        { integer } declare [ 256 rem ] map
+!         { integer } declare [ 256 rem ] map
-    ] { mod fixnum-mod rem } inlined?
+!     ] { mod fixnum-mod rem } inlined?
-] unit-test
+! ] unit-test

basis/concurrency/mailboxes/mailboxes.factor

@@ -4,7 +4,7 @@ IN: concurrency.mailboxes
 USING: dlists dequeues threads sequences continuations
 destructors namespaces random math quotations words kernel
 arrays assocs init system concurrency.conditions accessors
-debugger debugger.threads ;
+debugger debugger.threads locals ;
 
 TUPLE: mailbox threads data disposed ;
 
@@ -23,13 +23,12 @@ M: mailbox dispose* threads>> notify-all ;
 : wait-for-mailbox ( mailbox timeout -- )
     >r threads>> r> "mailbox" wait ;
 
-: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
+:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
-    pick check-disposed
+    mailbox check-disposed
-    pick data>> over dlist-contains? [
+    mailbox data>> pred dlist-contains? [
-        3drop
+        mailbox timeout wait-for-mailbox
-    ] [
+        mailbox timeout pred block-unless-pred
-        >r 2dup wait-for-mailbox r> block-unless-pred
+    ] unless ; inline recursive
-    ] if ; inline recursive
 
 : block-if-empty ( mailbox timeout -- mailbox )
     over check-disposed

basis/float-arrays/float-arrays.factor

@@ -47,16 +47,16 @@ M: float-array byte-length length "double" heap-size * ;
 INSTANCE: float-array sequence
 
 : 1float-array ( x -- array )
-    1 <float-array> [ set-first ] keep ; flushable
+    1 <float-array> [ set-first ] keep ; inline
 
 : 2float-array ( x y -- array )
-    T{ float-array } 2sequence ; flushable
+    T{ float-array } 2sequence ; inline
 
 : 3float-array ( x y z -- array )
-    T{ float-array } 3sequence ; flushable
+    T{ float-array } 3sequence ; inline
 
 : 4float-array ( w x y z -- array )
-    T{ float-array } 4sequence ; flushable
+    T{ float-array } 4sequence ; inline
 
 : F{ ( parsed -- parsed )
     \ } [ >float-array ] parse-literal ; parsing

basis/help/lint/lint.factor

@@ -109,9 +109,9 @@ M: help-error error.
     vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
     H{ } clone [
         [
-            >r >r dup >link where dup
+            [ dup >link where dup ] 2dip
-            [ first r> at r> push-at ]
+            [ first r> at r> push-at ] 2curry
-            [ r> r> 2drop 2drop ]
+            [ 2drop ]
             if
         ] 2curry each
     ] keep ;

basis/hints/hints-docs.factor

@@ -0,0 +1,29 @@
+IN: hints
+USING: help.markup help.syntax words ;
+
+ARTICLE: "hints" "Compiler specialization hints"
+"Specialization hints help the compiler generate efficient code."
+$nl
+"Specialization hints can help words which call a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
+$nl
+"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
+$nl
+"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
+$nl
+"Type hints are declared with a parsing word:"
+{ $subsection POSTPONE: HINT: }
+$nl
+"The specialized version of a word which will be compiled by the compiler can be inspected:"
+{ $subsection specialized-def } ;
+
+HELP: specialized-def
+{ $values { "word" word } { "quot" quotation } }
+{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
+
+HELP: HINTS:
+{ $values { "word" word } { "hints..." "a list of sequences of classes" } }
+{ $description "Defines specialization hints for each words. Each sequence of classes in the list will cause a specialized version of the word to be compiled." }
+{ $examples "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
+{ $code "HINTS: append { string string } { array array } ;" } } ;
+
+ABOUT: "hints"

basis/hints/hints.factor

@@ -1,10 +1,110 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser words definitions kernel ;
+USING: parser words definitions kernel sequences assocs arrays
+kernel.private fry combinators accessors vectors strings sbufs
+byte-arrays byte-vectors io.binary io.streams.string splitting
+math generic generic.standard generic.standard.engines ;
 IN: hints
 
+: (make-specializer) ( class picker -- quot )
+    swap "predicate" word-prop append ;
+
+: make-specializer ( classes -- quot )
+    dup length <reversed>
+    [ (picker) 2array ] 2map
+    [ drop object eq? not ] assoc-filter
+    dup empty? [ drop [ t ] ] [
+        [ (make-specializer) ] { } assoc>map
+        unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+    ] if ;
+
+: specializer-cases ( quot word -- default alist )
+    dup [ array? ] all? [ 1array ] unless [
+        [ make-specializer ] keep
+        '[ , declare ] pick append
+    ] { } map>assoc ;
+
+: method-declaration ( method -- quot )
+    [ "method-generic" word-prop dispatch# object <array> ]
+    [ "method-class" word-prop ]
+    bi prefix ;
+
+: specialize-method ( quot method -- quot' )
+    method-declaration '[ , declare ] prepend ;
+
+: specialize-quot ( quot specializer -- quot' )
+    specializer-cases alist>quot ;
+
+: standard-method? ( method -- ? )
+    dup method-body? [
+        "method-generic" word-prop standard-generic?
+    ] [ drop f ] if ;
+
+: specialized-def ( word -- quot )
+    dup def>> swap {
+        { [ dup standard-method? ] [ specialize-method ] }
+        {
+            [ dup "specializer" word-prop ]
+            [ "specializer" word-prop specialize-quot ]
+        }
+        [ drop ]
+    } cond ;
+
+: specialized-length ( specializer -- n )
+    dup [ array? ] all? [ first ] when length ;
+
 : HINTS:
     scan-word
     [ +inlined+ changed-definition ]
     [ parse-definition "specializer" set-word-prop ] bi ;
     parsing
+
+! Default specializers
+{ first first2 first3 first4 }
+[ { array } "specializer" set-word-prop ] each
+
+{ peek pop* pop push } [
+    { vector } "specializer" set-word-prop
+] each
+
+\ push-all
+{ { string sbuf } { array vector } { byte-array byte-vector } }
+"specializer" set-word-prop
+
+\ append
+{ { string string } { array array } }
+"specializer" set-word-prop
+
+\ subseq
+{ { fixnum fixnum string } { fixnum fixnum array } }
+"specializer" set-word-prop
+
+\ reverse-here
+{ { string } { array } }
+"specializer" set-word-prop
+
+\ mismatch
+{ string string }
+"specializer" set-word-prop
+
+\ find-last-sep { string sbuf } "specializer" set-word-prop
+
+\ >string { sbuf } "specializer" set-word-prop
+
+\ >array { { string } { vector } } "specializer" set-word-prop
+
+\ >vector { { array } { vector } } "specializer" set-word-prop
+
+\ >sbuf { string } "specializer" set-word-prop
+
+\ split, { string string } "specializer" set-word-prop
+
+\ memq? { array } "specializer" set-word-prop
+
+\ member? { fixnum string } "specializer" set-word-prop
+
+\ assoc-stack { vector } "specializer" set-word-prop
+
+\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
+
+\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop

basis/math/ranges/ranges.factor

@@ -10,7 +10,7 @@ TUPLE: range
 : <range> ( a b step -- range )
     >r over - r>
     [ / 1+ 0 max >integer ] keep
-    range boa ;
+    range boa ; inline
 
 M: range length ( seq -- n )
     length>> ;
@@ -26,19 +26,19 @@ INSTANCE: range immutable-sequence
 
 : ,b) dup neg rot + swap ; inline
 
-: [a,b] ( a b -- range ) twiddle <range> ; foldable
+: [a,b] ( a b -- range ) twiddle <range> ; inline
 
-: (a,b] ( a b -- range ) twiddle (a, <range> ; foldable
+: (a,b] ( a b -- range ) twiddle (a, <range> ; inline
 
-: [a,b) ( a b -- range ) twiddle ,b) <range> ; foldable
+: [a,b) ( a b -- range ) twiddle ,b) <range> ; inline
 
-: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ; foldable
+: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ; inline
 
-: [0,b] ( b -- range ) 0 swap [a,b] ; foldable
+: [0,b] ( b -- range ) 0 swap [a,b] ; inline
 
-: [1,b] ( b -- range ) 1 swap [a,b] ; foldable
+: [1,b] ( b -- range ) 1 swap [a,b] ; inline
 
-: [0,b) ( b -- range ) 0 swap [a,b) ; foldable
+: [0,b) ( b -- range ) 0 swap [a,b) ; inline
 
 : range-increasing? ( range -- ? )
     step>> 0 > ;

basis/ui/freetype/freetype.factor

@@ -212,7 +212,7 @@ M: freetype-renderer draw-string ( font string loc -- )
     char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
 
 M: freetype-renderer x>offset ( x open-font string -- n )
-    dup >r run-char-widths [ <= ] with find drop
+    [ run-char-widths [ <= ] with find drop ] keep swap
-    [ r> drop ] [ r> length ] if* ;
+    [ ] [ length ] ?if ;
 
 T{ freetype-renderer } font-renderer set-global

core/arrays/arrays.factor

@@ -23,12 +23,12 @@ M: array equal?
 
 INSTANCE: array sequence
 
-: 1array ( x -- array ) 1 swap <array> ; flushable
+: 1array ( x -- array ) 1 swap <array> ; inline
 
-: 2array ( x y -- array ) { } 2sequence ; flushable
+: 2array ( x y -- array ) { } 2sequence ; inline
 
-: 3array ( x y z -- array ) { } 3sequence ; flushable
+: 3array ( x y z -- array ) { } 3sequence ; inline
 
-: 4array ( w x y z -- array ) { } 4sequence ; flushable
+: 4array ( w x y z -- array ) { } 4sequence ; inline
 
 PREDICATE: pair < array length 2 number= ;

core/classes/classes.factor

@@ -182,4 +182,4 @@ M: class forget* ( class -- )
 
 GENERIC: class ( object -- class )
 
-GENERIC: instance? ( object class -- ? )
+GENERIC: instance? ( object class -- ? ) flushable

core/classes/tuple/tuple.factor

@@ -298,11 +298,9 @@ M: tuple-class (classes-intersect?)
         [ swap classes-intersect? ]
     } cond ;
 
-M: tuple clone
+M: tuple clone (clone) ;
-    (clone) dup delegate clone over set-delegate ;
 
-M: tuple equal?
+M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
-    over tuple? [ tuple= ] [ 2drop f ] if ;
 
 M: tuple hashcode*
     [

core/cursors/cursors.factor

@@ -1,34 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math accessors ;
-IN: cursors
-
-GENERIC: key ( cursor -- key )
-GENERIC: value ( cursor -- value )
-GENERIC: next ( cursor -- cursor/f )
-
-TUPLE: sequence-cursor { i read-only } { seq read-only } ;
-
-: (sequence-cursor) ( i seq -- cursor/f )
-    2dup bounds-check? [ sequence-cursor boa ] [ 2drop f ] if ;
-    inline
-
-: <sequence-cursor> ( seq -- cursor/f )
-    0 swap (sequence-cursor) ; inline
-
-: >sequence-cursor< ( cursor -- i seq ) [ i>> ] [ seq>> ] bi ;
-
-M: sequence-cursor key
-    i>> ;
-
-M: sequence-cursor value
-    >sequence-cursor< nth ;
-
-M: sequence-cursor next
-    >sequence-cursor< [ 1+ ] dip (sequence-cursor) ;
-
-: cursor-iterate ( cursor quot: ( cursor -- cursor' ) -- )
-    over [ call cursor-iterate ] [ 2drop ] if ; inline recursive
-
-: cursor-each ( cursor quot -- )
-    [ keep ] curry cursor-iterate ; inline

core/generic/standard/standard.factor

@@ -21,27 +21,11 @@ M: generic method-declaration
 M: quotation engine>quot
     assumed get generic get method-declaration prepend ;
 
-: unpickers
-    {
-        [ nip ]
-        [ >r nip r> swap ]
-        [ >r >r nip r> r> -rot ]
-    } ; inline
-
-: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
-
 ERROR: no-method object generic ;
 
 : error-method ( word -- quot )
     picker swap [ no-method ] curry append ;
 
-: empty-method ( word -- quot )
-    [
-        picker % [ delegate dup ] %
-        unpicker over suffix ,
-        error-method \ drop prefix , \ if ,
-    ] [ ] make ;
-
 : default-method ( word -- pair )
     "default-method" word-prop
     object bootstrap-word swap 2array ;
@@ -137,7 +121,7 @@ PREDICATE: simple-generic < standard-generic
 M: standard-generic extra-values drop 0 ;
 
 M: standard-combination make-default-method
-    [ empty-method ] with-standard ;
+    [ error-method ] with-standard ;
 
 M: standard-combination perform-combination
     [ drop ] [ [ single-combination ] with-standard ] 2bi define ;