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

basis/compiler/tree/propagation/branches/branches.factor

@@ -130,6 +130,22 @@ M: #phi propagate-before ( #phi -- )
                 swap t-->
             ]
         }
+        {
+            { { t f } { t } }
+            [
+                first =f
+                condition-value get =t /\
+                swap f-->
+            ]
+        }
+        {
+            { { t } { t f } }
+            [
+                second =f
+                condition-value get =f /\
+                swap f-->
+            ]
+        }
         {
             { { t f } { } }
             [

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

@@ -4,7 +4,7 @@ USING: accessors combinators combinators.private effects fry
 kernel kernel.private make sequences continuations quotations
 words math stack-checker combinators.short-circuit
 stack-checker.transforms compiler.tree.propagation.info
-compiler.tree.propagation.inlining ;
+compiler.tree.propagation.inlining compiler.units ;
 IN: compiler.tree.propagation.call-effect
 
 ! call( and execute( have complex expansions.
@@ -15,22 +15,19 @@ IN: compiler.tree.propagation.call-effect
 !   and compare it with declaration. If matches, call it unsafely.
 ! - Fallback. If the above doesn't work, call it and compare the datastack before
 !   and after to make sure it didn't mess anything up.
+! - Inline caches and cached effects are invalidated whenever a macro is redefined, or
+!   a word's effect changes, by comparing a global counter against the counter value
+!   last observed. The counter is incremented by compiler.units.
 
 ! execute( uses a similar strategy.
 
-: definition-counter ( -- n ) 46 getenv ; inline
-
 TUPLE: inline-cache value counter ;
 
 : inline-cache-hit? ( word/quot ic -- ? )
-    {
+    { [ value>> eq? ] [ nip counter>> effect-counter eq? ] } 2&& ; inline
-        [ nip value>> ]
-        [ value>> eq? ]
-        [ nip counter>> definition-counter eq? ]
-    } 2&& ; inline
 
 : update-inline-cache ( word/quot ic -- )
-    [ definition-counter ] dip
+    [ effect-counter ] dip
     [ (>>value) ] [ (>>counter) ] bi-curry bi* ; inline
 
 SINGLETON: +unknown+
@@ -64,10 +61,10 @@ M: compose cached-effect
     [ infer ] [ 2drop +unknown+ ] recover ;
 
 : cached-effect-valid? ( quot -- ? )
-    cache-counter>> definition-counter eq? ; inline
+    cache-counter>> effect-counter eq? ; inline
 
 : save-effect ( effect quot -- )
-    [ definition-counter ] dip
+    [ effect-counter ] dip
     [ (>>cached-effect) ] [ (>>cache-counter) ] bi-curry bi* ;
 
 M: quotation cached-effect

basis/compiler/tree/propagation/constraints/constraints.factor

@@ -39,8 +39,8 @@ M: true-constraint assume*
     bi ;
 
 M: true-constraint satisfied?
-    value>> value-info class>>
+    value>> value-info*
-    { [ true-class? ] [ null-class? not ] } 1&& ;
+    [ class>> true-class? ] [ drop f ] if ;
 
 TUPLE: false-constraint value ;
 
@@ -52,8 +52,8 @@ M: false-constraint assume*
     bi ;
 
 M: false-constraint satisfied?
-    value>> value-info class>>
+    value>> value-info*
-    { [ false-class? ] [ null-class? not ] } 1&& ;
+    [ class>> false-class? ] [ drop f ] if ;
 
 ! Class constraints
 TUPLE: class-constraint value class ;

basis/compiler/tree/propagation/info/info.factor

@@ -294,8 +294,11 @@ DEFER: (value-info-union)
 ! Assoc stack of current value --> info mapping
 SYMBOL: value-infos
 
+: value-info* ( value -- info ? )
+    resolve-copy value-infos get assoc-stack [ null-info or ] [ >boolean ] bi ; inline
+
 : value-info ( value -- info )
-    resolve-copy value-infos get assoc-stack null-info or ;
+    value-info* drop ;
 
 : set-value-info ( info value -- )
     resolve-copy value-infos get last set-at ;

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

@@ -224,6 +224,14 @@ IN: compiler.tree.propagation.tests
 
 [ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
 
+[ V{ fixnum } ] [
+    [
+        [ { fixnum } declare ] [ drop f ] if
+        dup [ dup 13 eq? [ t ] [ f ] if ] [ t ] if
+        [ "Oops" throw ] when
+    ] final-classes
+] unit-test
+
 [ V{ fixnum } ] [
     [
         >fixnum
@@ -231,6 +239,14 @@ IN: compiler.tree.propagation.tests
     ] final-classes
 ] unit-test
 
+[ ] [
+    [
+        dup dup dup [ 100 < ] [ drop f ] if dup
+        [ 2drop f ] [ 2drop f ] if
+        [ ] [ dup [ ] [ ] if ] if
+    ] final-info drop
+] unit-test
+
 [ V{ fixnum } ] [
     [ { fixnum } declare (clone) ] final-classes
 ] unit-test
@@ -925,3 +941,4 @@ M: tuple-with-read-only-slot clone
 
 ! Could be bignum not integer but who cares
 [ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test
+

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

@@ -6,7 +6,7 @@ stack-checker.dependencies quotations classes.tuple.private math
 math.partial-dispatch math.private math.intervals sets.private
 math.floats.private math.integers.private layouts math.order
 vectors hashtables combinators effects generalizations assocs
-sets combinators.short-circuit sequences.private locals
+sets combinators.short-circuit sequences.private locals growable
 stack-checker namespaces compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.transforms
 
@@ -300,3 +300,10 @@ CONSTANT: lookup-table-at-max 256
     tester '[ _ filter ] ;
 
 \ intersect [ intersect-quot ] 1 define-partial-eval
+
+! Speeds up sum-file, sort and reverse-complement benchmarks by
+! compiling decoder-readln better
+\ push [
+    in-d>> second value-info class>> growable class<=
+    [ \ push def>> ] [ f ] if
+] "custom-inlining" set-word-prop

basis/macros/macros.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser kernel sequences words effects combinators assocs
-definitions quotations namespaces memoize accessors ;
+definitions quotations namespaces memoize accessors
+compiler.units ;
 IN: macros
 
 <PRIVATE
@@ -28,3 +29,5 @@ 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 ;

basis/stack-checker/alien/alien.factor

@@ -69,6 +69,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
     pop-literal nip >>abi
     pop-literal nip >>parameters
     pop-literal nip >>return
-    "( callback )" f <word> >>xt
+    "( callback )" <uninterned-word> >>xt
     dup callback-bottom
     #alien-callback, ;

core/bootstrap/syntax.factor

@@ -1,8 +1,10 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: words words.symbol sequences vocabs kernel ;
+USING: words words.symbol sequences vocabs kernel
+compiler.units ;
 IN: bootstrap.syntax
 
+[
     "syntax" create-vocab drop
 
     {
@@ -88,3 +90,4 @@ IN: bootstrap.syntax
     } [ "syntax" create drop ] each
 
     "t" "syntax" lookup define-symbol
+] with-compilation-unit

core/classes/algebra/algebra-tests.factor

@@ -37,6 +37,8 @@ INTERSECTION: empty-intersection ;
 
 INTERSECTION: generic-class generic class ;
 
+UNION: union-with-one-member a ;
+
 ! class<=
 [ t ] [ \ fixnum \ integer class<= ] unit-test
 [ t ] [ \ fixnum \ fixnum class<= ] unit-test
@@ -122,6 +124,9 @@ INTERSECTION: generic-class generic class ;
 [ t ] [ generic-class generic class<= ] unit-test
 [ t ] [ generic-class \ class class<= ] unit-test
 
+[ t ] [ a union-with-one-member class<= ] unit-test
+[ f ] [ union-with-one-member class-not integer class<= ] unit-test
+
 ! class-and
 : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
 

core/classes/algebra/algebra.factor

@@ -9,11 +9,14 @@ IN: classes.algebra
 
 TUPLE: anonymous-union { members read-only } ;
 
-C: <anonymous-union> anonymous-union
+: <anonymous-union> ( members -- class )
+    [ null eq? not ] filter prune
+    dup length 1 = [ first ] [ anonymous-union boa ] if ;
 
 TUPLE: anonymous-intersection { participants read-only } ;
 
-C: <anonymous-intersection> anonymous-intersection
+: <anonymous-intersection> ( participants -- class )
+    prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
 
 TUPLE: anonymous-complement { class read-only } ;
 
@@ -114,6 +117,7 @@ M: word valid-class? drop f ;
             [ class-not normalize-class ] map
             <anonymous-union>
         ] }
+        [ <anonymous-complement> ]
     } cond ;
 
 : left-anonymous-complement<= ( first second -- ? )
@@ -133,8 +137,10 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
 
 : (class<=) ( first second -- ? )
     2dup eq? [ 2drop t ] [
+        [ normalize-class ] bi@
         2dup superclass<= [ 2drop t ] [
-            [ normalize-class ] bi@ {
+            {
+                { [ 2dup eq? ] [ 2drop t ] }
                 { [ dup empty-intersection? ] [ 2drop t ] }
                 { [ over empty-union? ] [ 2drop t ] }
                 { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }

core/compiler/units/units-tests.factor

@@ -7,7 +7,7 @@ IN: compiler.units.tests
 
 ! Non-optimizing compiler bugs
 [ 1 1 ] [
-    "A" "B" <word> [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep
+    "A" <uninterned-word> [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep
     1 swap execute
 ] unit-test
 

core/compiler/units/units.factor

@@ -3,7 +3,8 @@
 USING: accessors arrays kernel continuations assocs namespaces
 sequences words vocabs definitions hashtables init sets
 math math.order classes classes.algebra classes.tuple
-classes.tuple.private generic source-files.errors ;
+classes.tuple.private generic source-files.errors
+kernel.private ;
 IN: compiler.units
 
 SYMBOL: old-definitions
@@ -15,12 +16,16 @@ TUPLE: redefine-error def ;
     \ redefine-error boa
     { { "Continue" t } } throw-restarts drop ;
 
+<PRIVATE
+
 : add-once ( key assoc -- )
     2dup key? [ over redefine-error ] when conjoin ;
 
 : (remember-definition) ( definition loc assoc -- )
     [ over set-where ] dip add-once ;
 
+PRIVATE>
+
 : remember-definition ( definition loc -- )
     new-definitions get first (remember-definition) ;
 
@@ -44,6 +49,8 @@ HOOK: to-recompile compiler-impl ( -- words )
 
 HOOK: process-forgotten-words compiler-impl ( words -- )
 
+: compile ( words -- ) recompile modify-code-heap ;
+
 ! Non-optimizing compiler
 M: f recompile
     [ dup def>> ] { } map>assoc ;
@@ -90,6 +97,17 @@ GENERIC: definitions-changed ( assoc obj -- )
     definition-observers get
     [ definitions-changed ] with each ;
 
+! Incremented each time stack effects potentially changed, used
+! by compiler.tree.propagation.call-effect for call( and execute(
+! inline caching
+: effect-counter ( -- n ) 46 getenv ; inline
+
+GENERIC: bump-effect-counter* ( defspec -- ? )
+
+M: object bump-effect-counter* drop f ;
+
+<PRIVATE
+
 : changed-vocabs ( assoc -- vocabs )
     [ drop word? ] assoc-filter
     [ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
@@ -102,22 +120,34 @@ GENERIC: definitions-changed ( assoc obj -- )
     dup changed-definitions get update
     dup dup changed-vocabs update ;
 
-: compile ( words -- ) recompile modify-code-heap ;
-
 : process-forgotten-definitions ( -- )
     forgotten-definitions get keys
     [ [ word? ] filter process-forgotten-words ]
     [ [ delete-definition-errors ] each ]
     bi ;
 
+: bump-effect-counter? ( -- ? )
+    changed-effects get new-words get assoc-diff assoc-empty? not
+    changed-definitions get [ drop bump-effect-counter* ] assoc-any?
+    or ;
+
+: bump-effect-counter ( -- )
+    bump-effect-counter? [ 46 getenv 0 or 1 + 46 setenv ] when ;
+
+: notify-observers ( -- )
+    updated-definitions dup assoc-empty?
+    [ drop ] [ notify-definition-observers notify-error-observers ] if ;
+
 : finish-compilation-unit ( -- )
     remake-generics
     to-recompile recompile
     update-tuples
     process-forgotten-definitions
     modify-code-heap
-    updated-definitions dup assoc-empty?
+    bump-effect-counter
-    [ drop ] [ notify-definition-observers notify-error-observers ] if ;
+    notify-observers ;
+
+PRIVATE>
 
 : with-nested-compilation-unit ( quot -- )
     [
@@ -126,6 +156,7 @@ GENERIC: definitions-changed ( assoc obj -- )
         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
@@ -138,6 +169,7 @@ GENERIC: definitions-changed ( assoc obj -- )
         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

core/definitions/definitions.factor

@@ -21,8 +21,16 @@ SYMBOL: changed-generics
 
 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 ;
 

core/sequences/sequences.factor

@@ -659,9 +659,9 @@ PRIVATE>
         [ 0 swap copy ] keep
     ] new-like ;
 
-: suffix! ( seq elt -- seq ) over push ;
+: suffix! ( seq elt -- seq ) over push ; inline
 
-: append! ( seq1 seq2 -- seq1 ) over push-all ;
+: append! ( seq1 seq2 -- seq1 ) over push-all ; inline
 
 : last ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
 

core/words/words.factor

@@ -135,10 +135,13 @@ M: word reset-word
     ] tri ;
 
 : <word> ( name vocab -- word )
-    2dup [ hashcode ] bi@ bitxor >fixnum (word) ;
+    2dup [ hashcode ] bi@ bitxor >fixnum (word) dup new-word ;
+
+: <uninterned-word> ( name -- word )
+    f \ <uninterned-word> counter >fixnum (word) ;
 
 : gensym ( -- word )
-    "( gensym )" f \ gensym counter >fixnum (word) ;
+    "( gensym )" <uninterned-word> ;
 
 : define-temp ( quot effect -- word )
     [ gensym dup ] 2dip define-declared ;

extra/benchmark/fannkuch/fannkuch.factor

@@ -24,7 +24,7 @@ IN: benchmark.fannkuch
 
 : fannkuch ( n -- )
     [
-        [ 0 0 ] dip [ 1 + ] B{ } map-as
+        [ 0 0 ] dip iota [ 1 + ] B{ } map-as
         [ fannkuch-step ] each-permutation nip
     ] keep
     "Pfannkuchen(" write pprint ") = " write . ;

vm/code_heap.cpp

@@ -135,18 +135,6 @@ struct code_heap_relocator {
 	}
 };
 
-void factor_vm::increment_definition_counter()
-{
-	/* Increment redefinition counter for call( */
-	cell counter_ = special_objects[REDEFINITION_COUNTER];
-	cell counter;
-	if(counter_ == false_object)
-		counter = 0;
-	else
-		counter = untag_fixnum(counter_) + 1;
-	special_objects[REDEFINITION_COUNTER] = tag_fixnum(counter);
-}
-
 void factor_vm::primitive_modify_code_heap()
 {
 	data_root<array> alist(dpop(),this);
@@ -197,7 +185,6 @@ void factor_vm::primitive_modify_code_heap()
 	}
 
 	update_code_heap_words();
-	increment_definition_counter();
 }
 
 code_heap_room factor_vm::code_room()

vm/vm.hpp

@@ -534,7 +534,6 @@ struct factor_vm
 	void jit_compile_word(cell word_, cell def_, bool relocate);
 	void update_code_heap_words();
 	void update_code_heap_words_and_literals();
-	void increment_definition_counter();
 	void primitive_modify_code_heap();
 	code_heap_room code_room();
 	void primitive_code_room();