1 ! Copyright (C) 2009, 2010 Slava Pestov, Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors combinators combinators.private
4 combinators.short-circuit compiler.tree.propagation.info
5 compiler.tree.propagation.inlining compiler.units continuations
6 effects fry kernel kernel.private namespaces quotations
7 sequences stack-checker stack-checker.dependencies
8 stack-checker.transforms words ;
9 IN: compiler.tree.propagation.call-effect
11 TUPLE: inline-cache value counter ;
13 : inline-cache-hit? ( word/quot ic -- ? )
14 { [ value>> eq? ] [ nip counter>> effect-counter eq? ] } 2&& ; inline
16 : update-inline-cache ( word/quot ic -- )
17 swap >>value effect-counter >>counter drop ; inline
21 GENERIC: cached-effect ( quot -- effect )
23 M: object cached-effect drop +unknown+ ;
25 GENERIC: curry-effect* ( effect -- effect' )
27 M: +unknown+ curry-effect* ;
29 M: effect curry-effect* curry-effect ;
31 M: curry cached-effect
32 quot>> cached-effect curry-effect* ;
34 : compose-effects* ( effect1 effect2 -- effect' )
36 { [ 2dup [ effect? ] both? ] [ compose-effects ] }
37 { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
40 M: compose cached-effect
41 [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
43 : safe-infer ( quot -- effect )
44 error get-global error-continuation get-global
45 [ [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ] 2dip
46 [ error set-global ] [ error-continuation set-global ] bi* ;
48 : cached-effect-valid? ( quot -- ? )
49 cache-counter>> effect-counter eq? ; inline
51 : save-effect ( effect quot -- )
52 swap >>cached-effect effect-counter >>cache-counter drop ;
54 M: quotation cached-effect
55 dup cached-effect-valid?
56 [ cached-effect>> ] [ [ safe-infer dup ] keep save-effect ] if ;
58 : call-effect-slow>quot ( effect -- quot )
59 [ \ call-effect def>> curry ] [ add-effect-input ] bi
60 '[ _ _ call-effect-unsafe ] ;
62 : call-effect-slow ( quot effect -- ) drop call ;
64 \ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
66 \ call-effect-slow t "no-compile" set-word-prop
68 : call-effect-unsafe? ( quot effect -- ? )
71 [ 2drop f ] [ [ { effect } declare ] dip effect<= ] if ; inline
73 : call-effect-fast ( quot effect inline-cache -- )
74 2over call-effect-unsafe?
75 [ [ nip update-inline-cache ] [ drop call-effect-unsafe ] 3bi ]
76 [ drop call-effect-slow ]
79 : call-effect-ic ( quot effect inline-cache -- )
80 3dup nip inline-cache-hit?
81 [ drop call-effect-unsafe ]
85 : call-effect>quot ( effect -- quot )
86 inline-cache new '[ drop _ _ call-effect-ic ] ;
88 : execute-effect-slow ( word effect -- )
89 [ '[ _ execute ] ] dip call-effect-slow ; inline
91 : execute-effect-unsafe? ( word effect -- ? )
93 [ [ stack-effect { effect } declare ] dip effect<= ]
97 : execute-effect-fast ( word effect inline-cache -- )
98 2over execute-effect-unsafe?
99 [ [ nip update-inline-cache ] [ drop execute-effect-unsafe ] 3bi ]
100 [ drop execute-effect-slow ]
103 : execute-effect-ic ( word effect inline-cache -- )
104 3dup nip inline-cache-hit?
105 [ drop execute-effect-unsafe ]
106 [ execute-effect-fast ]
109 : execute-effect>quot ( effect -- quot )
110 inline-cache new '[ drop _ _ execute-effect-ic ] ;
112 GENERIC: already-inlined-quot? ( quot -- ? )
114 M: curry already-inlined-quot? quot>> already-inlined-quot? ;
116 M: compose already-inlined-quot?
117 [ first>> already-inlined-quot? ]
118 [ second>> already-inlined-quot? ] bi or ;
120 M: quotation already-inlined-quot? already-inlined? ;
122 GENERIC: add-quot-to-history ( quot -- )
124 M: curry add-quot-to-history quot>> add-quot-to-history ;
126 M: compose add-quot-to-history
127 [ first>> add-quot-to-history ]
128 [ second>> add-quot-to-history ] bi ;
130 M: quotation add-quot-to-history add-to-history ;
132 : last2 ( seq -- penultimate ultimate )
135 : top-two ( #call -- effect value )
136 in-d>> last2 [ value-info ] bi@
141 : remove-effect-input ( effect -- effect' )
142 ( -- object ) swap compose-effects ;
144 : (infer-value) ( value-info -- effect )
147 [ callable? [ uninferable ] unless ]
148 [ already-inlined-quot? [ uninferable ] when ]
149 [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
152 { \ curry [ slots>> third (infer-value) remove-effect-input ] }
153 { \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
158 : infer-value ( value-info -- effect/f )
159 '[ _ (infer-value) ] [ uninferable? ] ignore-error/f ;
161 : (value>quot) ( value-info -- quot )
163 literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
167 slots>> third (value>quot)
168 '[ [ obj>> ] [ quot>> @ ] bi ]
171 slots>> last2 [ (value>quot) ] bi@
172 '[ [ first>> @ ] [ second>> @ ] bi ]
177 : value>quot ( value-info -- quot: ( code effect -- ) )
178 (value>quot) '[ drop @ ] ;
180 : call-inlining ( #call -- quot/f )
181 top-two dup infer-value [
184 [ drop call-effect>quot ] if
185 ] [ drop call-effect>quot ] if* ;
187 \ call-effect [ call-inlining ] "custom-inlining" set-word-prop
189 : execute-inlining ( #call -- quot/f )
191 2dup swap execute-effect-unsafe?
192 [ nip '[ 2drop _ execute ] ]
193 [ drop execute-effect>quot ] if
194 ] [ drop execute-effect>quot ] if ;
196 \ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop