stack-checker: trust word declarations instead of recursively checking them

basis/compiler/compiler.factor

@@ -57,7 +57,6 @@ SYMBOLS: +optimized+ +unoptimized+ ;
         {
             [ inline? ]
             [ macro? ]
-            [ "transform-quot" word-prop ]
             [ "no-compile" word-prop ]
             [ "special" word-prop ]
         } 1||
@@ -150,4 +149,4 @@ M: optimizing-compiler recompile ( words -- alist )
     f compiler-impl set-global ;
 
 : recompile-all ( -- )
-    forget-errors all-words compile ;
+    all-words compile ;

basis/compiler/tree/builder/builder.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors quotations kernel sequences namespaces
-assocs words arrays vectors hints combinators compiler.tree
+assocs words arrays vectors hints combinators continuations
+effects compiler.tree
 stack-checker
 stack-checker.state
 stack-checker.errors
@@ -15,23 +16,27 @@ IN: compiler.tree.builder
     with-infer nip ; inline
 
 : build-tree ( quot -- nodes )
-    #! Not safe to call from inference transforms.
     [ f initial-recursive-state infer-quot ] with-tree-builder ;
 
 : build-tree-with ( in-stack quot -- nodes out-stack )
-    #! Not safe to call from inference transforms.
     [
-        [ >vector \ meta-d set ]
+        [
-        [ f initial-recursive-state infer-quot ] bi*
+            [ >vector \ meta-d set ]
-    ] with-tree-builder
+            [ f initial-recursive-state infer-quot ] bi*
-    unclip-last in-d>> ;
+        ] with-tree-builder
+        unclip-last in-d>>
+    ] [ "OOPS" USE: io print flush 3drop f f ] recover ;
 
