call( and execute( inline known quotations/words in the propagation pass
Daniel Ehrenberg
parent
500c784bd7
commit
47500fad06
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Daniel Ehrenberg
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
! 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
|
||||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! 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
|
||||
stack-checker stack-checker.transforms words math ;
|
||||
IN: stack-checker.call-effect
|
||||
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.
|
||||
|
||||
|
|
@ -90,12 +91,8 @@ M: quotation cached-effect
|
|||
[ 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
|
||||
: call-effect>quot ( effect -- quot )
|
||||
inline-cache new '[ drop _ _ call-effect-ic ] ;
|
||||
|
||||
: execute-effect-slow ( word effect -- )
|
||||
[ '[ _ execute ] ] dip call-effect-slow ; inline
|
||||
|
|
@ -116,8 +113,72 @@ M: quotation cached-effect
|
|||
if ; inline
|
||||
|
||||
: execute-effect>quot ( effect -- quot )
|
||||
inline-cache new '[ _ _ execute-effect-ic ] ;
|
||||
inline-cache new '[ drop _ _ execute-effect-ic ] ;
|
||||
|
||||
\ execute-effect [ execute-effect>quot ] 1 define-transform
|
||||
: last2 ( seq -- penultimate ultimate )
|
||||
2 tail* first2 ;
|
||||
|
||||
\ execute-effect t "no-compile" set-word-prop
|
||||
: 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
|
||||
|
|
@ -13,7 +13,8 @@ compiler.tree.propagation.info
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
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
|
||||
|
|
@ -205,6 +205,16 @@ M: object infer-call*
|
|||
|
||||
\ 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
|
||||
|
|
|
|||
|
|
@ -15,5 +15,3 @@ M: callable infer ( quot -- effect )
|
|||
: infer. ( quot -- )
|
||||
#! Safe to call from inference transforms.
|
||||
infer effect>string print ;
|
||||
|
||||
"stack-checker.call-effect" require
|
||||
Loading…
Reference in New Issue