From 339cc8f04e88b6d5fd47607c2e06ba6727f76319 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 7 Mar 2010 11:44:44 -0800 Subject: [PATCH] row polymorphism new approach: wrap polymorphic quotation inputs in a "declared-effect" value. M\ declared-effect infer-call* will then assert the effect of declared-effect values during the normal course of stack inference --- basis/stack-checker/branches/branches.factor | 11 +- basis/stack-checker/inlining/inlining.factor | 2 +- .../known-words/known-words.factor | 10 ++ .../row-polymorphism-tests.factor | 80 ------------- .../row-polymorphism/row-polymorphism.factor | 108 ++++-------------- .../stack-checker/stack-checker-tests.factor | 4 +- basis/stack-checker/values/values.factor | 35 +++++- 7 files changed, 77 insertions(+), 173 deletions(-) delete mode 100644 basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 99e5a70409..2862b03f20 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -91,6 +91,9 @@ M: literal infer-branch [ value>> quotation set ] [ infer-literal-quot ] bi ] H{ } make-assoc ; +M: declared-effect infer-branch + value>> infer-branch ; + M: callable infer-branch [ copy-inference @@ -107,12 +110,18 @@ M: callable infer-branch infer-branches [ first2 #if, ] dip compute-phi-function ; +GENERIC: curried/composed? ( known -- ? ) +M: object curried/composed? drop f ; +M: curried curried/composed? drop t ; +M: composed curried/composed? drop t ; +M: declared-effect curried/composed? value>> known curried/composed? ; + : infer-if ( -- ) 2 literals-available? [ (infer-if) ] [ drop 2 consume-d - dup [ known [ curried? ] [ composed? ] bi or ] any? [ + dup [ known curried/composed? ] any? [ output-d [ rot [ drop call ] [ nip call ] if ] infer-quot-here diff --git a/basis/stack-checker/inlining/inlining.factor b/basis/stack-checker/inlining/inlining.factor index b1d6b6d9ef..c83f609868 100644 --- a/basis/stack-checker/inlining/inlining.factor +++ b/basis/stack-checker/inlining/inlining.factor @@ -142,7 +142,7 @@ SYMBOL: enter-out : inline-word ( word -- ) commit-literals [ depends-on-definition ] - [ infer-polymorphic? get [ check-polymorphic-effect ] [ drop ] if ] + [ declare-input-effects ] [ dup inline-recursive-label [ call-recursive-inline-word diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index e93dca9072..03c45b9487 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -98,6 +98,16 @@ M: composed infer-call* 1 infer->r infer-call terminated? get [ 1 infer-r> infer-call ] unless ; +: Pdeclared-effect ( x -- x ) + dup + [ word>> P. ] + [ effect>> P. ] + [ value>> known known>callable P. ] tri ; + +M: declared-effect infer-call* + Pdeclared-effect + nip value>> (infer-call) ; + M: input-parameter infer-call* \ call unknown-macro-input ; M: object infer-call* \ call bad-macro-input ; diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor b/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor deleted file mode 100644 index a5572336c0..0000000000 --- a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor +++ /dev/null @@ -1,80 +0,0 @@ -! (c)2010 Joe Groff bsd license -USING: accessors effects fry io kernel make math namespaces sequences -splitting system tools.test -stack-checker -stack-checker.backend -stack-checker.errors -stack-checker.row-polymorphism -stack-checker.state -stack-checker.values ; -FROM: splitting.private => split, ; -IN: stack-checker.row-polymorphism.tests - -: infer-polymorphic-quot ( quot -- vars ) - t infer-polymorphic? [ - unclip-last [ - dup current-word set - init-inference - init-known-values - [ [ [ set-known ] [ push-d ] bi ] each ] - [ stack-effect ] bi* - infer-polymorphic-vars - ] with-scope - ] with-variable ; - -: test-poly-infer ( effect quot -- ) - [ '[ _ ] ] [ '[ _ infer-polymorphic-quot ] ] bi* unit-test ; inline - -: poly-infer-must-fail ( quot -- ) - '[ _ infer-polymorphic-quot ] [ invalid-quotation-input? ] must-fail-with ; inline -: poly-infer-must-fail-unknown ( quot -- ) - '[ _ infer-polymorphic-quot ] [ unknown-macro-input? ] must-fail-with ; inline - -H{ { "." 0 } } [ [ write ] each ] test-poly-infer -H{ { "." 1 } } [ [ append ] each ] test-poly-infer -H{ { "." 0 } } [ [ ] map ] test-poly-infer -H{ { "." 0 } } [ [ reverse ] map ] test-poly-infer -H{ { "." 1 } } [ [ append dup ] map ] test-poly-infer -H{ { "." 1 } } [ [ swap nth suffix dup ] map-index ] test-poly-infer - -H{ { "a" 3 } { "b" 1 } } [ [ 2drop ] [ 2nip ] if ] test-poly-infer -H{ { "a" 2 } { "b" 3 } } [ [ dup ] [ over ] if ] test-poly-infer -H{ { "a" 0 } { "b" 1 } } [ [ os ] [ cpu ] if ] test-poly-infer -H{ { "a" 1 } { "b" 2 } } [ [ os ] [ 1 + cpu ] if ] test-poly-infer - -H{ { "a" 0 } { "b" 0 } } [ [ write ] [ "(f)" write ] if* ] test-poly-infer -H{ { "a" 0 } { "b" 1 } } [ [ ] [ f ] if* ] test-poly-infer -H{ { "a" 1 } { "b" 1 } } [ [ nip ] [ drop f ] if* ] test-poly-infer -H{ { "a" 1 } { "b" 1 } } [ [ nip ] [ ] if* ] test-poly-infer -H{ { "a" 2 } { "b" 2 } } [ [ 3append f ] [ ] if* ] test-poly-infer -H{ { "a" 0 } { "b" 0 } } [ [ drop ] [ ] if* ] test-poly-infer - -H{ { "a" 0 } { "b" 1 } } [ [ 1 + ] [ "oops" throw ] if* ] test-poly-infer - -H{ } [ [ [ member? ] curry split, ] { } make ] test-poly-infer - -[ (( x x -- x )) ] [ - t infer-polymorphic? [ - [ [ [ member? ] curry split, ] { } make ] infer - ] with-variable -] unit-test - -[ [ write write ] each ] poly-infer-must-fail -[ [ ] each ] poly-infer-must-fail -[ [ dup ] map ] poly-infer-must-fail -[ [ drop ] map ] poly-infer-must-fail -[ [ 1 + ] map-index ] poly-infer-must-fail - -[ [ dup ] [ ] if ] poly-infer-must-fail -[ [ 2dup ] [ over ] if ] poly-infer-must-fail -[ [ drop ] [ ] if ] poly-infer-must-fail - -[ [ ] [ ] if* ] poly-infer-must-fail -[ [ dup ] [ ] if* ] poly-infer-must-fail -[ [ drop ] [ drop ] if* ] poly-infer-must-fail -[ [ ] [ drop ] if* ] poly-infer-must-fail -[ [ ] [ 2dup ] if* ] poly-infer-must-fail - -[ each ] poly-infer-must-fail-unknown -[ [ "derp" ] if ] poly-infer-must-fail-unknown - diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 85d151d478..5f798b1760 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -10,94 +10,26 @@ stack-checker.values stack-checker.visitor ; IN: stack-checker.row-polymorphism - d-length + n d-length < [ + d-length 1 - n - :> n' + n' meta-d [| value | + value word effect variables :> known' + :> value' + known' value' set-known + value' + ] change-nth + ] [ word unknown-macro-input ] if ; -SYMBOL: (unknown) +:: declare-input-effects ( word -- ) + H{ } clone :> variables + word stack-effect in>> [| in n | + in ?quotation-effect [| effect | + word effect variables n declare-effect-d + ] when* + ] each-index ; -GENERIC: >error-quot ( known -- quot ) - -M: object >error-quot drop (unknown) ; -M: literal >error-quot value>> ; -M: composed >error-quot - [ quot1>> known >error-quot ] [ quot2>> known >error-quot ] bi - \ compose [ ] 3sequence ; -M: curried >error-quot - [ obj>> known >error-quot ] [ quot>> known >error-quot ] bi - \ curry [ ] 3sequence ; - -: >error-branches-and-quots ( branch/values -- branches quots ) - [ [ second ] [ known >error-quot ] bi* ] assoc-map unzip ; - -: abandon-check ( -- * ) - current-word get - current-word-effect get in>> current-meta-d get zip - [ first quotation-effect? ] filter - >error-branches-and-quots - invalid-quotation-input ; - -:: check-variable ( actual-count declared-count variable -- difference ) - actual-count declared-count - - variable [ - variable current-effect-variables get at* nip - [ variable current-effect-variables get at - ] - [ variable current-effect-variables get set-at 0 ] if - ] [ - dup [ abandon-check ] unless-zero - ] if ; - -: adjust-variable ( diff var -- ) - over 0 >= - [ current-effect-variables get at+ ] - [ 2drop ] if ; inline - -:: (check-input) ( declared actual -- ) - actual terminated?>> [ - actual declared [ in>> length ] bi@ declared in-var>> - [ check-variable ] keep :> ( in-diff in-var ) - actual declared [ out>> length ] bi@ declared out-var>> - [ check-variable ] keep :> ( out-diff out-var ) - { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0|| - [ - in-var [ in-diff swap adjust-variable ] when* - out-var [ out-diff swap adjust-variable ] when* - ] [ - abandon-check - ] if - ] unless ; - -: infer-value ( value -- effect ) - dup known [ nest-visitor init-inference infer-call* current-effect ] with-scope ; inline - -: check-input ( in value -- ) - over quotation-effect? [ - [ second ] dip infer-value (check-input) - ] [ 2drop ] if ; - -: normalize-variables ( -- variables' ) - current-effect-variables get dup values [ - infimum dup 0 < - [ '[ _ - ] assoc-map ] [ drop ] if - ] unless-empty ; - -PRIVATE> - -: infer-polymorphic-vars ( effect -- variables ) - H{ } clone current-effect-variables set - dup current-word-effect set - in>> dup length ensure-d dup current-meta-d set - [ check-input ] 2each - normalize-variables ; - -: check-polymorphic-effect ( word -- ) - current-word get [ - dup current-word set - stack-effect dup { [ in-var>> ] [ out-var>> ] } 1|| - [ infer-polymorphic-vars ] when drop - ] dip current-word set ; - -SYMBOL: infer-polymorphic? -infer-polymorphic? [ t ] initialize diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 270e5695b3..cf0210821e 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -378,7 +378,9 @@ DEFER: eee' [ [ cond ] infer ] [ T{ unknown-macro-input f cond } = ] must-fail-with [ [ bi ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with -[ [ each ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with + +[ [ each ] infer ] [ T{ unknown-macro-input f each } = ] must-fail-with +[ [ if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with [ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 7e11ec3edb..53f9e307eb 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces kernel assocs sequences -stack-checker.recursive-state stack-checker.errors ; +stack-checker.recursive-state stack-checker.errors +quotations ; IN: stack-checker.values ! Values @@ -97,9 +98,39 @@ M: input-parameter (literal-value?) drop f ; M: input-parameter (literal) current-word get unknown-macro-input ; +! Argument corresponding to polymorphic declared input of inline combinator + +TUPLE: declared-effect value word effect variables ; + +C: declared-effect + +M: declared-effect (input-value?) value>> input-value? ; + +M: declared-effect (literal-value?) value>> literal-value? ; + +M: declared-effect (literal) value>> literal ; + ! Computed values M: f (input-value?) drop f ; M: f (literal-value?) drop f ; -M: f (literal) current-word get bad-macro-input ; \ No newline at end of file +M: f (literal) current-word get bad-macro-input ; + +SYMBOL: (_) +ERROR: (@) ; + +GENERIC: known>callable ( known -- quot ) + +: ?@ ( x -- y ) + dup callable? [ drop [ (@) ] ] unless ; + +M: object known>callable drop (_) ; +M: literal known>callable value>> ; +M: composed known>callable + [ quot1>> known known>callable ?@ ] [ quot2>> known known>callable ?@ ] bi + append ; +M: curried known>callable + [ quot>> known known>callable ] [ obj>> known known>callable ] bi + prefix ; +