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

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

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel
-compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ;
+compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences
+eval combinators ;
 IN: compiler.tree.propagation.call-effect.tests
 
 [ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
@@ -58,4 +59,23 @@ IN: compiler.tree.propagation.call-effect.tests
 ! [ boa ] by itself doesn't infer
 TUPLE: a-tuple x ;
 
-[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
+[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
+
+! See if redefinitions are handled correctly
+: call(-redefine-test ( a -- b ) 1 + ;
+
+: test-quotatation ( -- quot ) [ call(-redefine-test ] ;
+
+[ t ] [ test-quotatation cached-effect (( a -- b )) effect<= ] unit-test
+
+[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a b -- c ) + ;" eval( -- ) ] unit-test
+
+[ t ] [ test-quotatation cached-effect (( a b -- c )) effect<= ] unit-test
+
+: inline-cache-invalidation-test ( a b c -- c ) call( a b -- c ) ;
+
+[ 4 ] [ 1 3 test-quotatation inline-cache-invalidation-test ] unit-test
+
+[ ] [ "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

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

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.private effects fry
 kernel kernel.private make sequences continuations quotations
-words math stack-checker stack-checker.transforms
-compiler.tree.propagation.info
+words math stack-checker combinators.short-circuit
+stack-checker.transforms compiler.tree.propagation.info
 compiler.tree.propagation.inlining ;
 IN: compiler.tree.propagation.call-effect
 
@@ -18,10 +18,20 @@ IN: compiler.tree.propagation.call-effect
 
 ! execute( uses a similar strategy.
 
-TUPLE: inline-cache value ;
+: definition-counter ( -- n ) 46 getenv ; inline
 
-: cache-hit? ( word/quot ic -- ? )
-    [ value>> eq? ] [ value>> ] bi and ; inline
+TUPLE: inline-cache value counter ;
+
+: inline-cache-hit? ( word/quot ic -- ? )
+    {
+        [ nip value>> ]
+        [ value>> eq? ]
+        [ nip counter>> definition-counter eq? ]
+    } 2&& ; inline
+
+: update-inline-cache ( word/quot ic -- )
+    [ definition-counter ] dip
+    [ (>>value) ] [ (>>counter) ] bi-curry bi* ; inline
 
 SINGLETON: +unknown+
 
@@ -53,9 +63,16 @@ M: compose cached-effect
 : safe-infer ( quot -- effect )
     [ infer ] [ 2drop +unknown+ ] recover ;
 
+: cached-effect-valid? ( quot -- ? )
+    cache-counter>> definition-counter eq? ; inline
+
+: save-effect ( effect quot -- )
+    [ definition-counter ] dip
+    [ (>>cached-effect) ] [ (>>cache-counter) ] bi-curry bi* ;
+
 M: quotation cached-effect
-    dup cached-effect>>
-    [ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ;
+    dup cached-effect-valid?
+    [ cached-effect>> ] [ [ safe-infer dup ] keep save-effect ] if ;
 
 : call-effect-unsafe? ( quot effect -- ? )
     [ cached-effect ] dip
@@ -82,12 +99,12 @@ M: quotation cached-effect
 
 : call-effect-fast ( quot effect inline-cache -- )
     2over call-effect-unsafe?
-    [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
+    [ [ nip update-inline-cache ] [ drop call-effect-unsafe ] 3bi ]
     [ drop call-effect-slow ]
     if ; inline
 
 : call-effect-ic ( quot effect inline-cache -- )
-    3dup nip cache-hit?
+    3dup nip inline-cache-hit?
     [ drop call-effect-unsafe ]
     [ call-effect-fast ]
     if ; inline
@@ -103,12 +120,12 @@ M: quotation cached-effect
 
 : execute-effect-fast ( word effect inline-cache -- )
     2over execute-effect-unsafe?
-    [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
+    [ [ nip update-inline-cache ] [ drop execute-effect-unsafe ] 3bi ]
     [ drop execute-effect-slow ]
     if ; inline
 
 : execute-effect-ic ( word effect inline-cache -- )
-    3dup nip cache-hit?
+    3dup nip inline-cache-hit?
     [ drop execute-effect-unsafe ]
     [ execute-effect-fast ]
     if ; inline

vm/code_heap.cpp

@@ -135,6 +135,18 @@ 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);
@@ -185,6 +197,7 @@ void factor_vm::primitive_modify_code_heap()
 	}
 
 	update_code_heap_words();
+	increment_definition_counter();
 }
 
 code_heap_room factor_vm::code_room()

vm/objects.hpp

@@ -61,6 +61,10 @@ enum special_object {
 
 	/* Callback stub generation in callbacks.c */
 	CALLBACK_STUB       = 45,
+	
+	/* Incremented on every modify-code-heap call; invalidates call( inline
+	caching */
+	REDEFINITION_COUNTER = 46,
 
 	/* Polymorphic inline cache generation in inline_cache.c */
 	PIC_LOAD            = 47,

vm/vm.hpp

@@ -534,6 +534,7 @@ 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();