From e5cdb7ac2db9a7f0fa95aafc06fcd2d903ea6923 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 21:08:29 -0500 Subject: [PATCH] call( fast-path now supports curry and compose --- basis/compiler/tests/call-effect.factor | 7 +++++ .../tree/propagation/inlining/inlining.factor | 4 +-- .../call-effect/call-effect-tests.factor | 13 +++++++-- .../call-effect/call-effect.factor | 28 +++++++++++++++++-- .../known-words/known-words.factor | 2 +- basis/stack-checker/stack-checker-docs.factor | 1 + core/effects/effects-docs.factor | 11 ++++++-- core/effects/effects-tests.factor | 6 +++- core/effects/effects.factor | 20 +++++++++++-- 9 files changed, 78 insertions(+), 14 deletions(-) create mode 100644 basis/compiler/tests/call-effect.factor diff --git a/basis/compiler/tests/call-effect.factor b/basis/compiler/tests/call-effect.factor new file mode 100644 index 0000000000..407250a685 --- /dev/null +++ b/basis/compiler/tests/call-effect.factor @@ -0,0 +1,7 @@ +IN: compiler.tests.call-effect +USING: tools.test combinators generic.single sequences kernel ; + +: execute-ic-test ( a b -- c ) execute( a -- c ) ; + +! VM type check error +[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with \ No newline at end of file diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 42c47377e0..2a7d431314 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -188,9 +188,7 @@ SYMBOL: history { curry compose } memq? ; : never-inline-word? ( word -- ? ) - [ deferred? ] - [ "default" word-prop ] - [ { call execute } memq? ] tri or or ; + [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ; : custom-inlining? ( word -- ? ) "custom-inlining" word-prop ; diff --git a/basis/stack-checker/call-effect/call-effect-tests.factor b/basis/stack-checker/call-effect/call-effect-tests.factor index e5c0f23b30..b222cbbcf7 100644 --- a/basis/stack-checker/call-effect/call-effect-tests.factor +++ b/basis/stack-checker/call-effect/call-effect-tests.factor @@ -1,7 +1,16 @@ -USING: stack-checker.call-effect tools.test math kernel ; +USING: stack-checker.call-effect tools.test math kernel math effects ; IN: stack-checker.call-effect.tests [ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test [ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test [ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test -[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test \ No newline at end of file +[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test + +[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test +[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test +[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test +[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test +[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test +[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test +[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test +[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test \ No newline at end of file diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor index daeecc3ad5..4adc5952fd 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/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 words ; +stack-checker stack-checker.transforms words math ; IN: stack-checker.call-effect ! call( and execute( have complex expansions. @@ -18,14 +18,36 @@ IN: stack-checker.call-effect TUPLE: inline-cache value ; -: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline +: cache-hit? ( word/quot ic -- ? ) + [ value>> ] [ value>> eq? ] bi and ; inline -SYMBOL: +unknown+ +SINGLETON: +unknown+ GENERIC: cached-effect ( quot -- effect ) M: object cached-effect drop +unknown+ ; +GENERIC: curry-effect ( effect -- effect' ) + +M: +unknown+ curry-effect ; + +M: effect curry-effect + [ in>> length ] [ out>> length ] [ terminated?>> ] tri + pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if + effect boa ; + +M: curry cached-effect + quot>> cached-effect curry-effect ; + +: compose-effects* ( effect1 effect2 -- effect' ) + { + { [ 2dup [ effect? ] both? ] [ compose-effects ] } + { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] } + } cond ; + +M: compose cached-effect + [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ; + M: quotation cached-effect dup cached-effect>> [ ] [ diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index d7acf77162..4a9ff93179 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -147,7 +147,7 @@ M: object infer-call* apply-word/effect ; : infer-execute-effect-unsafe ( -- ) - \ execute infer-effect-unsafe ; + \ (execute) infer-effect-unsafe ; : infer-call-effect-unsafe ( -- ) \ call infer-effect-unsafe ; diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 243221ccf0..7d18482bff 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -102,6 +102,7 @@ ARTICLE: "tools.inference" "Stack effect tools" "Comparing effects:" { $subsection effect-height } { $subsection effect<= } +{ $subsection effect= } "The class of stack effects:" { $subsection effect } { $subsection effect? } ; diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index 495aeb39c1..38b8ab4dad 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -42,8 +42,15 @@ HELP: effect-height { $description "Outputs the number of objects added to the data stack by the stack effect. This will be negative if the stack effect only removes objects from the stack." } ; HELP: effect<= -{ $values { "eff1" effect } { "eff2" effect } { "?" "a boolean" } } -{ $description "Tests if " { $snippet "eff1" } " is substitutable for " { $snippet "eff2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ; +{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "effect1" } " is substitutable for " { $snippet "effect2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ; + +HELP: effect= +{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "effect1" } " and " { $snippet "effect2" } " represent the same stack transformation, without looking parameter names." } +{ $examples + { $example "USING: effects prettyprint ;" "(( a -- b )) (( x -- y )) effect= ." "t" } +} ; HELP: effect>string { $values { "obj" object } { "str" string } } diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 316add54c0..3eb9273859 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -18,4 +18,8 @@ USING: effects tools.test prettyprint accessors sequences ; [ { "x" "y" } ] [ { "y" "x" } (( a b -- b a )) shuffle ] unit-test [ { "y" "x" "y" } ] [ { "y" "x" } (( a b -- a b a )) shuffle ] unit-test -[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test \ No newline at end of file +[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test + +[ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test +[ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test +[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test \ No newline at end of file diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 142b9120a8..cab1e531b7 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.parser namespaces make sequences strings +USING: kernel math math.parser math.order namespaces make sequences strings words assocs combinators accessors arrays ; IN: effects @@ -13,7 +13,7 @@ TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ; : effect-height ( effect -- n ) [ out>> length ] [ in>> length ] bi - ; inline -: effect<= ( eff1 eff2 -- ? ) +: effect<= ( effect1 effect2 -- ? ) { { [ over terminated?>> ] [ t ] } { [ dup terminated?>> ] [ f ] } @@ -22,6 +22,12 @@ TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ; [ t ] } cond 2nip ; inline +: effect= ( effect1 effect2 -- ? ) + [ [ in>> length ] bi@ = ] + [ [ out>> length ] bi@ = ] + [ [ terminated?>> ] bi@ = ] + 2tri and and ; + GENERIC: effect>string ( obj -- str ) M: string effect>string ; M: object effect>string drop "object" ; @@ -66,3 +72,13 @@ M: effect clone : add-effect-input ( effect -- effect' ) [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ; + +: compose-effects ( effect1 effect2 -- effect' ) + over terminated?>> [ + drop + ] [ + [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ] + [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ] + [ nip terminated?>> ] 2tri + effect boa + ] if ; inline