]> gitweb.factorcode.org Git - factor.git/commitdiff
Remove "compiled-status" word prop and simplify associated machinery
authorSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Tue, 21 Apr 2009 08:23:11 +0000 (03:23 -0500)
committerSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Tue, 21 Apr 2009 08:23:11 +0000 (03:23 -0500)
basis/compiler/compiler.factor
basis/macros/macros.factor
basis/tools/deploy/shaker/shaker.factor
core/definitions/definitions.factor
core/words/words.factor

index b8ba620f32fb784d8138b062c3c0bd5434700340..717f66ba8814d182cddb60c416aa916c2406498f 100644 (file)
@@ -28,23 +28,14 @@ SYMBOL: compiled
 : maybe-compile ( word -- )
     dup optimized>> [ drop ] [ queue-compile ] if ;
 
-SYMBOLS: +optimized+ +unoptimized+ ;
+: recompile-callers? ( word -- ? )
+    changed-effects get key? ;
 
-: ripple-up ( words -- )
-    dup "compiled-status" word-prop +unoptimized+ eq?
-    [ usage [ word? ] filter ] [ compiled-usage keys ] if
-    [ queue-compile ] each ;
-
-: ripple-up? ( status word -- ? )
-    [
-        [ nip changed-effects get key? ]
-        [ "compiled-status" word-prop eq? not ] 2bi or
-    ] keep "compiled-status" word-prop and ;
-
-: save-compiled-status ( word status -- )
-    [ over ripple-up? [ ripple-up ] [ drop ] if ]
-    [ "compiled-status" set-word-prop ]
-    2bi ;
+: recompile-callers ( words -- )
+    dup recompile-callers? [
+        [ usage [ word? ] filter ] [ compiled-usage keys ] bi
+        [ [ queue-compile ] each ] bi@
+    ] [ drop ] if ;
 
 : start ( word -- )
     "trace-compilation" get [ dup name>> print flush ] when
@@ -55,20 +46,19 @@ SYMBOLS: +optimized+ +unoptimized+ ;
 : ignore-error? ( word error -- ? )
     [
         {
-            [ inline? ]
             [ macro? ]
-            [ "no-compile" word-prop ]
+            [ inline? ]
             [ "special" word-prop ]
+            [ "no-compile" word-prop ]
         } 1||
     ] [ error-type +compiler-warning+ eq? ] bi* and ;
 
 : (fail) ( word compiled -- * )
     swap
+    [ recompile-callers ]
     [ compiled-unxref ]
     [ compiled get set-at ]
-    [ +unoptimized+ save-compiled-status ]
-    tri
-    return ;
+    tri return ;
 
 : not-compiled-def ( word error -- def )
     '[ _ _ not-compiled ] [ ] like ;
@@ -106,11 +96,10 @@ t compile-dependencies? set-global
     ] each ;
 
 : finish ( word -- )
-    [ +optimized+ save-compiled-status ]
+    [ recompile-callers ]
     [ compiled-unxref ]
     [
-        dup crossref?
-        [
+        dup crossref? [
             dependencies get
             generic-dependencies get
             compiled-xref
index a86b711340526c4b19b12d68005abd66d19c0d36..0e5ef30f51cf4a13d77a0071cb63a49bff5b75f9 100644 (file)
@@ -12,10 +12,11 @@ IN: macros
 PRIVATE>
 
 : define-macro ( word definition effect -- )
-    real-macro-effect
-    [ [ memoize-quot [ call ] append ] keep define-declared ]
-    [ drop "macro" set-word-prop ]
-    3bi ;
+    real-macro-effect {
+        [ [ memoize-quot [ call ] append ] keep define-declared ]
+        [ drop "macro" set-word-prop ]
+        [ 2drop changed-effect ]
+    } 3cleave ;
 
 SYNTAX: MACRO: (:) define-macro ;
 
index 807abe4d580ad16c073020b79957a3fc1b414e17..0d7d8fd7c68455bc8cdb8d9d86445a8de4c68566 100755 (executable)
@@ -99,7 +99,6 @@ IN: tools.deploy.shaker
                 "boa-check"
                 "coercer"
                 "combination"
-                "compiled-status"
                 "compiled-generic-uses"
                 "compiled-uses"
                 "constraints"
index 7463a863e5b466201ee47163c95db9c10ef4f607..1a26e45e878446982d179d1febde86c153daeff2 100644 (file)
@@ -19,9 +19,6 @@ SYMBOL: changed-definitions
 
 SYMBOL: changed-effects
 
-: changed-effect ( word -- )
-    dup changed-effects get set-in-unit ;
-
 SYMBOL: changed-generics
 
 SYMBOL: outdated-generics
index 97225c0f75a4b3707ef0bb27078b448bdc6539cf..1a2317997a4f3fe1b5c5aa743aeed68fafe76c13 100755 (executable)
@@ -138,12 +138,15 @@ M: word subwords drop f ;
     >>def
     dup crossref? [ dup xref ] when drop ;
 
+: changed-effect ( word -- )
+    [ dup changed-effects get set-in-unit ]
+    [ dup primitive? [ drop ] [ changed-definition ] if ] bi ;
+
 : set-stack-effect ( effect word -- )
     2dup "declared-effect" word-prop = [ 2drop ] [
-        swap
-        [ drop changed-effect ]
-        [ "declared-effect" set-word-prop ]
-        [ drop dup primitive? [ drop ] [ changed-definition ] if ]
+        [ nip changed-effect ]
+        [ nip subwords [ changed-effect ] each ]
+        [ swap "declared-effect" set-word-prop ]
         2tri
     ] if ;
 
@@ -151,7 +154,11 @@ M: word subwords drop f ;
     [ nip swap set-stack-effect ] [ drop define ] 3bi ;
 
 : make-inline ( word -- )
-    t "inline" set-word-prop ;
+    dup inline? [ drop ] [
+        [ t "inline" set-word-prop ]
+        [ changed-effect ]
+        bi
+    ] if ;
 
 : make-recursive ( word -- )
     t "recursive" set-word-prop ;