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
7 compiler.tree.propagation.inlining ;
8 IN: compiler.tree.propagation.call-effect
10 ! call( and execute( have complex expansions.
12 ! call( uses the following strategy:
13 ! - Inline caching. If the quotation is the same as last time, just call it unsafely
14 ! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
15 ! and compare it with declaration. If matches, call it unsafely.
16 ! - Fallback. If the above doesn't work, call it and compare the datastack before
17 ! and after to make sure it didn't mess anything up.
19 ! execute( uses a similar strategy.
21 TUPLE: inline-cache value ;
23 : cache-hit? ( word/quot ic -- ? )
24 [ value>> eq? ] [ value>> ] bi and ; inline
28 GENERIC: cached-effect ( quot -- effect )
30 M: object cached-effect drop +unknown+ ;
32 GENERIC: curry-effect ( effect -- effect' )
34 M: +unknown+ curry-effect ;
36 M: effect curry-effect
37 [ in>> length ] [ out>> length ] [ terminated?>> ] tri
38 pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
41 M: curry cached-effect
42 quot>> cached-effect curry-effect ;
44 : compose-effects* ( effect1 effect2 -- effect' )
46 { [ 2dup [ effect? ] both? ] [ compose-effects ] }
47 { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
50 M: compose cached-effect
51 [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
53 M: quotation cached-effect
56 [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
60 : call-effect-unsafe? ( quot effect -- ? )
63 [ 2drop f ] [ effect<= ] if ; inline
65 : (call-effect-slow>quot) ( in out effect -- quot )
67 [ [ datastack ] dip dip ] %
68 [ [ , ] bi@ \ check-datastack , ] dip
69 '[ _ wrong-values ] , \ unless ,
72 : call-effect-slow>quot ( effect -- quot )
73 [ in>> length ] [ out>> length ] [ ] tri
74 [ (call-effect-slow>quot) ] keep add-effect-input
75 [ call-effect-unsafe ] 2curry ;
77 : call-effect-slow ( quot effect -- ) drop call ;
79 \ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
81 \ call-effect-slow t "no-compile" set-word-prop
83 : call-effect-fast ( quot effect inline-cache -- )
84 2over call-effect-unsafe?
85 [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
86 [ drop call-effect-slow ]
89 : call-effect-ic ( quot effect inline-cache -- )
91 [ drop call-effect-unsafe ]
95 : call-effect>quot ( effect -- quot )
96 inline-cache new '[ drop _ _ call-effect-ic ] ;
98 : execute-effect-slow ( word effect -- )
99 [ '[ _ execute ] ] dip call-effect-slow ; inline
101 : execute-effect-unsafe? ( word effect -- ? )
102 over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
104 : execute-effect-fast ( word effect inline-cache -- )
105 2over execute-effect-unsafe?
106 [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
107 [ drop execute-effect-slow ]
110 : execute-effect-ic ( word effect inline-cache -- )
112 [ drop execute-effect-unsafe ]
113 [ execute-effect-fast ]
116 : execute-effect>quot ( effect -- quot )
117 inline-cache new '[ drop _ _ execute-effect-ic ] ;
119 : last2 ( seq -- penultimate ultimate )
122 : top-two ( #call -- effect value )
123 in-d>> last2 [ value-info ] bi@
128 : remove-effect-input ( effect -- effect' )
129 (( -- object )) swap compose-effects ;
131 : (infer-value) ( value-info -- effect )
134 literal>> [ uninferable ] unless*
135 dup already-inlined? [ uninferable ] when
136 cached-effect dup +unknown+ = [ uninferable ] when
139 slots>> third (infer-value)
143 slots>> last2 [ (infer-value) ] bi@
149 : infer-value ( value-info -- effect/f )
151 [ dup uninferable? [ 2drop f ] [ rethrow ] if ]
154 : (value>quot) ( value-info -- quot )
156 { \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] }
158 slots>> third (value>quot)
159 '[ [ obj>> ] [ quot>> @ ] bi ]
162 slots>> last2 [ (value>quot) ] bi@
163 '[ [ first>> @ ] [ second>> @ ] bi ]
167 : value>quot ( value-info -- quot: ( code effect -- ) )
168 (value>quot) '[ drop @ ] ;
170 : call-inlining ( #call -- quot/f )
171 top-two dup infer-value [
174 [ drop call-effect>quot ] if
175 ] [ drop call-effect>quot ] if* ;
177 \ call-effect [ call-inlining ] "custom-inlining" set-word-prop
179 : execute-inlining ( #call -- quot/f )
181 2dup swap execute-effect-unsafe?
182 [ nip '[ 2drop _ execute ] ]
183 [ drop execute-effect>quot ] if
184 ] [ drop execute-effect>quot ] if ;
186 \ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop