--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel
+compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ;
+IN: compiler.tree.propagation.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
+
+[ 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
+
+: optimized-quot ( quot -- quot' )
+ build-tree optimize-tree nodes>quot ;
+
+: compiled-call2 ( a quot: ( a -- b ) -- b )
+ call( a -- b ) ;
+
+: compiled-execute2 ( a b word: ( a b -- c ) -- c )
+ execute( a b -- c ) ;
+
+[ [ 3 ] ] [ [ 1 2 \ + execute( a b -- c ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 [ + ] call( a b -- c ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 '[ _ + ] call( a -- b ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] optimized-quot ] unit-test
+
+[ 1 2 { [ + ] } first compiled-call2 ] must-fail
+[ 3 ] [ 1 2 { + } first compiled-execute2 ] unit-test
+[ 3 ] [ 1 2 '[ _ + ] compiled-call2 ] unit-test
+[ 3 ] [ 1 2 '[ _ ] [ + ] compose compiled-call2 ] unit-test
+[ 3 ] [ 1 2 \ + compiled-execute2 ] unit-test
+
+[ 3 ] [ 1 2 { [ + ] } first call( a b -- c ) ] unit-test
+[ 3 ] [ 1 2 { + } first execute( a b -- c ) ] unit-test
+[ 3 ] [ 1 2 '[ _ + ] call( a -- b ) ] unit-test
+[ 3 ] [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] unit-test
+
+[ t ] [ [ 2 '[ _ ] [ + ] compose ] final-info first infer-value (( object -- object )) effect= ] unit-test
+[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
+[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
+[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
+[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
+[ f ] [ [ dup drop ] final-info first infer-value ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.private effects fry
+kernel kernel.private make sequences continuations quotations
+words math stack-checker stack-checker.transforms
+compiler.tree.propagation.info slots.private ;
+IN: compiler.tree.propagation.call-effect
+
+! call( and execute( have complex expansions.
+
+! call( uses the following strategy:
+! - Inline caching. If the quotation is the same as last time, just call it unsafely
+! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
+! and compare it with declaration. If matches, call it unsafely.
+! - Fallback. If the above doesn't work, call it and compare the datastack before
+! and after to make sure it didn't mess anything up.
+
+! execute( uses a similar strategy.
+
+TUPLE: inline-cache value ;
+
+: cache-hit? ( word/quot ic -- ? )
+ [ value>> eq? ] [ value>> ] bi and ; inline
+
+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>>
+ [ ] [
+ [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
+ (>>cached-effect)
+ ] ?if ;
+
+: call-effect-unsafe? ( quot effect -- ? )
+ [ cached-effect ] dip
+ over +unknown+ eq?
+ [ 2drop f ] [ effect<= ] if ; inline
+
+: (call-effect-slow>quot) ( in out effect -- quot )
+ [
+ [ [ datastack ] dip dip ] %
+ [ [ , ] bi@ \ check-datastack , ] dip
+ '[ _ wrong-values ] , \ unless ,
+ ] [ ] make ;
+
+: call-effect-slow>quot ( effect -- quot )
+ [ in>> length ] [ out>> length ] [ ] tri
+ [ (call-effect-slow>quot) ] keep add-effect-input
+ [ call-effect-unsafe ] 2curry ;
+
+: call-effect-slow ( quot effect -- ) drop call ;
+
+\ 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 ]
+ [ drop call-effect-slow ]
+ if ; inline
+
+: call-effect-ic ( quot effect inline-cache -- )
+ 3dup nip cache-hit?
+ [ drop call-effect-unsafe ]
+ [ call-effect-fast ]
+ if ; inline
+
+: call-effect>quot ( effect -- quot )
+ inline-cache new '[ drop _ _ call-effect-ic ] ;
+
+: execute-effect-slow ( word effect -- )
+ [ '[ _ execute ] ] dip call-effect-slow ; inline
+
+: execute-effect-unsafe? ( word effect -- ? )
+ over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
+
+: execute-effect-fast ( word effect inline-cache -- )
+ 2over execute-effect-unsafe?
+ [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
+ [ drop execute-effect-slow ]
+ if ; inline
+
+: execute-effect-ic ( word effect inline-cache -- )
+ 3dup nip cache-hit?
+ [ drop execute-effect-unsafe ]
+ [ execute-effect-fast ]
+ if ; inline
+
+: execute-effect>quot ( effect -- quot )
+ inline-cache new '[ drop _ _ execute-effect-ic ] ;
+
+: last2 ( seq -- penultimate ultimate )
+ 2 tail* first2 ;
+
+: top-two ( #call -- effect value )
+ in-d>> last2 [ value-info ] bi@
+ literal>> swap ;
+
+ERROR: uninferable ;
+
+: remove-effect-input ( effect -- effect' )
+ (( -- object )) swap compose-effects ;
+
+: (infer-value) ( value-info -- effect )
+ dup class>> {
+ { \ quotation [
+ literal>> [ uninferable ] unless* cached-effect
+ dup +unknown+ = [ uninferable ] when
+ ] }
+ { \ curry [
+ slots>> third (infer-value)
+ remove-effect-input
+ ] }
+ { \ compose [
+ slots>> last2 [ (infer-value) ] bi@
+ compose-effects
+ ] }
+ [ uninferable ]
+ } case ;
+
+: infer-value ( value-info -- effect/f )
+ [ (infer-value) ]
+ [ dup uninferable? [ 2drop f ] [ rethrow ] if ]
+ recover ;
+
+: (value>quot) ( value-info -- quot )
+ dup class>> {
+ { \ quotation [ literal>> '[ drop @ ] ] }
+ { \ curry [
+ slots>> third (value>quot)
+ '[ [ obj>> ] [ quot>> @ ] bi ]
+ ] }
+ { \ compose [
+ slots>> last2 [ (value>quot) ] bi@
+ '[ [ first>> @ ] [ second>> @ ] bi ]
+ ] }
+ } case ;
+
+: value>quot ( value-info -- quot: ( code effect -- ) )
+ (value>quot) '[ drop @ ] ;
+
+: call-inlining ( #call -- quot/f )
+ top-two dup infer-value [
+ pick effect<=
+ [ nip value>quot ]
+ [ drop call-effect>quot ] if
+ ] [ drop call-effect>quot ] if* ;
+
+\ call-effect [ call-inlining ] "custom-inlining" set-word-prop
+
+: execute-inlining ( #call -- quot/f )
+ top-two >literal< [
+ 2dup swap execute-effect-unsafe?
+ [ nip '[ 2drop _ execute ] ]
+ [ drop execute-effect>quot ] if
+ ] [ drop execute-effect>quot ] if ;
+
+\ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop
compiler.tree.propagation.nodes
compiler.tree.propagation.slots
compiler.tree.propagation.simple
-compiler.tree.propagation.constraints ;
+compiler.tree.propagation.constraints
+compiler.tree.propagation.call-effect ;
IN: compiler.tree.propagation.known-words
\ fixnum
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-USING: stack-checker.call-effect tools.test 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
-
-[ 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
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! 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 math ;
-IN: stack-checker.call-effect
-
-! call( and execute( have complex expansions.
-
-! call( uses the following strategy:
-! - Inline caching. If the quotation is the same as last time, just call it unsafely
-! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
-! and compare it with declaration. If matches, call it unsafely.
-! - Fallback. If the above doesn't work, call it and compare the datastack before
-! and after to make sure it didn't mess anything up.
-
-! execute( uses a similar strategy.
-
-TUPLE: inline-cache value ;
-
-: cache-hit? ( word/quot ic -- ? )
- [ value>> eq? ] [ value>> ] bi and ; inline
-
-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>>
- [ ] [
- [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
- (>>cached-effect)
- ] ?if ;
-
-: call-effect-unsafe? ( quot effect -- ? )
- [ cached-effect ] dip
- over +unknown+ eq?
- [ 2drop f ] [ effect<= ] if ; inline
-
-: (call-effect-slow>quot) ( in out effect -- quot )
- [
- [ [ datastack ] dip dip ] %
- [ [ , ] bi@ \ check-datastack , ] dip
- '[ _ wrong-values ] , \ unless ,
- ] [ ] make ;
-
-: call-effect-slow>quot ( effect -- quot )
- [ in>> length ] [ out>> length ] [ ] tri
- [ (call-effect-slow>quot) ] keep add-effect-input
- [ call-effect-unsafe ] 2curry ;
-
-: call-effect-slow ( quot effect -- ) drop call ;
-
-\ 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 ]
- [ drop call-effect-slow ]
- if ; inline
-
-: call-effect-ic ( quot effect inline-cache -- )
- 3dup nip cache-hit?
- [ drop call-effect-unsafe ]
- [ call-effect-fast ]
- if ; inline
-
-: call-effect>quot ( -- quot )
- inline-cache new '[ _ call-effect-ic ] ;
-
-\ call-effect [ call-effect>quot ] 0 define-transform
-
-\ call-effect t "no-compile" set-word-prop
-
-: execute-effect-slow ( word effect -- )
- [ '[ _ execute ] ] dip call-effect-slow ; inline
-
-: execute-effect-unsafe? ( word effect -- ? )
- over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
-
-: execute-effect-fast ( word effect inline-cache -- )
- 2over execute-effect-unsafe?
- [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
- [ drop execute-effect-slow ]
- if ; inline
-
-: execute-effect-ic ( word effect inline-cache -- )
- 3dup nip cache-hit?
- [ drop execute-effect-unsafe ]
- [ execute-effect-fast ]
- if ; inline
-
-: execute-effect>quot ( effect -- quot )
- inline-cache new '[ _ _ execute-effect-ic ] ;
-
-\ execute-effect [ execute-effect>quot ] 1 define-transform
-
-\ execute-effect t "no-compile" set-word-prop
\ drop-locals [ infer-drop-locals ] "special" set-word-prop
+: infer-call-effect ( word -- )
+ 1 ensure-d first literal value>>
+ add-effect-input add-effect-input
+ apply-word/effect ;
+
+{ call-effect execute-effect } [
+ dup t "no-compile" set-word-prop
+ dup '[ _ infer-call-effect ] "special" set-word-prop
+] each
+
\ do-primitive [ unknown-primitive-error ] "special" set-word-prop
\ if [ infer-if ] "special" set-word-prop
: infer. ( quot -- )
#! Safe to call from inference transforms.
infer effect>string print ;
-
-"stack-checker.call-effect" require
\ No newline at end of file
projects / factor.git / commitdiff