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 ! Save and restore error variables here, so that we don't
45 ! pollute words such as :error and :c for the user.
46 error get-global error-continuation get-global
47 [ [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ] 2dip
48 [ error set-global ] [ error-continuation set-global ] bi* ;
50 : cached-effect-valid? ( quot -- ? )
51 cache-counter>> effect-counter eq? ; inline
53 : save-effect ( effect quot -- )
54 swap >>cached-effect effect-counter >>cache-counter drop ;
56 M: quotation cached-effect
57 dup cached-effect-valid?
58 [ cached-effect>> ] [ [ safe-infer dup ] keep save-effect ] if ;
60 : call-effect-slow>quot ( effect -- quot )
61 [ \ call-effect def>> curry ] [ add-effect-input ] bi
62 '[ _ _ call-effect-unsafe ] ;
64 : call-effect-slow ( quot effect -- ) drop call ;
66 \ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
68 \ call-effect-slow t "no-compile" set-word-prop
70 : call-effect-unsafe? ( quot effect -- ? )
73 [ 2drop f ] [ [ { effect } declare ] dip effect<= ] if ; inline
75 : call-effect-fast ( quot effect inline-cache -- )
76 2over call-effect-unsafe?
77 [ [ nip update-inline-cache ] [ drop call-effect-unsafe ] 3bi ]
78 [ drop call-effect-slow ]
81 : call-effect-ic ( quot effect inline-cache -- )
82 3dup nip inline-cache-hit?
83 [ drop call-effect-unsafe ]
87 : call-effect>quot ( effect -- quot )
88 inline-cache new '[ drop _ _ call-effect-ic ] ;
90 : execute-effect-slow ( word effect -- )
91 [ '[ _ execute ] ] dip call-effect-slow ; inline
93 : execute-effect-unsafe? ( word effect -- ? )
95 [ [ stack-effect { effect } declare ] dip effect<= ]
99 : execute-effect-fast ( word effect inline-cache -- )
100 2over execute-effect-unsafe?
101 [ [ nip update-inline-cache ] [ drop execute-effect-unsafe ] 3bi ]
102 [ drop execute-effect-slow ]
105 : execute-effect-ic ( word effect inline-cache -- )
106 3dup nip inline-cache-hit?
107 [ drop execute-effect-unsafe ]
108 [ execute-effect-fast ]
111 : execute-effect>quot ( effect -- quot )
112 inline-cache new '[ drop _ _ execute-effect-ic ] ;
114 GENERIC: already-inlined-quot? ( quot -- ? )
116 M: curry already-inlined-quot? quot>> already-inlined-quot? ;
118 M: compose already-inlined-quot?
119 [ first>> already-inlined-quot? ]
120 [ second>> already-inlined-quot? ] bi or ;
122 M: quotation already-inlined-quot? already-inlined? ;
124 GENERIC: add-quot-to-history ( quot -- )
126 M: curry add-quot-to-history quot>> add-quot-to-history ;
128 M: compose 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 : last2 ( seq -- penultimate ultimate )
137 : top-two ( #call -- effect value )
138 in-d>> last2 [ value-info ] bi@
143 : remove-effect-input ( effect -- effect' )
144 ( -- object ) swap compose-effects ;
146 : (infer-value) ( value-info -- effect )
149 [ callable? [ throw-uninferable ] unless ]
150 [ already-inlined-quot? [ throw-uninferable ] when ]
151 [ safe-infer dup +unknown+ = [ throw-uninferable ] when ] tri
154 { \ curry [ slots>> third (infer-value) remove-effect-input ] }
155 { \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
156 [ throw-uninferable ]
160 : infer-value ( value-info -- effect/f )
162 [ dup uninferable? [ 2drop f ] [ rethrow ] if ]
165 : (value>quot) ( value-info -- quot )
167 literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
171 slots>> third (value>quot)
172 '[ [ obj>> ] [ quot>> @ ] bi ]
175 slots>> last2 [ (value>quot) ] bi@
176 '[ [ first>> @ ] [ second>> @ ] bi ]
181 : value>quot ( value-info -- quot: ( code effect -- ) )
182 (value>quot) '[ drop @ ] ;
184 : call-inlining ( #call -- quot/f )
185 top-two dup infer-value [
188 [ drop call-effect>quot ] if
189 ] [ drop call-effect>quot ] if* ;
191 \ call-effect [ call-inlining ] "custom-inlining" set-word-prop
193 : execute-inlining ( #call -- quot/f )
195 2dup swap execute-effect-unsafe?
196 [ nip '[ 2drop _ execute ] ]
197 [ drop execute-effect>quot ] if
198 ] [ drop execute-effect>quot ] if ;
200 \ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop