1 ! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors combinators combinators.private effects fry
4 kernel kernel.private make sequences continuations quotations
5 words math stack-checker stack-checker.transforms
6 compiler.tree.propagation.info slots.private ;
7 IN: compiler.tree.propagation.call-effect
9 ! call( and execute( have complex expansions.
11 ! call( uses the following strategy:
12 ! - Inline caching. If the quotation is the same as last time, just call it unsafely
13 ! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
14 ! and compare it with declaration. If matches, call it unsafely.
15 ! - Fallback. If the above doesn't work, call it and compare the datastack before
16 ! and after to make sure it didn't mess anything up.
18 ! execute( uses a similar strategy.
20 TUPLE: inline-cache value ;
22 : cache-hit? ( word/quot ic -- ? )
23 [ value>> eq? ] [ value>> ] bi and ; inline
27 GENERIC: cached-effect ( quot -- effect )
29 M: object cached-effect drop +unknown+ ;
31 GENERIC: curry-effect ( effect -- effect' )
33 M: +unknown+ curry-effect ;
35 M: effect curry-effect
36 [ in>> length ] [ out>> length ] [ terminated?>> ] tri
37 pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if
40 M: curry cached-effect
41 quot>> cached-effect curry-effect ;
43 : compose-effects* ( effect1 effect2 -- effect' )
45 { [ 2dup [ effect? ] both? ] [ compose-effects ] }
46 { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
49 M: compose cached-effect
50 [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
52 M: quotation cached-effect
55 [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
59 : call-effect-unsafe? ( quot effect -- ? )
62 [ 2drop f ] [ effect<= ] if ; inline
64 : (call-effect-slow>quot) ( in out effect -- quot )
66 [ [ datastack ] dip dip ] %
67 [ [ , ] bi@ \ check-datastack , ] dip
68 '[ _ wrong-values ] , \ unless ,
71 : call-effect-slow>quot ( effect -- quot )
72 [ in>> length ] [ out>> length ] [ ] tri
73 [ (call-effect-slow>quot) ] keep add-effect-input
74 [ call-effect-unsafe ] 2curry ;
76 : call-effect-slow ( quot effect -- ) drop call ;
78 \ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
80 \ call-effect-slow t "no-compile" set-word-prop
82 : call-effect-fast ( quot effect inline-cache -- )
83 2over call-effect-unsafe?
84 [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
85 [ drop call-effect-slow ]
88 : call-effect-ic ( quot effect inline-cache -- )
90 [ drop call-effect-unsafe ]
94 : call-effect>quot ( effect -- quot )
95 inline-cache new '[ drop _ _ call-effect-ic ] ;
97 : execute-effect-slow ( word effect -- )
98 [ '[ _ execute ] ] dip call-effect-slow ; inline
100 : execute-effect-unsafe? ( word effect -- ? )
101 over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
103 : execute-effect-fast ( word effect inline-cache -- )
104 2over execute-effect-unsafe?
105 [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
106 [ drop execute-effect-slow ]
109 : execute-effect-ic ( word effect inline-cache -- )
111 [ drop execute-effect-unsafe ]
112 [ execute-effect-fast ]
115 : execute-effect>quot ( effect -- quot )
116 inline-cache new '[ drop _ _ execute-effect-ic ] ;
118 : last2 ( seq -- penultimate ultimate )
121 : top-two ( #call -- effect value )
122 in-d>> last2 [ value-info ] bi@
127 : remove-effect-input ( effect -- effect' )
128 (( -- object )) swap compose-effects ;
130 : (infer-value) ( value-info -- effect )
133 literal>> [ uninferable ] unless* cached-effect
134 dup +unknown+ = [ uninferable ] when
137 slots>> third (infer-value)
141 slots>> last2 [ (infer-value) ] bi@
147 : infer-value ( value-info -- effect/f )
149 [ dup uninferable? [ 2drop f ] [ rethrow ] if ]
152 : (value>quot) ( value-info -- quot )
154 { \ quotation [ literal>> '[ drop @ ] ] }
156 slots>> third (value>quot)
157 '[ [ obj>> ] [ quot>> @ ] bi ]
160 slots>> last2 [ (value>quot) ] bi@
161 '[ [ first>> @ ] [ second>> @ ] bi ]
165 : value>quot ( value-info -- quot: ( code effect -- ) )
166 (value>quot) '[ drop @ ] ;
168 : call-inlining ( #call -- quot/f )
169 top-two dup infer-value [
172 [ drop call-effect>quot ] if
173 ] [ drop call-effect>quot ] if* ;
175 \ call-effect [ call-inlining ] "custom-inlining" set-word-prop
177 : execute-inlining ( #call -- quot/f )
179 2dup swap execute-effect-unsafe?
180 [ nip '[ 2drop _ execute ] ]
181 [ drop execute-effect>quot ] if
182 ] [ drop execute-effect>quot ] if ;
184 \ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop