diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 19d80ec14f..65e9ccdff6 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -12,12 +12,13 @@ IN: compiler.tree.builder : build-tree ( quot -- nodes ) #! Not safe to call from inference transforms. - [ f infer-quot ] with-tree-builder nip ; + [ f initial-recursive-state infer-quot ] with-tree-builder nip ; : build-tree-with ( in-stack quot -- nodes out-stack ) #! Not safe to call from inference transforms. [ - [ >vector meta-d set ] [ f infer-quot ] bi* + [ >vector meta-d set ] + [ f initial-recursive-state infer-quot ] bi* ] with-tree-builder nip unclip-last in-d>> ; @@ -32,10 +33,10 @@ IN: compiler.tree.builder dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and [ - 1quotation f infer-quot + 1quotation f initial-recursive-state infer-quot ] [ - [ specialized-def ] - [ dup 2array 1array ] bi infer-quot + [ specialized-def ] [ initial-recursive-state ] bi + infer-quot ] if ; : check-cannot-infer ( word -- ) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index aadd1adbd4..250ee2cb7a 100644 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -82,9 +82,6 @@ M: object apply-object push-literal ; infer-quot-here ] dip recursive-state set ; -: infer-quot-recursive ( quot word label -- ) - 2array recursive-state get swap prefix infer-quot ; - : time-bomb ( error -- ) '[ _ throw ] infer-quot-here ; @@ -97,7 +94,7 @@ M: object apply-object push-literal ; ] [ dup value>> callable? [ [ value>> ] - [ [ recursion>> ] keep f 2array prefix ] + [ [ recursion>> ] keep add-local-quotation ] bi infer-quot ] [ drop bad-call @@ -126,6 +123,9 @@ M: object apply-object push-literal ; terminated?>> [ terminate ] when ] 2bi ; inline +: infer-word-def ( word -- ) + [ def>> ] [ add-recursive-state ] bi infer-quot ; + : check->r ( -- ) meta-r get empty? terminated? get or [ \ too-many->r inference-error ] unless ; @@ -174,7 +174,7 @@ M: object apply-object push-literal ; stack-visitor off dependencies off generic-dependencies off - [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ] + [ infer-word-def end-infer ] [ finish-word current-effect ] bi ] with-scope diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index bab6c17c85..b728d1a7e9 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -2,11 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel generic sequences prettyprint io words arrays summary effects debugger assocs accessors namespaces -compiler.errors ; +compiler.errors stack-checker.state ; IN: stack-checker.errors -SYMBOL: recursive-state - TUPLE: inference-error error type rstate ; M: inference-error compiler-error-type type>> ; @@ -35,6 +33,8 @@ TUPLE: literal-expected ; M: literal-expected summary drop "Literal value expected" ; +M: object (literal) \ literal-expected inference-warning ; + TUPLE: unbalanced-branches-error branches quots ; : unbalanced-branches-error ( branches quots -- * ) diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index 7847fdfdcf..695eb4f0d3 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -14,8 +14,8 @@ IN: stack-checker.inlining ! Code to handle inline words. Much of the complexity stems from ! having to handle recursive inline words. -: (inline-word) ( word label -- ) - [ [ def>> ] keep ] dip infer-quot-recursive ; +: infer-inline-word-def ( word label -- ) + [ drop def>> ] [ add-local-recursive-state ] 2bi infer-quot ; TUPLE: inline-recursive < identity-tuple id @@ -88,7 +88,7 @@ SYMBOL: enter-out nest-visitor dup - [ dup emit-enter-recursive (inline-word) ] + [ dup emit-enter-recursive infer-inline-word-def ] [ end-recursive-word ] [ nip ] 2tri @@ -133,20 +133,23 @@ SYMBOL: enter-out object '[ _ prepend ] bi@ ; -: call-recursive-inline-word ( word -- ) - dup "recursive" word-prop [ - [ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri - [ 2nip check-call ] [ nip '[ _ #call-recursive, ] consume/produce ] 3bi - ] [ undeclared-recursion-error inference-error ] if ; +: call-recursive-inline-word ( word label -- ) + over "recursive" word-prop [ + [ required-stack-effect adjust-stack-effect ] dip + [ check-call ] [ '[ _ #call-recursive, ] consume/produce ] bi + ] [ drop undeclared-recursion-error inference-error ] if ; : inline-word ( word -- ) [ inlined-dependency depends-on ] [ - { - { [ dup inline-recursive-label ] [ call-recursive-inline-word ] } - { [ dup "recursive" word-prop ] [ inline-recursive-word ] } - [ dup (inline-word) ] - } cond + dup inline-recursive-label [ + call-recursive-inline-word + ] [ + dup "recursive" word-prop + [ inline-recursive-word ] + [ dup infer-inline-word-def ] + if + ] if* ] bi ; M: word apply-object diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 257181f6ad..ecc9f95f54 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -195,7 +195,7 @@ do-primitive alien-invoke alien-indirect alien-callback { [ dup local? ] [ infer-local-reader ] } { [ dup local-reader? ] [ infer-local-reader ] } { [ dup local-writer? ] [ infer-local-writer ] } - { [ dup recursive-label ] [ call-recursive-word ] } + { [ dup recursive-word? ] [ call-recursive-word ] } [ dup infer-word apply-word/effect ] } cond ; diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 11dc6f9ef8..177731f985 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -1,10 +1,38 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs namespaces sequences kernel definitions math -effects accessors words fry classes.algebra stack-checker.errors +USING: assocs arrays namespaces sequences kernel definitions +math effects accessors words fry classes.algebra compiler.units ; IN: stack-checker.state +! Recursive state +SYMBOL: recursive-state + +: initial-recursive-state ( word -- state ) + { } { } 3array 1array ; inline + +f initial-recursive-state recursive-state set-global + +: add-recursive-state ( word -- rstate ) + [ recursive-state get ] dip { } { } 3array prefix ; + +: add-local-quotation ( recursive-state quot -- rstate ) + [ unclip first3 swap ] dip prefix swap 3array prefix ; + +: add-local-recursive-state ( word label -- rstate ) + [ recursive-state get ] 2dip + [ unclip first3 ] 2dip 2array prefix 3array prefix ; + +: recursive-word? ( word -- ? ) + recursive-state get key? ; + +: inline-recursive-label ( word -- label/f ) + recursive-state get first third at ; + +: recursive-quotation? ( quot -- ? ) + recursive-state get first second [ eq? ] with contains? ; + +! Values : ( -- value ) \ counter ; SYMBOL: known-values @@ -29,9 +57,12 @@ TUPLE: literal < identity-tuple value recursion ; : ( obj -- value ) recursive-state get \ literal boa ; +GENERIC: (literal) ( value -- literal ) + +M: literal (literal) ; + : literal ( value -- literal ) - known dup literal? - [ \ literal-expected inference-warning ] unless ; + known (literal) ; ! Result of curry TUPLE: curried obj quot ; @@ -71,20 +102,6 @@ SYMBOL: meta-r : init-known-values ( -- ) H{ } clone known-values set ; -: recursive-label ( word -- label/f ) - recursive-state get at ; - -: local-recursive-state ( -- assoc ) - recursive-state get dup - [ first dup word? [ inline? ] when not ] find drop - [ head-slice ] when* ; - -: inline-recursive-label ( word -- label/f ) - local-recursive-state at ; - -: recursive-quotation? ( quot -- ? ) - local-recursive-state [ first eq? ] with contains? ; - ! Words that the current quotation depends on SYMBOL: dependencies @@ -98,9 +115,12 @@ SYMBOL: dependencies ! Generic words that the current quotation depends on SYMBOL: generic-dependencies +: ?class-or ( class/f class -- class' ) + swap [ class-or ] when* ; + : depends-on-generic ( generic class -- ) generic-dependencies get dup - [ swap '[ null or _ class-or ] change-at ] [ 3drop ] if ; + [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ; ! Words we've inferred the stack effect of, for rollback SYMBOL: recorded diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index abc3ae1950..c71337b021 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -9,7 +9,7 @@ stack-checker.errors ; IN: stack-checker.transforms : give-up-transform ( word -- ) - dup recursive-label + dup recursive-word? [ call-recursive-word ] [ dup infer-word apply-word/effect ] if ;