-: build-sub-tree ( #call quot -- nodes )
+: build-sub-tree ( #call quot -- nodes/f )
     [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
-    over ends-with-terminate?
+    {
-    [ drop swap [ f swap #push ] map append ]
+        { [ over not ] [ 3drop f ] }
-    [ rot #copy suffix ]
+        { [ over ends-with-terminate? ] [ drop swap [ f swap #push ] map append ] }
-    if ;
+        [ rot #copy suffix ]
+    } cond ;
+
+: check-no-compile ( word -- )
+    dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
 
 : (build-tree-from-word) ( word -- )
     dup initial-recursive-state recursive-state set
@@ -39,24 +44,19 @@ IN: compiler.tree.builder
     [ 1quotation ] [ specialized-def ] if
     infer-quot-here ;
 
-: check-cannot-infer ( word -- )
+: check-effect ( word effect -- )
-    dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
+    over required-stack-effect 2dup effect<=
+    [ 3drop ] [ effect-error ] if ;
 
-TUPLE: do-not-compile word ;
+: finish-word ( word -- )
-
+    current-effect check-effect ;
-: check-no-compile ( word -- )
-    dup "no-compile" word-prop [ do-not-compile inference-warning ] [ drop ] if ;
 
 : build-tree-from-word ( word -- nodes )
     [
-        [
+        [ check-no-compile ]
-            {
+        [ (build-tree-from-word) ]
-                [ check-cannot-infer ]
+        [ finish-word ]
-                [ check-no-compile ]
+        tri
-                [ (build-tree-from-word) ]
-                [ finish-word ]
-            } cleave
-        ] maybe-cannot-infer
     ] with-tree-builder ;
 
 : contains-breakpoints? ( word -- ? )

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -4,6 +4,7 @@ USING: accessors kernel arrays sequences math math.order
 math.partial-dispatch generic generic.standard generic.math
 classes.algebra classes.union sets quotations assocs combinators
 words namespaces continuations classes fry combinators.smart hints
+locals
 compiler.tree
 compiler.tree.builder
 compiler.tree.recursive
@@ -27,24 +28,30 @@ SYMBOL: node-count
 SYMBOL: inlining-count
 
 ! Splicing nodes
-GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
+GENERIC: splicing-nodes ( #call word/quot/f -- nodes/f )
 
 M: word splicing-nodes
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
 
 M: callable splicing-nodes
-    build-sub-tree analyze-recursive normalize ;
+    build-sub-tree dup [ analyze-recursive normalize ] when ;
 
 ! Dispatch elimination
+: undo-inlining ( #call -- ? )
+    f >>method f >>body f >>class drop f ;
+
+: propagate-body ( #call -- ? )
+    body>> (propagate) t ;
+
 : eliminate-dispatch ( #call class/f word/quot/f -- ? )
     dup [
         [ >>class ] dip
-        over method>> over = [ drop ] [
+        over method>> over = [ drop propagate-body ] [
-            2dup splicing-nodes
+            2dup splicing-nodes dup [
-            [ >>method ] [ >>body ] bi*
+                [ >>method ] [ >>body ] bi* propagate-body
+            ] [ 2drop undo-inlining ] if
         ] if
-        body>> (propagate) t
+    ] [ 2drop undo-inlining ] if ;
-    ] [ 2drop f >>method f >>body f >>class drop f ] if ;
 
 : inlining-standard-method ( #call word -- class/f method/f )
     dup "methods" word-prop assoc-empty? [ 2drop f f ] [
@@ -159,14 +166,15 @@ SYMBOL: history
     [ history [ swap suffix ] change ]
     bi ;
 
-: inline-word-def ( #call word quot -- ? )
+:: inline-word-def ( #call word quot -- ? )
-    over history get memq? [ 3drop f ] [
+    word history get memq? [ f ] [
-        [
+        #call quot splicing-nodes [
-            [ remember-inlining ] dip
+            [
-            [ drop ] [ splicing-nodes ] 2bi
+                word remember-inlining
-            [ >>body drop ] [ count-nodes ] [ (propagate) ] tri
+                [ ] [ count-nodes ] [ (propagate) ] tri
-        ] with-scope node-count +@
+            ] with-scope
-        t
+            [ #call (>>body) ] [ node-count +@ ] bi* t
+        ] [ f ] if*
     ] if ;
 
 : inline-word ( #call word -- ? )

basis/hints/hints.factor

@@ -65,7 +65,7 @@ M: object specializer-declaration class ;
 
 SYNTAX: HINTS:
     scan-object
-    [ redefined ]
+    [ changed-definition ]
     [ parse-definition "specializer" set-word-prop ] bi ;
 
 ! Default specializers

basis/prettyprint/prettyprint-tests.factor

@@ -86,7 +86,6 @@ unit-test
     drop ;
 
 [ "drop ;" ] [
-    \ blah f "inferred-effect" set-word-prop
     [ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
 ] unit-test
 

basis/stack-checker/backend/backend.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry arrays generic io io.streams.string kernel math
 namespaces parser sequences strings vectors words quotations
 effects classes continuations assocs combinators
 compiler.errors accessors math.order definitions sets
-generic.standard.engines.tuple hints stack-checker.state
+generic.standard.engines.tuple hints macros stack-checker.state
 stack-checker.visitor stack-checker.errors stack-checker.values
 stack-checker.recursive-state ;
 IN: stack-checker.backend
@@ -121,9 +121,6 @@ M: object apply-object push-literal ;
 : infer-r> ( n -- )
     consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
 
-: undo-infer ( -- )
-    recorded get [ f "inferred-effect" set-word-prop ] each ;
-
 : (consume/produce) ( effect -- inputs outputs )
     [ in>> length consume-d ] [ out>> length produce-d ] bi ;
 
@@ -132,65 +129,29 @@ M: object apply-object push-literal ;
     [ terminated?>> [ terminate ] when ]
     bi ; inline
 
-: infer-word-def ( word -- )
-    [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
-
 : end-infer ( -- )
     meta-d clone #return, ;
 
 : required-stack-effect ( word -- effect )
     dup stack-effect [ ] [ missing-effect ] ?if ;
 
-: check-effect ( word effect -- )
-    over required-stack-effect 2dup effect<=
-    [ 3drop ] [ effect-error ] if ;
-
-: finish-word ( word -- )
-    [ current-effect check-effect ]
-    [ recorded get push ]
-    [ t "inferred-effect" set-word-prop ]
-    tri ;
-
-: cannot-infer-effect ( word -- * )
-    "cannot-infer" word-prop rethrow ;
-
-: maybe-cannot-infer ( word quot -- )
-    [ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline
-
-: infer-word ( word -- effect )
-    [
-        [
-            init-inference
-            init-known-values
-            stack-visitor off
-            dependencies off
-            generic-dependencies off
-            [ infer-word-def end-infer ]
-            [ finish-word ]
-            [ stack-effect ]
-            tri
-        ] with-scope
-    ] maybe-cannot-infer ;
-
 : apply-word/effect ( word effect -- )
     swap '[ _ #call, ] consume/produce ;
 
-: call-recursive-word ( word -- )
+: infer-word ( word -- )
-    dup required-stack-effect apply-word/effect ;
+    {
-
+        { [ dup macro? ] [ do-not-compile ] }
-: cached-infer ( word -- )
+        { [ dup "no-compile" word-prop ] [ do-not-compile ] }
-    dup stack-effect apply-word/effect ;
+        [ dup required-stack-effect apply-word/effect ]
+    } cond ;
 
 : with-infer ( quot -- effect visitor )
     [
-        [
+        init-inference
-            V{ } clone recorded set
+        init-known-values
-            init-inference
+        stack-visitor off
-            init-known-values
+        call
-            stack-visitor off
+        end-infer
-            call
+        current-effect
-            end-infer
+        stack-visitor get
-            current-effect
-            stack-visitor get
-        ] [ ] [ undo-infer ] cleanup
     ] with-scope ; inline

basis/stack-checker/call-effect/call-effect.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.private effects fry
 kernel kernel.private make sequences continuations quotations
-stack-checker stack-checker.transforms ;
+stack-checker stack-checker.transforms words ;
 IN: stack-checker.call-effect
 
 ! call( and execute( have complex expansions.
@@ -54,6 +54,8 @@ M: quotation cached-effect
 
 \ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
 
+\ call-effect-slow t "no-compile" set-word-prop
+
 : call-effect-fast ( quot effect inline-cache -- )
     2over call-effect-unsafe?
     [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
@@ -71,6 +73,8 @@ M: quotation cached-effect
     ]
 ] 0 define-transform
 
+\ call-effect t "no-compile" set-word-prop
+
 : execute-effect-slow ( word effect -- )
     [ '[ _ execute ] ] dip call-effect-slow ; inline
 
@@ -93,3 +97,5 @@ M: quotation cached-effect
     inline-cache new '[ _ _ execute-effect-ic ] ;
 
 \ execute-effect [ execute-effect>quot ] 1 define-transform
+
+\ execute-effect t "no-compile" set-word-prop

basis/stack-checker/errors/errors.factor

@@ -24,6 +24,10 @@ M: inference-error error-type type>> ;
 : inference-warning ( ... class -- * )
     +compiler-warning+ (inference-error) ; inline
 
+TUPLE: do-not-compile word ;
+
+: do-not-compile ( word -- * ) \ do-not-compile inference-warning ;
+
 TUPLE: literal-expected what ;
 
 : literal-expected ( what -- * ) \ literal-expected inference-warning ;

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

@@ -219,6 +219,8 @@ M: object infer-call*
 } [ t "special" set-word-prop ] each
 
 M\ quotation call t "no-compile" set-word-prop
+M\ curry call t "no-compile" set-word-prop
+M\ compose call t "no-compile" set-word-prop
 M\ word execute t "no-compile" set-word-prop
 \ clear t "no-compile" set-word-prop
 
@@ -230,14 +232,11 @@ M\ word execute t "no-compile" set-word-prop
         { [ dup "primitive" word-prop ] [ infer-primitive ] }
         { [ dup "transform-quot" word-prop ] [ apply-transform ] }
         { [ dup "macro" word-prop ] [ apply-macro ] }
-        { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
-        { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
         { [ dup local? ] [ infer-local-reader ] }
         { [ dup local-reader? ] [ infer-local-reader ] }
         { [ dup local-writer? ] [ infer-local-writer ] }
         { [ dup local-word? ] [ infer-local-word ] }
-        { [ dup recursive-word? ] [ call-recursive-word ] }
+        [ infer-word ]
-        [ dup infer-word apply-word/effect ]
     } cond ;
 
 : define-primitive ( word inputs outputs -- )

basis/stack-checker/recursive-state/recursive-state.factor

@@ -1,39 +1,26 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays sequences kernel sequences assocs
 namespaces stack-checker.recursive-state.tree ;
 IN: stack-checker.recursive-state
 
-TUPLE: recursive-state word words quotations inline-words ;
+TUPLE: recursive-state word quotations inline-words ;
-
-: prepare-recursive-state ( word rstate -- rstate )
-    swap >>word
-    f >>quotations
-    f >>inline-words ; inline
 
 : initial-recursive-state ( word -- state )
     recursive-state new
-        f >>words
+        swap >>word
-        prepare-recursive-state ; inline
+        f >>quotations
+        f >>inline-words ; inline
 
 f initial-recursive-state recursive-state set-global
 
-: add-recursive-state ( word -- rstate )
+: add-local-quotation ( rstate quot -- rstate )
-    recursive-state get clone
-        [ word>> dup ] keep [ store ] change-words
-        prepare-recursive-state ;
-
-: add-local-quotation ( recursive-state quot -- rstate )
     swap clone [ dupd store ] change-quotations ;
 
 : add-inline-word ( word label -- rstate )
     swap recursive-state get clone
     [ store ] change-inline-words ;
 
-: recursive-word? ( word -- ? )
-    recursive-state get 2dup word>> eq?
-    [ 2drop t ] [ words>> lookup ] if ;
-
 : inline-recursive-label ( word -- label/f )
     recursive-state get inline-words>> lookup ;
 

basis/stack-checker/stack-checker-docs.factor

@@ -109,7 +109,6 @@ HELP: inference-error
     "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
 } ;
 
-
 HELP: infer
 { $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } }
 { $description "Attempts to infer the quotation's stack effect. For interactive testing, the " { $link infer. } " word should be called instead since it presents the output in a nicely formatted manner." }
@@ -121,11 +120,3 @@ HELP: infer.
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
 
 { infer infer. } related-words
-
-HELP: forget-errors
-{ $description "Removes markers indicating which words do not have stack effects."
-$nl
-"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
-{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
-{ $code "forget-errors" }
-"Subsequent invocations of the compiler will consider all words for compilation." } ;

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

@@ -588,3 +588,7 @@ DEFER: eee'
 [ forget-test ] must-infer
 [ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
 [ forget-test ] must-infer
+
+[ [ cond ] infer ] must-fail
+[ [ bi ] infer ] must-fail
+[ at ] must-infer

basis/stack-checker/stack-checker.factor

@@ -16,17 +16,4 @@ M: callable infer ( quot -- effect )
     #! Safe to call from inference transforms.
     infer effect>string print ;
 
-: forget-errors ( -- )
-    all-words [
-        dup subwords [ f "cannot-infer" set-word-prop ] each
-        f "cannot-infer" set-word-prop
-    ] each ;
-
-: forget-effects ( -- )
-    forget-errors
-    all-words [
-        dup subwords [ f "inferred-effect" set-word-prop ] each
-        f "inferred-effect" set-word-prop
-    ] each ;
-
 "stack-checker.call-effect" require

basis/stack-checker/state/state.factor

@@ -64,6 +64,3 @@ SYMBOL: generic-dependencies
 : depends-on-generic ( generic class -- )
     generic-dependencies get dup
     [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
-
-! Words we've inferred the stack effect of, for rollback
-SYMBOL: recorded

basis/stack-checker/transforms/transforms.factor

@@ -10,13 +10,6 @@ stack-checker.state stack-checker.visitor stack-checker.errors
 stack-checker.values stack-checker.recursive-state ;
 IN: stack-checker.transforms
 
-: give-up-transform ( word -- )
-    {
-        { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
-        { [ dup recursive-word? ] [ call-recursive-word ] }
-        [ dup infer-word apply-word/effect ]
-    } cond ;
-
 : call-transformer ( word stack quot -- newquot )
     '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
     [ transform-expansion-error ]
@@ -29,7 +22,7 @@ IN: stack-checker.transforms
         word inlined-dependency depends-on
         values [ length meta-d shorten-by ] [ #drop, ] bi
         rstate infer-quot
-    ] [ word give-up-transform ] if* ;
+    ] [ word infer-word ] if* ;
 
 : literals? ( values -- ? ) [ literal-value? ] all? ;
 
@@ -41,7 +34,7 @@ IN: stack-checker.transforms
             [ first literal recursion>> ] tri
         ] if
         ((apply-transform))
-    ] [ 2drop give-up-transform ] if ;
+    ] [ 2drop infer-word ] if ;
 
 : apply-transform ( word -- )
     [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
@@ -59,6 +52,8 @@ IN: stack-checker.transforms
 ! Combinators
 \ cond [ cond>quot ] 1 define-transform
 
+\ cond t "no-compile" set-word-prop
+
 \ case [
     [
         [ no-case ]
@@ -71,14 +66,24 @@ IN: stack-checker.transforms
     ] if-empty
 ] 1 define-transform
 
+\ case t "no-compile" set-word-prop
+
 \ cleave [ cleave>quot ] 1 define-transform
 
+\ cleave t "no-compile" set-word-prop
+
 \ 2cleave [ 2cleave>quot ] 1 define-transform
 
+\ 2cleave t "no-compile" set-word-prop
+
 \ 3cleave [ 3cleave>quot ] 1 define-transform
 
+\ 3cleave t "no-compile" set-word-prop
+
 \ spread [ spread>quot ] 1 define-transform
 
+\ spread t "no-compile" set-word-prop
+
 \ (call-next-method) [
     [
         [ "method-class" word-prop ]
@@ -90,6 +95,8 @@ IN: stack-checker.transforms
     ] bi
 ] 1 define-transform
 
+\ (call-next-method) t "no-compile" set-word-prop
+
 ! Constructors
 \ boa [
     dup tuple-class? [
@@ -100,6 +107,9 @@ IN: stack-checker.transforms
     ] [ drop f ] if
 ] 1 define-transform
 
+\ boa t "no-compile" set-word-prop
+M\ tuple-class boa t "no-compile" set-word-prop
+
 \ new [
     dup tuple-class? [
         dup inlined-dependency depends-on

basis/tools/deploy/shaker/shaker.factor

@@ -97,7 +97,6 @@ IN: tools.deploy.shaker
             {
                 "alias"
                 "boa-check"
-                "cannot-infer"
                 "coercer"
                 "combination"
                 "compiled-status"
@@ -116,7 +115,6 @@ IN: tools.deploy.shaker
                 "identities"
                 "if-intrinsics"
                 "infer"
-                "inferred-effect"
                 "inline"
                 "inlined-block"
                 "input-classes"

core/classes/classes.factor

@@ -135,7 +135,7 @@ M: sequence implementors [ implementors ] gather ;
             [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
             [ reset-class ]
             [ ?define-symbol ]
-            [ redefined ]
+            [ changed-definition ]
             [ ]
         } cleave
     ] dip [ assoc-union ] curry change-props

core/classes/tuple/tuple.factor

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

core/words/words-docs.factor

@@ -104,10 +104,6 @@ $nl
     
     { { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } }
 
-    { { $snippet "\"infer\"" } { $link "macros" } }
-
-    { { { $snippet "\"inferred-effect\"" } } { $link "inference" } }
-
     { { $snippet "\"specializer\"" } { $link "hints" } }
     
     { { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" }

core/words/words.factor

@@ -131,43 +131,10 @@ GENERIC: subwords ( word -- seq )
 
 M: word subwords drop f ;
 
-<PRIVATE
-
-SYMBOL: visited
-
-CONSTANT: reset-on-redefine { "inferred-effect" "cannot-infer" }
-
-: relevant-callers ( word -- seq )
-    crossref get at keys
-    [ word? ] filter
-    [
-        [ reset-on-redefine [ word-prop ] with any? ]
-        [ inline? ]
-        bi or
-    ] filter ;
-
-: (redefined) ( word -- )
-    dup visited get key? [ drop ] [
-        [ reset-on-redefine reset-props ]
-        [ visited get conjoin ]
-        [
-            [ relevant-callers [ (redefined) ] each ]
-            [ subwords [ (redefined) ] each ]
-            bi
-        ] tri
-    ] if ;
-
-PRIVATE>
-
-: redefined ( word -- )
-    [ H{ } clone visited [ (redefined) ] with-variable ]
-    [ changed-definition ]
-    bi ;
-
 : define ( word def -- )
     [ ] like
     over unxref
-    over redefined
+    over changed-definition
     >>def
     dup crossref? [ dup xref ] when drop ;
 
@@ -176,7 +143,7 @@ PRIVATE>
         swap
         [ drop changed-effect ]
         [ "declared-effect" set-word-prop ]
-        [ drop dup primitive? [ drop ] [ redefined ] if ]
+        [ drop dup primitive? [ drop ] [ changed-definition ] if ]
         2tri
     ] if ;