Merge branch 'master' of git://github.com/slavapestov/factor

basis/combinators/smart/smart-tests.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test combinators.smart math kernel accessors ;
+USING: accessors arrays combinators.smart kernel math
+tools.test ;
 IN: combinators.smart.tests
 
 : test-bi ( -- 9 11 )
@@ -59,3 +60,6 @@ IN: combinators.smart.tests
 
 [ 7 ] [ 10 3 smart-if-test ] unit-test
 [ 16 ] [ 25 41 smart-if-test ] unit-test
+
+[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 3 smart-apply ] unit-test
+[ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 2 smart-apply ] unit-test

basis/combinators/smart/smart.factor

@@ -51,3 +51,6 @@ MACRO: nullary ( quot -- quot' )
 
 MACRO: smart-if ( pred true false -- )
     '[ _ preserving _ _ if ] ;
+
+MACRO: smart-apply ( quot n -- )
+    [ dup inputs ] dip '[ _ _ mnapply ] ;

basis/compiler/compiler.factor

@@ -3,18 +3,16 @@
 USING: accessors kernel namespaces arrays sequences io words fry
 continuations vocabs assocs dlists definitions math graphs generic
 generic.single combinators deques search-deques macros
-source-files.errors combinators.short-circuit
+source-files.errors combinators.short-circuit classes.algebra
 
 stack-checker stack-checker.dependencies stack-checker.inlining
 stack-checker.errors
 
-compiler.errors compiler.units compiler.utilities
+compiler.errors compiler.units compiler.utilities compiler.crossref
 
 compiler.tree.builder
 compiler.tree.optimizer
 
-compiler.crossref
-
 compiler.cfg
 compiler.cfg.builder
 compiler.cfg.optimizer
@@ -40,19 +38,18 @@ SYMBOL: compiled
 : recompile-callers? ( word -- ? )
     changed-effects get key? ;
 
-: recompile-callers ( words -- )
+: recompile-callers ( word -- )
-    #! If a word's stack effect changed, recompile all words that
+    #! If a word's stack effect changed, recompile all words
-    #! have compiled calls to it.
+    #! that have compiled calls to it.
     dup recompile-callers?
-    [ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
+    [ effect-dependencies-of keys [ queue-compile ] each ] [ drop ] if ;
 
 : compiler-message ( string -- )
     "trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ;
 
 : start ( word -- )
     dup name>> compiler-message
-    H{ } clone dependencies set
+    init-dependencies
-    H{ } clone generic-dependencies set
     clear-compiler-error ;
 
 GENERIC: no-compile? ( word -- ? )
@@ -88,9 +85,9 @@ M: word combinator? inline? ;
     [ compiled-unxref ]
     [
         dup crossref? [
-            dependencies get
+            [ dependencies get generic-dependencies get compiled-xref ]
-            generic-dependencies get
+            [ conditional-dependencies get save-conditional-dependencies ]
-            compiled-xref
+            bi
         ] [ drop ] if
     ] tri ;
 
@@ -183,6 +180,14 @@ t compile-dependencies? set-global
 
 SINGLETON: optimizing-compiler
 
+M: optimizing-compiler update-call-sites ( class generic -- words )
+    #! Words containing call sites with inferred type 'class'
+    #! which inlined a method on 'generic'
+    compiled-generic-usage swap '[
+        nip dup forgotten-class?
+        [ drop f ] [ _ classes-intersect? ] if
+    ] assoc-filter keys ;
+
 M: optimizing-compiler recompile ( words -- alist )
     [
         <hashed-dlist> compile-queue set
@@ -198,7 +203,7 @@ M: optimizing-compiler recompile ( words -- alist )
 
 M: optimizing-compiler to-recompile ( -- words )
     changed-definitions get compiled-usages
-    changed-generics get compiled-generic-usages
+    maybe-changed get outdated-conditional-usages
     append assoc-combine keys ;
 
 M: optimizing-compiler process-forgotten-words

basis/compiler/crossref/crossref.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes.algebra compiler.units definitions graphs
+USING: arrays assocs classes.algebra compiler.units definitions
-grouping kernel namespaces sequences words
+graphs grouping kernel namespaces sequences words fry
-stack-checker.dependencies ;
+stack-checker.dependencies combinators ;
 IN: compiler.crossref
 
 SYMBOL: compiled-crossref
@@ -13,56 +13,99 @@ SYMBOL: compiled-generic-crossref
 
 compiled-generic-crossref [ H{ } clone ] initialize
 
-: compiled-usage ( word -- assoc )
+: effect-dependencies-of ( word -- assoc )
     compiled-crossref get at ;
 
-: (compiled-usages) ( word -- assoc )
+: definition-dependencies-of ( word -- assoc )
-    #! If the word is not flushable anymore, we have to recompile
+    effect-dependencies-of [ nip definition-dependency dependency>= ] assoc-filter ;
-    #! all words which flushable away a call (presumably when the
-    #! word was still flushable). If the word is flushable, we
-    #! don't have to recompile words that folded this away.
-    [ compiled-usage ]
-    [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
-    [ dependency>= nip ] curry assoc-filter ;
 
-: compiled-usages ( seq -- assocs )
+: conditional-dependencies-of ( word -- assoc )
+    effect-dependencies-of [ nip conditional-dependency dependency>= ] assoc-filter ;
+
+: compiled-usages ( assoc -- assocs )
     [ drop word? ] assoc-filter
-    [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
+    [ [ drop definition-dependencies-of ] { } assoc>map ] keep suffix ;
+
+: dependencies-satisfied? ( word cache -- ? )
+    [ "dependency-checks" word-prop ] dip
+    '[ _ [ satisfied? ] cache ] all? ;
+
+: outdated-conditional-usages ( assoc -- assocs )
+    H{ } clone '[
+        drop
+        conditional-dependencies-of
+        [ drop _ dependencies-satisfied? not ] assoc-filter
+    ] { } assoc>map ;
 
 : compiled-generic-usage ( word -- assoc )
     compiled-generic-crossref get at ;
 
-: (compiled-generic-usages) ( generic class -- assoc )
+: only-xref ( assoc -- assoc' )
-    [ compiled-generic-usage ] dip
+    [ drop crossref? ] { } assoc-filter-as ;
-    [
-        2dup [ valid-class? ] both?
-        [ classes-intersect? ] [ 2drop f ] if nip
-    ] curry assoc-filter ;
 
-: compiled-generic-usages ( assoc -- assocs )
+: set-compiled-generic-uses ( word alist -- )
-    [ (compiled-generic-usages) ] { } assoc>map ;
+    concat f like "compiled-generic-uses" set-word-prop ;
 
-: (compiled-xref) ( word dependencies word-prop variable -- )
+: split-dependencies ( assoc -- effect-deps cond-deps def-deps )
-    [ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
+    [ nip effect-dependency eq? ] assoc-partition
+    [ nip conditional-dependency eq? ] assoc-partition ;
+
+: (store-dependencies) ( word assoc prop -- )
+    [ keys f like ] dip set-word-prop ;
+
+: store-dependencies ( word assoc -- )
+    split-dependencies
+    "effect-dependencies" "definition-dependencies" "conditional-dependencies"
+    [ (store-dependencies) ] tri-curry@ tri-curry* tri ;
+
+: (compiled-xref) ( word dependencies generic-dependencies -- )
+    compiled-crossref compiled-generic-crossref
+    [ get add-vertex* ] bi-curry@ bi-curry* bi ;
 
 : compiled-xref ( word dependencies generic-dependencies -- )
-    [ [ drop crossref? ] { } assoc-filter-as ] bi@
+    [ only-xref ] bi@
-    [ "compiled-uses" compiled-crossref (compiled-xref) ]
+    [ nip set-compiled-generic-uses ]
-    [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
+    [ drop store-dependencies ]
-    bi-curry* bi ;
+    [ (compiled-xref) ]
+    3tri ;
 
-: (compiled-unxref) ( word word-prop variable -- )
+: set-at-each ( keys assoc value -- )
-    [ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
+    '[ _ [ _ ] 2dip set-at ] each ;
-    [ drop [ remove-word-prop ] curry ]
+
-    2bi bi ;
+: join-dependencies ( effect-deps cond-deps def-deps -- assoc )
+    H{ } clone [
+        [ effect-dependency set-at-each ]
+        [ conditional-dependency set-at-each ]
+        [ definition-dependency set-at-each ] tri-curry tri*
+    ] keep ;
+
+: load-dependencies ( word -- assoc )
+    [ "effect-dependencies" word-prop ]
+    [ "definition-dependencies" word-prop ]
+    [ "conditional-dependencies" word-prop ] tri
+    join-dependencies ;
+
+: (compiled-unxref) ( word dependencies variable -- )
+    get remove-vertex* ;
+
+: compiled-generic-uses ( word -- alist )
+    "compiled-generic-uses" word-prop 2 <groups> ;
 
 : compiled-unxref ( word -- )
-    [ "compiled-uses" compiled-crossref (compiled-unxref) ]
+    {
-    [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
+        [ dup load-dependencies compiled-crossref (compiled-unxref) ]
-    bi ;
+        [ dup compiled-generic-uses compiled-generic-crossref (compiled-unxref) ]
+        [ "effect-dependencies" remove-word-prop ]
+        [ "definition-dependencies" remove-word-prop ]
+        [ "conditional-dependencies" remove-word-prop ]
+        [ "compiled-generic-uses" remove-word-prop ]
+    } cleave ;
 
 : delete-compiled-xref ( word -- )
     [ compiled-unxref ]
     [ compiled-crossref get delete-at ]
     [ compiled-generic-crossref get delete-at ]
     tri ;
+
+: save-conditional-dependencies ( word deps -- )
+    keys f like "dependency-checks" set-word-prop ;

basis/compiler/tests/redefine10.factor

@@ -1,26 +1,83 @@
-USING: eval tools.test compiler.units vocabs words kernel ;
+USING: eval tools.test compiler.units vocabs words kernel
+definitions sequences math classes classes.mixin kernel.private ;
 IN: compiler.tests.redefine10
 
-! Mixin redefinition did not recompile all necessary words.
+! Mixin redefinition should update predicate call sites
 
-[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
+MIXIN: my-mixin
+INSTANCE: fixnum my-mixin
+: my-inline-1 ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
+: my-inline-2 ( a -- b ) dup my-mixin? [ 1 + ] when ;
+: my-inline-3 ( a -- b ) dup my-mixin? [ float? ] [ drop f ] if ;
+: my-inline-4 ( a -- b ) dup float? [ my-mixin? ] [ drop f ] if ;
+: my-inline-5 ( a -- b ) dup my-mixin? [ fixnum? ] [ drop f ] if ;
+: my-inline-6 ( a -- b ) dup fixnum? [ my-mixin? ] [ drop f ] if ;
 
-[ ] [
+GENERIC: fake-float? ( obj -- ? )
-    "USING: kernel math classes ;
-    IN: compiler.tests.redefine10
-    MIXIN: my-mixin
-    INSTANCE: fixnum my-mixin
-    : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;"
-    eval( -- )
-] unit-test
 
-[ ] [
+M: float fake-float? drop t ;
-    "USE: math
+M: object fake-float? drop f ;
-    IN: compiler.tests.redefine10
-    INSTANCE: float my-mixin"
-    eval( -- )
-] unit-test
 
-[ 2.0 ] [
+: my-fake-inline-3 ( a -- b ) dup my-mixin? [ fake-float? ] [ drop f ] if ;
-    1.0 "my-inline" "compiler.tests.redefine10" lookup execute
+
-] unit-test
+: my-baked-inline-3 ( a -- b ) { my-mixin } declare fake-float? ;
+
+[ f ] [ 5 my-inline-3 ] unit-test
+
+[ f ] [ 5 my-fake-inline-3 ] unit-test
+
+[ f ] [ 5 my-baked-inline-3 ] unit-test
+
+[ f ] [ 5 my-inline-4 ] unit-test
+
+[ t ] [ 5 my-inline-5 ] unit-test
+
+[ t ] [ 5 my-inline-6 ] unit-test
+
+[ ] [ [ float my-mixin add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ 2.0 ] [ 1.0 my-inline-1 ] unit-test
+
+[ 2.0 ] [ 1.0 my-inline-2 ] unit-test
+
+[ t ] [ 1.0 my-inline-3 ] unit-test
+
+[ t ] [ 1.0 my-fake-inline-3 ] unit-test
+
+[ t ] [ 1.0 my-baked-inline-3 ] unit-test
+
+[ t ] [ 1.0 my-inline-4 ] unit-test
+
+[ f ] [ 1.0 my-inline-5 ] unit-test
+
+[ f ] [ 1.0 my-inline-6 ] unit-test
+
+[ ] [ [ fixnum my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ f ] [ 5 my-inline-3 ] unit-test
+
+[ f ] [ 5 my-fake-inline-3 ] unit-test
+
+[ f ] [ 5 my-baked-inline-3 ] unit-test
+
+[ f ] [ 5 my-inline-4 ] unit-test
+
+[ f ] [ 5 my-inline-5 ] unit-test
+
+[ f ] [ 5 my-inline-6 ] unit-test
+
+[ ] [ [ float my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ 1.0 ] [ 1.0 my-inline-1 ] unit-test
+
+[ 1.0 ] [ 1.0 my-inline-2 ] unit-test
+
+[ f ] [ 1.0 my-inline-3 ] unit-test
+
+[ f ] [ 1.0 my-fake-inline-3 ] unit-test
+
+[ f ] [ 1.0 my-inline-4 ] unit-test
+
+[ f ] [ 1.0 my-inline-5 ] unit-test
+
+[ f ] [ 1.0 my-inline-6 ] unit-test

basis/compiler/tests/redefine18.factor

@@ -0,0 +1,25 @@
+USING: kernel tools.test eval words ;
+IN: compiler.tests.redefine18
+
+! Mixin bug found by Doug
+
+GENERIC: g1 ( a -- b )
+GENERIC: g2 ( a -- b )
+
+MIXIN: c
+SINGLETON: a
+INSTANCE: a c
+
+M: c g1 g2 ;
+M: a g2 drop a ;
+
+MIXIN: d
+INSTANCE: d c
+
+M: d g2 drop d ;
+
+[ ] [ "IN: compiler.tests.redefine18 SINGLETON: b INSTANCE: b d" eval( -- ) ] unit-test
+
+[ d ] [ "b" "compiler.tests.redefine18" lookup g1 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine18 FORGET: b" eval( -- ) ] unit-test

basis/compiler/tests/redefine19.factor

@@ -0,0 +1,23 @@
+USING: kernel classes.mixin compiler.units tools.test generic ;
+IN: compiler.tests.redefine19
+
+GENERIC: g ( a -- b )
+
+MIXIN: m1 M: m1 g drop 1 ;
+MIXIN: m2 M: m2 g drop 2 ;
+
+TUPLE: c ;
+
+INSTANCE: c m2
+
+: foo ( -- b ) c new g ;
+
+[ 2 ] [ foo ] unit-test
+
+[ ] [ [ c m1 add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ { m2 m1 } ] [ \ g order ] unit-test
+
+[ 1 ] [ foo ] unit-test
+
+[ ] [ [ c m1 remove-mixin-instance ] with-compilation-unit ] unit-test

basis/compiler/tests/redefine20.factor

@@ -0,0 +1,23 @@
+IN: compiler.tests.redefine20
+USING: kernel sequences compiler.units definitions classes.mixin
+tools.test ;
+
+GENERIC: cnm-recompile-test ( a -- b )
+
+M: object cnm-recompile-test drop object ;
+
+M: sequence cnm-recompile-test drop sequence ;
+
+TUPLE: funny ;
+
+M: funny cnm-recompile-test call-next-method ;
+
+[ object ] [ funny new cnm-recompile-test ] unit-test
+
+[ ] [ [ funny sequence add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ sequence ] [ funny new cnm-recompile-test ] unit-test
+
+[ ] [ [ funny sequence remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ object ] [ funny new cnm-recompile-test ] unit-test

basis/compiler/tree/builder/builder.factor

@@ -50,11 +50,6 @@ PRIVATE>
     [ f ] dip build-tree-with ;
 
 :: build-sub-tree ( in-d out-d word/quot -- nodes/f )
-    #! We don't want methods on mixins to have a declaration for that mixin.
-    #! This slows down compiler.tree.propagation.inlining since then every
-    #! inlined usage of a method has an inline-dependency on the mixin, and
-    #! not the more specific type at the call site.
-    f specialize-method? [
     [
         in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
         {
@@ -62,5 +57,4 @@ PRIVATE>
             { [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
             [ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
         } cond
-        ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
+    ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
-    ] with-variable ;

basis/compiler/tree/cleanup/cleanup.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences combinators fry
 classes.algebra namespaces assocs words math math.private
@@ -36,32 +36,51 @@ GENERIC: cleanup* ( node -- node/nodes )
     #! do it since the logic is a bit more involved
     [ cleanup* ] map-flat ;
 
+! Constant folding
 : cleanup-folding? ( #call -- ? )
     node-output-infos
     [ f ] [ [ literal?>> ] all? ] if-empty ;
 
-: cleanup-folding ( #call -- 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-dependency depends-on ]
     [
         [ node-output-infos ] [ out-d>> ] bi
         [ [ literal>> ] dip #push ] 2map
     ]
     [ in-d>> #drop ]
-    tri prefix ;
+    bi prefix ;
 
+: record-predicate-folding ( #call -- )
+    [ node-input-infos first class>> ]
+    [ word>> "predicating" word-prop ]
+    [ node-output-infos first literal>> ] tri
+    [ depends-on-class<= ] [ depends-on-classes-disjoint ] if ;
+
+: record-folding ( #call -- )
+    dup word>> predicate?
+    [ record-predicate-folding ]
+    [ word>> depends-on-definition ]
+    if ;
+
+: cleanup-folding ( #call -- nodes )
+    [ (cleanup-folding) ] [ record-folding ] bi ;
+
+! Method inlining
 : add-method-dependency ( #call -- )
     dup method>> word? [
-        [ word>> ] [ class>> ] bi depends-on-generic
+        [ [ class>> ] [ word>> ] bi depends-on-generic ]
+        [ [ class>> ] [ word>> ] [ method>> ] tri depends-on-method ]
+        bi
     ] [ drop ] if ;
 
-: cleanup-inlining ( #call -- nodes )
+: record-inlining ( #call -- )
-    [
     dup method>>
     [ add-method-dependency ]
-        [ word>> inlined-dependency depends-on ] if
+    [ word>> depends-on-definition ] if ;
-    ] [ body>> cleanup ] bi ;
+
+: cleanup-inlining ( #call -- nodes )
+    [ record-inlining ] [ body>> cleanup ] bi ;
 
 ! Removing overflow checks
 : (remove-overflow-check?) ( #call -- ? )

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

@@ -9,14 +9,6 @@ compiler.tree.propagation.info
 compiler.tree.dead-code.liveness ;
 IN: compiler.tree.dead-code.simple
 
-GENERIC: flushable? ( word -- ? )
-
-M: predicate flushable? drop t ;
-
-M: word flushable? "flushable" word-prop ;
-
-M: method-body flushable? "method-generic" word-prop flushable? ;
-
 : flushable-call? ( #call -- ? )
     dup word>> dup flushable? [
         "input-classes" word-prop dup [
@@ -98,7 +90,7 @@ M: #push remove-dead-code*
     ] [ drop f ] if ;
 
 : remove-flushable-call ( #call -- node )
-    [ word>> flushed-dependency depends-on ]
+    [ word>> depends-on-flushable ]
     [ in-d>> #drop remove-dead-code* ]
     bi ;
 

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

@@ -79,3 +79,16 @@ TUPLE: a-tuple x ;
 [ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test
 
 [ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with
+
+! See if redefining a tuple class bumps effect counter
+TUPLE: my-tuple a b c ;
+
+: my-quot ( -- quot ) [ my-tuple boa ] ;
+
+: my-word ( a b c q -- result ) call( a b c -- result ) ;
+
+[ T{ my-tuple f 1 2 3 } ] [ 1 2 3 my-quot my-word ] unit-test
+
+[ ] [ "IN: compiler.tree.propagation.call-effect.tests TUPLE: my-tuple a b ;" eval( -- ) ] unit-test
+
+[ 1 2 3 my-quot my-word ] [ wrong-values? ] must-fail-with

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

@@ -2,14 +2,19 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators combinators.private effects
 fry kernel kernel.private make sequences continuations
-quotations words math stack-checker combinators.short-circuit
+quotations words math stack-checker stack-checker.dependencies
-stack-checker.transforms compiler.tree.propagation.info
+combinators.short-circuit stack-checker.transforms
+compiler.tree.propagation.info
 compiler.tree.propagation.inlining compiler.units ;
 IN: compiler.tree.propagation.call-effect
 
 ! call( and execute( have complex expansions.
 
-! call( uses the following strategy:
+! If the input quotation is a literal, or built up from curry and
+! compose with terminal quotations literal, it is inlined at the
+! call site.
+
+! For dynamic call sites, call( uses the following strategy:
 ! - Inline caching. If the quotation is the same as last time, just call it unsafely
 ! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
 !   and compare it with declaration. If matches, call it unsafely.
@@ -58,7 +63,7 @@ M: compose cached-effect
     [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
 
 : safe-infer ( quot -- effect )
-    [ infer ] [ 2drop +unknown+ ] recover ;
+    [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ;
 
 : cached-effect-valid? ( quot -- ? )
     cache-counter>> effect-counter eq? ; inline

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -318,7 +318,7 @@ generic-comparison-ops [
     dup literal>> class?
     [
         literal>>
-        [ inlined-dependency depends-on ]
+        [ depends-on-conditionally ]
         [ predicate-output-infos ]
         bi
     ] [ 2drop object-info ] if

basis/compiler/tree/propagation/simple/simple.factor

@@ -36,7 +36,7 @@ M: #declare propagate-before
     #! classes mentioned in the declaration are redefined, since
     #! now we're making assumptions but their definitions.
     declaration>> [
-        [ inlined-dependency depends-on ]
+        [ depends-on-conditionally ]
         [ <class-info> swap refine-value-info ]
         bi
     ] assoc-each ;
@@ -110,8 +110,9 @@ M: #declare propagate-before
     #! is redefined, since now we're making assumptions but the
     #! class definition itself.
     [ in-d>> first value-info ]
-    [ "predicating" word-prop dup inlined-dependency depends-on ] bi*
+    [ "predicating" word-prop ] bi*
-    predicate-output-infos 1array ;
+    [ nip depends-on-conditionally ]
+    [ predicate-output-infos 1array ] 2bi ;
 
 : default-output-value-infos ( #call word -- infos )
     "default-output-classes" word-prop

basis/compiler/tree/propagation/transforms/transforms.factor

@@ -163,10 +163,12 @@ ERROR: bad-partial-eval quot word ;
 
 : inline-new ( class -- quot/f )
     dup tuple-class? [
-        dup inlined-dependency depends-on
+        dup tuple-layout
-        [ all-slots [ initial>> literalize ] map ]
+        [ depends-on-tuple-layout ]
-        [ tuple-layout '[ _ <tuple-boa> ] ]
+        [ drop all-slots [ initial>> literalize ] [ ] map-as ]
-        bi append >quotation
+        [ nip ]
+        2tri
+        '[ @ _ <tuple-boa> ]
     ] [ drop f ] if ;
 
 \ new [ inline-new ] 1 define-partial-eval
@@ -293,6 +295,6 @@ CONSTANT: lookup-table-at-max 256
 ! calls when a C type is redefined
 \ heap-size [
     dup word? [
-        [ inlined-dependency depends-on ] [ heap-size '[ _ ] ] bi
+        [ depends-on-definition ] [ heap-size '[ _ ] ] bi
     ] [ drop f ] if
 ] 1 define-partial-eval

basis/generalizations/generalizations-tests.factor

@@ -108,3 +108,8 @@ IN: generalizations.tests
     2 1 0 -1 [ + ] [ - ] [ * ] [ / ] 4 spread-curry 4 spread*
 ] unit-test
 
+[ { 1 2 } { 3 4 } { 5 6 } ]
+[ 1 2 3 4 5 6 [ 2array ] 2 3 mnapply ] unit-test
+
+[ { 1 2 3 } { 4 5 6 } ]
+[ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test

basis/generalizations/generalizations.factor

@@ -124,6 +124,10 @@ MACRO: cleave* ( n -- )
 MACRO: mnswap ( m n -- )
     1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
 
+MACRO: mnapply ( quot m n -- )
+    swap
+    [ swap '[ _ ] replicate ] dip '[ _ _ nspread ] ;
+
 MACRO: nweave ( n -- )
     [ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
     '[ _ _ ncleave ] ;

basis/grouping/grouping.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.order strings arrays vectors sequences
 sequences.private accessors fry ;
@@ -20,14 +20,16 @@ M: chunking-seq set-nth group@ <slice> 0 swap copy ;
 
 M: chunking-seq like drop { } like ; inline
 
-INSTANCE: chunking-seq sequence
-
 MIXIN: subseq-chunking
 
+INSTANCE: subseq-chunking sequence
+
 M: subseq-chunking nth group@ subseq ; inline
 
 MIXIN: slice-chunking
 
+INSTANCE: slice-chunking sequence
+
 M: slice-chunking nth group@ <slice> ; inline
 
 M: slice-chunking nth-unsafe group@ slice boa ; inline

basis/hints/hints.factor

@@ -41,18 +41,13 @@ M: object specializer-declaration class ;
 : specialize-quot ( quot specializer -- quot' )
     [ drop ] [ specializer-cases ] 2bi alist>quot ;
 
-! compiler.tree.propagation.inlining sets this to f
-SYMBOL: specialize-method?
-
-t specialize-method? set-global
-
 : method-declaration ( method -- quot )
     [ "method-generic" word-prop dispatch# object <array> ]
     [ "method-class" word-prop ]
     bi prefix [ declare ] curry [ ] like ;
 
 : specialize-method ( quot method -- quot' )
-    [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
+    [ method-declaration prepend ]
     [ "method-generic" word-prop ] bi
     specializer [ specialize-quot ] when* ;
 

basis/images/jpeg/jpeg.factor

@@ -287,7 +287,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
 : decode-macroblock ( -- blocks )
     jpeg> components>>
     [
-        [ mb-dim first2 * iota ]
+        [ mb-dim first2 * ]
         [ [ decode-block ] curry replicate ] bi
     ] map concat ;
 

basis/macros/macros.factor

@@ -32,4 +32,4 @@ M: macro definition "macro" word-prop ;
 M: macro reset-word
     [ call-next-method ] [ f "macro" set-word-prop ] bi ;
 
-M: macro bump-effect-counter* drop t ;
+M: macro always-bump-effect-counter? drop t ;

basis/random/windows/windows.factor

@@ -1,7 +1,8 @@
 USING: accessors alien.c-types alien.data byte-arrays
 combinators.short-circuit continuations destructors init kernel
 locals namespaces random windows.advapi32 windows.errors
-windows.kernel32 windows.types math.bitwise ;
+windows.kernel32 windows.types math.bitwise sequences fry
+literals ;
 IN: random.windows
 
 TUPLE: windows-rng provider type ;
@@ -58,13 +59,23 @@ M: windows-rng random-bytes* ( n tuple -- bytes )
         [ CryptGenRandom win32-error=0/f ] keep
     ] with-destructors ;
 
-[
+ERROR: no-windows-crypto-provider error ;
-    MS_DEF_PROV
-    PROV_RSA_FULL <windows-rng> system-random-generator set-global
 
-    [ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
+: try-crypto-providers ( seq -- windows-rng )
-    [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
+    [ first2 <windows-rng> ] attempt-all
-    secure-random-generator set-global
+    dup windows-rng? [ no-windows-crypto-provider ] unless ;
+
+[
+    {
+        ${ MS_ENHANCED_PROV PROV_RSA_FULL }
+        ${ MS_DEF_PROV PROV_RSA_FULL }
+    } try-crypto-providers
+    system-random-generator set-global
+
+    {
+        ${ MS_STRONG_PROV PROV_RSA_FULL }
+        ${ MS_ENH_RSA_AES_PROV PROV_RSA_AES }
+    } try-crypto-providers secure-random-generator set-global
 ] "random.windows" add-startup-hook
 
 [

basis/stack-checker/backend/backend.factor

@@ -74,7 +74,7 @@ GENERIC: apply-object ( obj -- )
 
 M: wrapper apply-object
     wrapped>>
-    [ dup word? [ called-dependency depends-on ] [ drop ] if ]
+    [ dup word? [ depends-on-effect ] [ drop ] if ]
     [ push-literal ]
     bi ;
 

basis/stack-checker/dependencies/dependencies-tests.factor

@@ -1,37 +1 @@
-IN: stack-checker.dependencies.tests
-USING: tools.test stack-checker.dependencies words kernel namespaces
-definitions ;
 
-: computing-dependencies ( quot -- dependencies )
-    H{ } clone [ dependencies rot with-variable ] keep ;
-    inline
-
-SYMBOL: a
-SYMBOL: b
-
-[ ] [ a called-dependency depends-on ] unit-test
-
-[ H{ { a called-dependency } } ] [
-    [ a called-dependency depends-on ] computing-dependencies
-] unit-test
-
-[ H{ { a called-dependency } { b inlined-dependency } } ] [
-    [
-        a called-dependency depends-on b inlined-dependency depends-on
-    ] computing-dependencies
-] unit-test
-
-[ H{ { a inlined-dependency } { b inlined-dependency } } ] [
-    [
-        a inlined-dependency depends-on
-        a called-dependency depends-on
-        b inlined-dependency depends-on
-    ] computing-dependencies
-] unit-test
-
-[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
-[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
-[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test
-[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test
-[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
-[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test

basis/stack-checker/dependencies/dependencies.factor

@@ -1,23 +1,24 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes.algebra fry kernel math namespaces
+USING: assocs accessors classes.algebra fry generic kernel math
-sequences words ;
+namespaces sequences words sets ;
+FROM: classes.tuple.private => tuple-layout ;
 IN: stack-checker.dependencies
 
 ! Words that the current quotation depends on
 SYMBOL: dependencies
 
-SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
+SYMBOLS: effect-dependency conditional-dependency definition-dependency ;
 
 : index>= ( obj1 obj2 seq -- ? )
     [ index ] curry bi@ >= ;
 
 : dependency>= ( how1 how2 -- ? )
-    { called-dependency flushed-dependency inlined-dependency }
+    { effect-dependency conditional-dependency definition-dependency }
     index>= ;
 
 : strongest-dependency ( how1 how2 -- how )
-    [ called-dependency or ] bi@ [ dependency>= ] most ;
+    [ effect-dependency or ] bi@ [ dependency>= ] most ;
 
 : depends-on ( word how -- )
     over primitive? [ 2drop ] [
@@ -26,12 +27,96 @@ SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
         ] [ 3drop ] if
     ] if ;
 
+: depends-on-effect ( word -- )
+    effect-dependency depends-on ;
+
+: depends-on-conditionally ( word -- )
+    conditional-dependency depends-on ;
+
+: depends-on-definition ( word -- )
+    definition-dependency depends-on ;
+
 ! Generic words that the current quotation depends on
 SYMBOL: generic-dependencies
 
-: ?class-or ( class/f class -- class' )
+: ?class-or ( class class/f -- class' )
-    swap [ class-or ] when* ;
+    [ class-or ] when* ;
 
-: depends-on-generic ( generic class -- )
+: depends-on-generic ( class generic -- )
     generic-dependencies get dup
-    [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
+    [ [ ?class-or ] change-at ] [ 3drop ] if ;
+
+! Conditional dependencies are re-evaluated when classes change;
+! if any fail, the word is recompiled
+SYMBOL: conditional-dependencies
+
+GENERIC: satisfied? ( dependency -- ? )
+
+: add-conditional-dependency ( ... class -- )
+    boa conditional-dependencies get
+    dup [ conjoin ] [ 2drop ] if ; inline
+
+TUPLE: depends-on-class<= class1 class2 ;
+
+: depends-on-class<= ( class1 class2 -- )
+    \ depends-on-class<= add-conditional-dependency ;
+
+M: depends-on-class<= satisfied?
+    [ class1>> ] [ class2>> ] bi class<= ;
+
+TUPLE: depends-on-classes-disjoint class1 class2 ;
+
+: depends-on-classes-disjoint ( class1 class2 -- )
+    \ depends-on-classes-disjoint add-conditional-dependency ;
+
+M: depends-on-classes-disjoint satisfied?
+    [ class1>> ] [ class2>> ] bi classes-intersect? not ;
+
+TUPLE: depends-on-next-method class generic next-method ;
+
+: depends-on-next-method ( class generic next-method -- )
+    over depends-on-conditionally
+    \ depends-on-next-method add-conditional-dependency ;
+
+M: depends-on-next-method satisfied?
+    [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ;
+
+TUPLE: depends-on-method class generic method ;
+
+: depends-on-method ( class generic method -- )
+    over depends-on-conditionally
+    \ depends-on-method add-conditional-dependency ;
+
+M: depends-on-method satisfied?
+    [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ;
+
+TUPLE: depends-on-tuple-layout class layout ;
+
+: depends-on-tuple-layout ( class layout -- )
+    [ drop depends-on-conditionally ]
+    [ \ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
+
+M: depends-on-tuple-layout satisfied?
+    [ class>> tuple-layout ] [ layout>> ] bi eq? ;
+
+TUPLE: depends-on-flushable word ;
+
+: depends-on-flushable ( word -- )
+    [ depends-on-conditionally ]
+    [ \ depends-on-flushable add-conditional-dependency ] bi ;
+
+M: depends-on-flushable satisfied?
+    word>> flushable? ;
+
+: init-dependencies ( -- )
+    H{ } clone dependencies set
+    H{ } clone generic-dependencies set
+    H{ } clone conditional-dependencies set ;
+
+: without-dependencies ( quot -- )
+    [
+        dependencies off
+        generic-dependencies off
+        conditional-dependencies off
+        call
+    ] with-scope ; inline

basis/stack-checker/inlining/inlining.factor

@@ -140,7 +140,7 @@ SYMBOL: enter-out
 
 : inline-word ( word -- )
     commit-literals
-    [ inlined-dependency depends-on ]
+    [ depends-on-definition ]
     [
         dup inline-recursive-label [
             call-recursive-inline-word

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

@@ -273,7 +273,7 @@ M: bad-executable summary
 \ clear t "no-compile" set-word-prop
 
 : non-inline-word ( word -- )
-    dup called-dependency depends-on
+    dup depends-on-effect
     {
         { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
         { [ dup "special" word-prop ] [ infer-special ] }

basis/stack-checker/transforms/transforms.factor

@@ -124,15 +124,15 @@ IN: stack-checker.transforms
 
 \ 3|| t "no-compile" set-word-prop
 
-\ (call-next-method) [
+: add-next-method-dependency ( method -- )
-    [
     [ "method-class" word-prop ]
     [ "method-generic" word-prop ] bi
-        [ inlined-dependency depends-on ] bi@
+    2dup next-method
-    ] [
+    depends-on-next-method ;
-        [ next-method-quot ]
+
-        [ '[ _ no-next-method ] ] bi or
+\ (call-next-method) [
-    ] bi
+    [ add-next-method-dependency ]
+    [ [ next-method-quot ] [ '[ _ no-next-method ] ] bi or ] bi
 ] 1 define-transform
 
 \ (call-next-method) t "no-compile" set-word-prop
@@ -140,10 +140,10 @@ IN: stack-checker.transforms
 ! Constructors
 \ boa [
     dup tuple-class? [
-        dup inlined-dependency depends-on
+        dup tuple-layout
-        [ "boa-check" word-prop [ ] or ]
+        [ depends-on-tuple-layout ]
-        [ tuple-layout '[ _ <tuple-boa> ] ]
+        [ [ "boa-check" word-prop [ ] or ] dip ] 2bi
-        bi append
+        '[ @ _ <tuple-boa> ]
     ] [ drop f ] if
 ] 1 define-transform
 

basis/tools/deploy/shaker/shaker.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays accessors io.backend io.streams.c init fry
 namespaces math make assocs kernel parser parser.notes lexer
@@ -128,6 +128,7 @@ IN: tools.deploy.shaker
                 "combination"
                 "compiled-generic-uses"
                 "compiled-uses"
+                "conditional-dependencies"
                 "constant"
                 "constraints"
                 "custom-inlining"
@@ -159,7 +160,6 @@ IN: tools.deploy.shaker
                 "members"
                 "memo-quot"
                 "methods"
-                "mixin"
                 "method-class"
                 "method-generic"
                 "modular-arithmetic"

basis/tools/profiler/profiler.factor

@@ -40,7 +40,7 @@ IN: tools.profiler
 : profiler-usage ( word -- words )
     [ smart-usage [ word? ] filter ]
     [ compiled-generic-usage keys ]
-    [ compiled-usage keys ]
+    [ effect-dependencies-of keys ]
     tri 3append prune ;
 
 : usage-counters ( word -- alist )

basis/typed/typed.factor

@@ -4,6 +4,7 @@ combinators.short-circuit definitions effects fry hints
 math kernel kernel.private namespaces parser quotations
 sequences slots words locals 
 locals.parser macros stack-checker.dependencies ;
+FROM: classes.tuple.private => tuple-layout ;
 IN: typed
 
 ERROR: type-mismatch-error word expected-types ;
@@ -31,6 +32,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
 
 : (unboxer) ( type -- quot )
     dup unboxable-tuple-class? [
+        dup dup tuple-layout depends-on-tuple-layout
         all-slots [
             [ name>> reader-word 1quotation ]
             [ class>> (unboxer) ] bi compose
@@ -49,7 +51,10 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
 
 : (unboxed-types) ( type -- types )
     dup unboxable-tuple-class?
-    [ all-slots [ class>> (unboxed-types) ] map concat ]
+    [
+        dup dup tuple-layout depends-on-tuple-layout
+        all-slots [ class>> (unboxed-types) ] map concat
+    ]
     [ 1array ] if ;
 
 : unboxed-types ( types -- types' )
@@ -75,7 +80,12 @@ DEFER: make-boxer
 
 : boxer ( type -- quot )
     dup unboxable-tuple-class?
-    [ [ all-slots [ class>> ] map make-boxer ] [ [ boa ] curry ] bi compose ]
+    [
+        dup dup tuple-layout depends-on-tuple-layout
+        [ all-slots [ class>> ] map make-boxer ]
+        [ [ boa ] curry ]
+        bi compose
+    ]
     [ drop [ ] ] if ;
 
 : make-boxer ( types -- quot )
@@ -84,18 +94,15 @@ DEFER: make-boxer
 
 ! defining typed words
 
-: (depends-on) ( types -- types )
-    dup [ inlined-dependency depends-on ] each ; inline
-
 MACRO: (typed) ( word def effect -- quot )
     [ swap ] dip
     [
-        nip effect-in-types (depends-on) swap
+        nip effect-in-types swap
         [ [ unboxed-types ] [ make-boxer ] bi ] dip
         '[ _ declare @ @ ]
     ]
     [
-        effect-out-types (depends-on)
+        effect-out-types
         dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
     ] 2bi ;
 
@@ -118,9 +125,9 @@ M: typed-gensym crossref?
     [ 2nip ] 3tri define-declared ;
 
 MACRO: typed ( quot word effect -- quot' )
-    [ effect-in-types (depends-on) dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ] 
+    [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ] 
     [
-        nip effect-out-types (depends-on) dup typed-stack-effect?
+        nip effect-out-types dup typed-stack-effect?
         [ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if
     ] 2bi ;
 

core/bootstrap/primitives.factor

@@ -126,6 +126,9 @@ call( -- )
     prepare-slots make-slots 1 finalize-slots
     [ "slots" set-word-prop ] [ define-accessors ] 2bi ;
 
+: define-builtin-predicate ( class -- )
+    dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
+
 : define-builtin ( symbol slotspec -- )
     [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;
 

core/classes/algebra/algebra-tests.factor

@@ -79,9 +79,9 @@ INSTANCE: union-with-one-member mixin-with-one-member
 
 [ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
 
-[ t ] [ growable tuple sequence class-and class<= ] unit-test
+[ f ] [ growable tuple sequence class-and class<= ] unit-test
 
-[ t ] [ growable assoc class-and tuple class<= ] unit-test
+[ f ] [ growable assoc class-and tuple class<= ] unit-test
 
 [ t ] [ object \ f \ f class-not class-or class<= ] unit-test
 
@@ -130,6 +130,14 @@ INSTANCE: union-with-one-member mixin-with-one-member
 [ t ] [ a union-with-one-member class<= ] unit-test
 [ f ] [ union-with-one-member class-not integer class<= ] unit-test
 
+MIXIN: empty-mixin
+
+[ f ] [ empty-mixin class-not null class<= ] unit-test
+[ f ] [ empty-mixin null class<= ] unit-test
+
+[ t ] [ array sequence vector class-not class-and class<= ] unit-test
+[ f ] [ vector sequence vector class-not class-and class<= ] unit-test
+
 ! class-and
 : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
 
@@ -146,8 +154,6 @@ INSTANCE: union-with-one-member mixin-with-one-member
 [ t ] [ slice     reversed null   class-and* ] unit-test
 [ t ] [ \ f class-not \ f      null   class-and* ] unit-test
 
-[ t ] [ vector virtual-sequence null class-and* ] unit-test
-
 [ t ] [ vector array class-not vector class-and* ] unit-test
 
 ! class-or
@@ -160,6 +166,7 @@ INSTANCE: union-with-one-member mixin-with-one-member
 
 ! classes-intersect?
 [ t ] [ both tuple classes-intersect? ] unit-test
+
 [ f ] [ vector virtual-sequence classes-intersect? ] unit-test
 
 [ t ] [ number vector class-or sequence classes-intersect? ] unit-test

core/classes/algebra/algebra.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes combinators accessors sequences arrays
 vectors assocs namespaces words sorting layouts math hashtables
@@ -34,22 +34,18 @@ DEFER: (class-or)
 
 GENERIC: (flatten-class) ( class -- )
 
-: normalize-class ( class -- class' )
+GENERIC: normalize-class ( class -- class' )
-    {
+
-        { [ dup members ] [ members <anonymous-union> normalize-class ] }
+M: object normalize-class ;
-        { [ dup participants ] [ participants <anonymous-intersection> normalize-class ] }
-        [ ]
-    } cond ;
 
 PRIVATE>
 
-GENERIC: valid-class? ( obj -- ? )
+GENERIC: forgotten-class? ( obj -- ? )
 
-M: class valid-class? drop t ;
+M: word forgotten-class? "forgotten" word-prop ;
-M: anonymous-union valid-class? members>> [ valid-class? ] all? ;
+M: anonymous-union forgotten-class? members>> [ forgotten-class? ] any? ;
-M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;
+M: anonymous-intersection forgotten-class? participants>> [ forgotten-class? ] any? ;
-M: anonymous-complement valid-class? class>> valid-class? ;
+M: anonymous-complement forgotten-class? class>> forgotten-class? ;
-M: word valid-class? drop f ;
 
 : class<= ( first second -- ? )
     class<=-cache get [ (class<=) ] 2cache ;
@@ -93,6 +89,9 @@ M: word valid-class? drop f ;
 : left-anonymous-union<= ( first second -- ? )
     [ members>> ] dip [ class<= ] curry all? ;
 
+: right-union<= ( first second -- ? )
+    members [ class<= ] with any? ;
+
 : right-anonymous-union<= ( first second -- ? )
     members>> [ class<= ] with any? ;
 
@@ -117,7 +116,7 @@ M: word valid-class? drop f ;
             [ class-not normalize-class ] map
             <anonymous-union>
         ] }
-        [ <anonymous-complement> ]
+        [ drop object ]
     } cond ;
 
 : left-anonymous-complement<= ( first second -- ? )
@@ -147,6 +146,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
                 { [ over anonymous-union? ] [ left-anonymous-union<= ] }
                 { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
                 { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
+                { [ dup members ] [ right-union<= ] }
                 { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
                 { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
                 { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }

core/classes/builtin/builtin.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes classes.algebra classes.algebra.private
 words kernel kernel.private namespaces sequences math
@@ -20,11 +20,6 @@ M: object class tag type>class ; inline
 
 M: builtin-class rank-class drop 0 ;
 
-GENERIC: define-builtin-predicate ( class -- )
-
-M: builtin-class define-builtin-predicate
-    dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
-
 M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
 
 M: builtin-class (flatten-class) dup set ;

core/classes/classes.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays definitions assocs kernel kernel.private
 slots.private namespaces make sequences strings words words.symbol
@@ -37,11 +37,16 @@ PREDICATE: class < word "class" word-prop ;
 
 : classes ( -- seq ) implementors-map get keys ;
 
-: predicate-word ( word -- predicate )
+: create-predicate-word ( word -- predicate )
     [ name>> "?" append ] [ vocabulary>> ] bi create ;
 
+: predicate-word ( word -- predicate )
+    "predicate" word-prop first ;
+
 PREDICATE: predicate < word "predicating" word-prop >boolean ;
 
+M: predicate flushable? drop t ;
+
 M: predicate forget*
     [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
 
@@ -49,8 +54,7 @@ M: predicate reset-word
     [ call-next-method ] [ f "predicating" set-word-prop ] bi ;
 
 : define-predicate ( class quot -- )
-    [ "predicate" word-prop first ] dip
+    [ predicate-word ] dip (( object -- ? )) define-declared ;
-    (( object -- ? )) define-declared ;
 
 : superclass ( class -- super )
     #! Output f for non-classes to work with algebra code
@@ -133,19 +137,24 @@ M: sequence implementors [ implementors ] gather ;
     dup deferred? [ define-symbol ] [ drop ] if ;
 
 : (define-class) ( word props -- )
+    reset-caches
+    [ drop update-map- ]
+    [
         [
             {
-            [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
+                [ dup class? [ drop ] [ implementors-map+ ] if ]
                 [ reset-class ]
                 [ ?define-symbol ]
-            [ changed-definition ]
                 [ ]
             } cleave
         ] dip [ assoc-union ] curry change-props
-    dup predicate-word
+        dup create-predicate-word
         [ 1quotation "predicate" set-word-prop ]
         [ swap "predicating" set-word-prop ]
         [ drop t "class" set-word-prop ]
+        2tri
+    ]
+    [ drop update-map+ ]
     2tri ;
 
 PRIVATE>
@@ -161,13 +170,7 @@ GENERIC: update-methods ( class seq -- )
     [ nip [ update-class ] each ] [ update-methods ] 2bi ;
 
 : define-class ( word superclass members participants metaclass -- )
-    #! If it was already a class, update methods after.
+    make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
-    reset-caches
-    make-class-props
-    [ drop update-map- ]
-    [ (define-class) ]
-    [ drop update-map+ ]
-    2tri ;
 
 : forget-predicate ( class -- )
     dup "predicate" word-prop

core/classes/intersection/intersection.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words accessors sequences kernel assocs combinators classes
 classes.algebra classes.algebra.private classes.builtin
@@ -8,6 +8,8 @@ IN: classes.intersection
 PREDICATE: intersection-class < class
     "metaclass" word-prop intersection-class eq? ;
 
+<PRIVATE
+
 : intersection-predicate-quot ( members -- quot )
     [
         [ drop t ]
@@ -23,16 +25,14 @@ PREDICATE: intersection-class < class
 
 M: intersection-class update-class define-intersection-predicate ;
 
-: define-intersection-class ( class participants -- )
-    [ [ f f ] dip intersection-class define-class ]
-    [ drop update-classes ]
-    2bi ;
-
 M: intersection-class rank-class drop 2 ;
 
 M: intersection-class instance?
     "participants" word-prop [ instance? ] with all? ;
 
+M: intersection-class normalize-class
+    participants <anonymous-intersection> normalize-class ;
+
 M: intersection-class (flatten-class)
     participants <anonymous-intersection> (flatten-class) ;
 
@@ -47,3 +47,10 @@ M: anonymous-intersection (flatten-class)
         [ intersect-flattened-classes ] map-reduce
         [ dup set ] each
     ] if-empty ;
+
+PRIVATE>
+
+: define-intersection-class ( class participants -- )
+    [ [ f f ] dip intersection-class define-class ]
+    [ drop update-classes ]
+    2bi ;

core/classes/mixin/mixin-tests.factor

@@ -38,8 +38,8 @@ MIXIN: mx1
 INSTANCE: integer mx1
 
 [ t ] [ integer mx1 class<= ] unit-test
-[ t ] [ mx1 integer class<= ] unit-test
+[ f ] [ mx1 integer class<= ] unit-test
-[ t ] [ mx1 number class<= ] unit-test
+[ f ] [ mx1 number class<= ] unit-test
 
 "IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- )
 

core/classes/mixin/mixin.factor

@@ -1,20 +1,81 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.union words kernel sequences
+USING: classes classes.algebra classes.algebra.private
+classes.union classes.union.private words kernel sequences
 definitions combinators arrays assocs generic accessors ;
 IN: classes.mixin
 
 PREDICATE: mixin-class < union-class "mixin" word-prop ;
 
+M: mixin-class normalize-class ;
+
+M: mixin-class (classes-intersect?)
+    members [ classes-intersect? ] with any? ;
+
 M: mixin-class reset-class
     [ call-next-method ] [ { "mixin" } reset-props ] bi ;
 
 M: mixin-class rank-class drop 3 ;
 
+TUPLE: check-mixin-class class ;
+
+: check-mixin-class ( mixin -- mixin )
+    dup mixin-class? [
+        \ check-mixin-class boa throw
+    ] unless ;
+
+<PRIVATE
+
 : redefine-mixin-class ( class members -- )
     [ (define-union-class) ]
+    [ drop changed-conditionally ]
     [ drop t "mixin" set-word-prop ]
-    2bi ;
+    2tri ;
+
+: if-mixin-member? ( class mixin true false -- )
+    [ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
+
+: change-mixin-class ( class mixin quot -- )
+    [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
+    swap redefine-mixin-class ; inline
+
+: (add-mixin-instance) ( class mixin -- )
+    #! Call update-methods before adding the member:
+    #! - Call sites of generics specializing on 'mixin'
+    #! where the inferred type is 'class' are updated,
+    #! - Call sites where the inferred type is a subtype
+    #! of 'mixin' disjoint from 'class' are not updated
+    dup class-usages {
+        [ nip update-methods ]
+        [ drop [ suffix ] change-mixin-class ]
+        [ drop [ f ] 2dip "instances" word-prop set-at ]
+        [ 2nip [ update-class ] each ]
+    } 3cleave ;
+
+: (remove-mixin-instance) ( class mixin -- )
+    #! Call update-methods after removing the member:
+    #! - Call sites of generics specializing on 'mixin'
+    #! where the inferred type is 'class' are updated,
+    #! - Call sites where the inferred type is a subtype
+    #! of 'mixin' disjoint from 'class' are not updated
+    dup class-usages {
+        [ drop [ swap remove ] change-mixin-class ]
+        [ drop "instances" word-prop delete-at ]
+        [ 2nip [ update-class ] each ]
+        [ nip update-methods ]
+    } 3cleave ;
+
+PRIVATE>
+
+GENERIC# add-mixin-instance 1 ( class mixin -- )
+
+M: class add-mixin-instance
+    [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
+
+: remove-mixin-instance ( class mixin -- )
+    [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
+
+M: mixin-class class-forgotten remove-mixin-instance ;
 
 : define-mixin-class ( class -- )
     dup mixin-class? [
@@ -26,73 +87,19 @@ M: mixin-class rank-class drop 3 ;
         tri
     ] if ;
 
-TUPLE: check-mixin-class class ;
-
-: check-mixin-class ( mixin -- mixin )
-    dup mixin-class? [
-        \ check-mixin-class boa throw
-    ] unless ;
-
-: if-mixin-member? ( class mixin true false -- )
-    [ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
-
-: change-mixin-class ( class mixin quot -- )
-    [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
-    swap redefine-mixin-class ; inline
-
-: update-classes/new ( mixin -- )
-    class-usages
-    [ [ update-class ] each ]
-    [ implementors [ remake-generic ] each ] bi ;
-
-: (add-mixin-instance) ( class mixin -- )
-    [ [ suffix ] change-mixin-class ]
-    [ [ f ] 2dip "instances" word-prop set-at ]
-    2bi ;
-
-GENERIC# add-mixin-instance 1 ( class mixin -- )
-
-M: class add-mixin-instance
-    #! Note: we call update-classes on the new member, not the
-    #! mixin. This ensures that we only have to update the
-    #! methods whose specializer intersects the new member, not
-    #! the entire mixin (since the other mixin members are not
-    #! affected at all). Also, all usages of the mixin will get
-    #! updated by transitivity; the mixins usages appear in
-    #! class-usages of the member, now that it's been added.
-    [ 2drop ] [
-        [ (add-mixin-instance) ] 2keep
-        [ nip ] [ [ new-class? ] either? ] 2bi
-        [ update-classes/new ] [ update-classes ] if
-    ] if-mixin-member? ;
-
-: (remove-mixin-instance) ( class mixin -- )
-    [ [ swap remove ] change-mixin-class ]
-    [ "instances" word-prop delete-at ]
-    2bi ;
-
-: remove-mixin-instance ( class mixin -- )
-    #! The order of the three clauses is important here. The last
-    #! one must come after the other two so that the entries it
-    #! adds to changed-generics are not overwritten.
-    [
-        [ (remove-mixin-instance) ]
-        [ nip update-classes ]
-        [ class-usages update-methods ]
-        2tri
-    ] [ 2drop ] if-mixin-member? ;
-
-M: mixin-class class-forgotten remove-mixin-instance ;
-
 ! Definition protocol implementation ensures that removing an
 ! INSTANCE: declaration from a source file updates the mixin.
 TUPLE: mixin-instance class mixin ;
 
 C: <mixin-instance> mixin-instance
 
+<PRIVATE
+
 : >mixin-instance< ( mixin-instance -- class mixin )
     [ class>> ] [ mixin>> ] bi ; inline
 
+PRIVATE>
+
 M: mixin-instance where >mixin-instance< "instances" word-prop at ;
 
 M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ;

core/classes/parser/parser.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser vocabs.parser words kernel classes compiler.units lexer ;
 IN: classes.parser
@@ -9,7 +9,7 @@ IN: classes.parser
 : create-class-in ( string -- word )
     current-vocab create
     dup save-class-location
-    dup predicate-word dup set-word save-location ;
+    dup create-predicate-word dup set-word save-location ;
 
 : CREATE-CLASS ( -- word )
     scan create-class-in ;

core/classes/predicate/predicate.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes classes.algebra classes.algebra.private kernel
 namespaces make words sequences quotations arrays kernel.private
@@ -8,6 +8,8 @@ IN: classes.predicate
 PREDICATE: predicate-class < class
     "metaclass" word-prop predicate-class eq? ;
 
+<PRIVATE
+
 GENERIC: predicate-quot ( class -- quot )
 
 M: predicate-class predicate-quot
@@ -18,6 +20,8 @@ M: predicate-class predicate-quot
         [ drop f ] , \ if ,
     ] [ ] make ;
 
+PRIVATE>
+
 : define-predicate-class ( class superclass definition -- )
     [ drop f f predicate-class define-class ]
     [ nip "predicate-definition" set-word-prop ]

core/classes/singleton/singleton.factor

@@ -1,11 +1,16 @@
-! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov.
+! Copyright (C) 2008, 2010 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes classes.algebra classes.algebra.private
-classes.predicate kernel sequences words ;
+classes.predicate classes.predicate.private kernel sequences
+words ;
 IN: classes.singleton
 
+<PRIVATE
+
 : singleton-predicate-quot ( class -- quot ) [ eq? ] curry ;
 
+PRIVATE>
+
 PREDICATE: singleton-class < predicate-class
     [ "predicate-definition" word-prop ]
     [ singleton-predicate-quot ]

core/classes/tuple/tuple-docs.factor

@@ -200,6 +200,8 @@ ARTICLE: "tuple-introspection" "Tuple introspection"
     tuple>array
     tuple-slots
 }
+"Tuples can be compared for slot equality even if the tuple class overrides " { $link equal? } ":"
+{ $subsections tuple= }
 "Tuple classes can also be defined at run time:"
 { $subsections define-tuple-class }
 { $see-also "slots" "mirrors" } ;
@@ -348,8 +350,7 @@ HELP: tuple-class
 
 HELP: tuple=
 { $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
-{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
+{ $description "Checks if two tuples have equal slot values. This is the default behavior of " { $link = } " on tuples, unless the tuple class subclasses " { $link identity-tuple } " or implements a method on " { $link equal? } ". In cases where equality has been redefined, this word can be used to get the default semantics if needed." } ;
-{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
 
 HELP: tuple
 { $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."

core/classes/tuple/tuple.factor

@@ -223,7 +223,7 @@ M: tuple-class update-class
         2drop
         [
             [ update-tuples-after ]
-            [ changed-definition ]
+            [ changed-conditionally ]
             bi
         ] each-subclass
     ]

core/classes/union/union.factor

@@ -1,13 +1,15 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel assocs combinators classes
-classes.algebra classes.algebra.private namespaces arrays math
+classes.private classes.algebra classes.algebra.private
-quotations ;
+namespaces arrays math quotations definitions ;
 IN: classes.union
 
 PREDICATE: union-class < class
     "metaclass" word-prop union-class eq? ;
 
+<PRIVATE
+
 : union-predicate-quot ( members -- quot )
     [
         [ drop f ]
@@ -24,15 +26,23 @@ PREDICATE: union-class < class
 M: union-class update-class define-union-predicate ;
 
 : (define-union-class) ( class members -- )
-    f swap f union-class define-class ;
+    f swap f union-class make-class-props (define-class) ;
+
+PRIVATE>
 
 : define-union-class ( class members -- )
-    [ (define-union-class) ] [ drop update-classes ] 2bi ;
+    [ (define-union-class) ]
+    [ drop changed-conditionally ]
+    [ drop update-classes ]
+    2tri ;
 
 M: union-class rank-class drop 2 ;
 
 M: union-class instance?
     "members" word-prop [ instance? ] with any? ;
 
+M: union-class normalize-class
+    members <anonymous-union> normalize-class ;
+
 M: union-class (flatten-class)
     members <anonymous-union> (flatten-class) ;

core/compiler/units/units.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel continuations assocs namespaces
 sequences words vocabs definitions hashtables init sets
@@ -43,6 +43,20 @@ PRIVATE>
 
 SYMBOL: compiler-impl
 
+HOOK: update-call-sites compiler-impl ( class generic -- words )
+
+: changed-call-sites ( class generic -- )
+    update-call-sites [ changed-definition ] each ;
+
+M: generic update-generic ( class generic -- )
+    [ changed-call-sites ]
+    [ remake-generic drop ]
+    [ changed-conditionally drop ]
+    2tri ;
+
+M: sequence update-methods ( class seq -- )
+    implementors [ update-generic ] with each ;
+
 HOOK: recompile compiler-impl ( words -- alist )
 
 HOOK: to-recompile compiler-impl ( -- words )
@@ -52,12 +66,14 @@ HOOK: process-forgotten-words compiler-impl ( words -- )
 : compile ( words -- ) recompile modify-code-heap ;
 
 ! Non-optimizing compiler
-M: f recompile
+M: f update-call-sites
-    [ dup def>> ] { } map>assoc ;
+    2drop { } ;
 
 M: f to-recompile
-    changed-definitions get [ drop word? ] assoc-filter
+    changed-definitions get [ drop word? ] assoc-filter keys ;
-    changed-generics get assoc-union keys ;
+
+M: f recompile
+    [ dup def>> ] { } map>assoc ;
 
 M: f process-forgotten-words drop ;
 
@@ -92,9 +108,9 @@ GENERIC: definitions-changed ( assoc obj -- )
 ! inline caching
 : effect-counter ( -- n ) 47 special-object ; inline
 
-GENERIC: bump-effect-counter* ( defspec -- ? )
+GENERIC: always-bump-effect-counter? ( defspec -- ? )
 
-M: object bump-effect-counter* drop f ;
+M: object always-bump-effect-counter? drop f ;
 
 <PRIVATE
 
@@ -108,6 +124,7 @@ M: object bump-effect-counter* drop f ;
     dup new-definitions get first update
     dup new-definitions get second update
     dup changed-definitions get update
+    dup maybe-changed get update
     dup dup changed-vocabs update ;
 
 : process-forgotten-definitions ( -- )
@@ -117,9 +134,10 @@ M: object bump-effect-counter* drop f ;
     bi ;
 
 : bump-effect-counter? ( -- ? )
-    changed-effects get new-words get assoc-diff assoc-empty? not
+    changed-effects get
-    changed-definitions get [ drop bump-effect-counter* ] assoc-any?
+    maybe-changed get
-    or ;
+    changed-definitions get [ drop always-bump-effect-counter? ] assoc-filter
+    3array assoc-combine new-words get assoc-diff assoc-empty? not ;
 
 : bump-effect-counter ( -- )
     bump-effect-counter? [
@@ -148,25 +166,23 @@ PRIVATE>
 : with-nested-compilation-unit ( quot -- )
     [
         H{ } clone changed-definitions set
-        H{ } clone changed-generics set
+        H{ } clone maybe-changed set
         H{ } clone changed-effects set
         H{ } clone outdated-generics set
         H{ } clone outdated-tuples set
         H{ } clone new-words set
-        H{ } clone new-classes set
         [ finish-compilation-unit ] [ ] cleanup
     ] with-scope ; inline
 
 : with-compilation-unit ( quot -- )
     [
         H{ } clone changed-definitions set
-        H{ } clone changed-generics set
+        H{ } clone maybe-changed set
         H{ } clone changed-effects set
         H{ } clone outdated-generics set
         H{ } clone forgotten-definitions set
         H{ } clone outdated-tuples set
         H{ } clone new-words set
-        H{ } clone new-classes set
         <definitions> new-definitions set
         <definitions> old-definitions set
         [ finish-compilation-unit ] [ ] cleanup

core/definitions/definitions.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences namespaces assocs math accessors ;
 IN: definitions
@@ -15,28 +15,23 @@ SYMBOL: changed-definitions
 : changed-definition ( defspec -- )
     dup changed-definitions get set-in-unit ;
 
-SYMBOL: changed-effects
+SYMBOL: maybe-changed
 
-SYMBOL: changed-generics
+: changed-conditionally ( class -- )
+    dup maybe-changed get set-in-unit ;
+
+SYMBOL: changed-effects
 
 SYMBOL: outdated-generics
 
 SYMBOL: new-words
 
-SYMBOL: new-classes
-
 : new-word ( word -- )
     dup new-words get set-in-unit ;
 
 : new-word? ( word -- ? )
     new-words get key? ;
 
-: new-class ( word -- )
-    dup new-classes get set-in-unit ;
-
-: new-class? ( word -- ? )
-    new-classes get key? ;
-
 GENERIC: where ( defspec -- loc )
 
 M: object where drop f ;

core/generic/generic.factor

@@ -87,21 +87,16 @@ TUPLE: check-method class generic ;
         \ check-method boa throw
     ] unless ; inline
 
-: changed-generic ( class generic -- )
-    changed-generics get
-    [ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ;
-
 : remake-generic ( generic -- )
     dup outdated-generics get set-in-unit ;
 
 : remake-generics ( -- )
     outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
 
+GENERIC: update-generic ( class generic -- )
+
 : with-methods ( class generic quot -- )
-    [ drop changed-generic ]
+    [ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
-    [ [ "methods" word-prop ] dip call ]
-    [ drop remake-generic drop ]
-    3tri ; inline
 
 : method-word-name ( class generic -- string )
     [ name>> ] bi@ "=>" glue ;
@@ -109,6 +104,9 @@ TUPLE: check-method class generic ;
 PREDICATE: method-body < word
     "method-generic" word-prop >boolean ;
 
+M: method-body flushable?
+    "method-generic" word-prop flushable? ;
+
 M: method-body stack-effect
     "method-generic" word-prop stack-effect ;
 
@@ -174,11 +172,6 @@ M: method-body forget*
         [ call-next-method ] bi
     ] if ;
 
-M: sequence update-methods ( class seq -- )
-    implementors [
-        [ changed-generic ] [ remake-generic drop ] 2bi
-    ] with each ;
-
 : define-generic ( word combination effect -- )
     [ nip swap set-stack-effect ]
     [

core/kernel/kernel-docs.factor

@@ -672,6 +672,9 @@ HELP: object
 HELP: null
 { $class-description
     "The canonical empty class with no instances."
+}
+{ $notes
+    "Unlike " { $snippet "null" } " in Java or " { $snippet "NULL" } " in C++, this is not a value signifying empty, or nothing. Use " { $link f } " for this purpose."
 } ;
 
 HELP: most

core/words/words.factor

@@ -110,9 +110,14 @@ M: word make-inline
 : define-inline ( word def effect -- )
     [ define-declared ] [ 2drop make-inline ] 3bi ;
 
+GENERIC: flushable? ( word -- ? )
+
+M: word flushable? "flushable" word-prop ;
+
 GENERIC: reset-word ( word -- )
 
 M: word reset-word
+    dup flushable? [ dup changed-conditionally ] when
     {
         "unannotated-def" "parsing" "inline" "recursive"
         "foldable" "flushable" "reading" "writing" "reader"

extra/gpu/shaders/shaders.factor

@@ -128,6 +128,20 @@ TR: hyphens>underscores "-" "_" ;
         [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
     } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
 
+:: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
+    program-instance name attribute-index :> idx
+    idx 0 >= [
+        idx glEnableVertexAttribArray
+        idx dim gl-type normalize? stride offset ptr <displaced-alien> glVertexAttribPointer
+    ] when ; inline
+
+:: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- )
+    program-instance name attribute-index :> idx
+    idx 0 >= [
+        idx glEnableVertexAttribArray
+        idx dim gl-type stride offset ptr <displaced-alien> glVertexAttribIPointer
+    ] when ; inline
+
 :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
     vertex-attribute name>> hyphens>underscores :> name
     vertex-attribute component-type>>           :> type
@@ -141,23 +155,9 @@ TR: hyphens>underscores "-" "_" ;
         { [ name not ] [ [ 2drop ] ] }
         {
             [ type unnormalized-integer-components? ]
-            [
+            [ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ]
-                {
-                    name attribute-index [ glEnableVertexAttribArray ] keep
-                    dim gl-type stride offset
-                } >quotation :> dip-block
-                
-                { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
-            ]
         }
-        [
+        [ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ]
-            {
-                name attribute-index [ glEnableVertexAttribArray ] keep
-                dim gl-type normalize? stride offset
-            } >quotation :> dip-block
-
-            { dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
-        ]
     } cond ;
 
 :: [bind-vertex-format] ( vertex-attributes -- quot )