1 ! Copyright (C) 2009, 2010 Slava Pestov, Daniel Ehrenberg.
2 ! See https://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: curried 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: composed 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: curried already-inlined-quot? quot>> already-inlined-quot? ;
116 M: composed already-inlined-quot?
118 [ first>> already-inlined-quot? ]
119 [ second>> already-inlined-quot? ]
122 M: quotation already-inlined-quot? already-inlined? ;
124 GENERIC: add-quot-to-history ( quot -- )
126 M: curried add-quot-to-history quot>> add-quot-to-history ;
128 M: composed add-quot-to-history
129 [ first>> add-quot-to-history ]
130 [ second>> add-quot-to-history ] bi ;
132 M: quotation add-quot-to-history add-to-history ;
134 : top-two ( #call -- effect value )
135 in-d>> last2 [ value-info ] bi@
140 : remove-effect-input ( effect -- effect' )
141 ( -- object ) swap compose-effects ;
143 : (infer-value) ( value-info -- effect )
146 [ callable? [ uninferable ] unless ]
147 [ already-inlined-quot? [ uninferable ] when ]
148 [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
150 dup { [ slots>> empty? not ] [ class>> ] } 1&& {
151 { \ curried [ slots>> third (infer-value) remove-effect-input ] }
152 { \ composed [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
157 : infer-value ( value-info -- effect/f )
158 '[ _ (infer-value) ] [ uninferable? ] ignore-error/f ;
160 : (value>quot) ( value-info -- quot )
162 literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
166 slots>> third (value>quot)
167 '[ [ obj>> ] [ quot>> @ ] bi ]
170 slots>> last2 [ (value>quot) ] bi@
171 '[ [ first>> @ ] [ second>> @ ] bi ]
176 : value>quot ( value-info -- quot: ( code effect -- ) )
177 (value>quot) '[ drop @ ] ;
179 : call-inlining ( #call -- quot/f )
180 top-two dup infer-value [
183 [ drop call-effect>quot ] if
184 ] [ drop call-effect>quot ] if* ;
186 \ call-effect [ call-inlining ] "custom-inlining" set-word-prop
188 : execute-inlining ( #call -- quot/f )
190 2dup swap execute-effect-unsafe?
191 [ nip '[ 2drop _ execute ] ]
192 [ drop execute-effect>quot ] if
193 ] [ drop execute-effect>quot ] if ;
195 \ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop