basis/compiler/tree/propagation/call-effect/call-effect.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators combinators.private effects
   4 fry kernel kernel.private make namespaces sequences continuations
   5 quotations words math stack-checker stack-checker.dependencies
   6 combinators.short-circuit stack-checker.transforms
   7 compiler.tree.propagation.info
   8 compiler.tree.propagation.inlining compiler.units ;
   9 IN: compiler.tree.propagation.call-effect
  10
  11 ! call( and execute( have complex expansions.
  12
  13 ! If the input quotation is a literal, or built up from curry and
  14 ! compose with terminal quotations literal, it is inlined at the
  15 ! call site.
  16
  17 ! For dynamic call sites, call( uses the following strategy:
  18 ! - Inline caching. If the quotation is the same as last time, just call it unsafely
  19 ! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
  20 !   and compare it with declaration. If matches, call it unsafely.
  21 ! - Fallback. If the above doesn't work, call it and compare the datastack before
  22 !   and after to make sure it didn't mess anything up.
  23 ! - Inline caches and cached effects are invalidated whenever a macro is redefined, or
  24 !   a word's effect changes, by comparing a global counter against the counter value
  25 !   last observed. The counter is incremented by compiler.units.
  26
  27 ! execute( uses a similar strategy.
  28
  29 TUPLE: inline-cache value counter ;
  30
  31 : inline-cache-hit? ( word/quot ic -- ? )
  32     { [ value>> eq? ] [ nip counter>> effect-counter eq? ] } 2&& ; inline
  33
  34 : update-inline-cache ( word/quot ic -- )
  35     [ effect-counter ] dip
  36     [ value<< ] [ counter<< ] bi-curry bi* ; inline
  37
  38 SINGLETON: +unknown+
  39
  40 GENERIC: cached-effect ( quot -- effect )
  41
  42 M: object cached-effect drop +unknown+ ;
  43
  44 GENERIC: curry-effect ( effect -- effect' )
  45
  46 M: +unknown+ curry-effect ;
  47
  48 M: effect curry-effect
  49     [ in>> length ] [ out>> length ] [ terminated?>> ] tri
  50     pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
  51     [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;
  52
  53 M: curry cached-effect
  54     quot>> cached-effect curry-effect ;
  55
  56 : compose-effects* ( effect1 effect2 -- effect' )
  57     {
  58         { [ 2dup [ effect? ] both? ] [ compose-effects ] }
  59         { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
  60     } cond ;
  61
  62 M: compose cached-effect
  63     [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
  64
  65 : safe-infer ( quot -- effect )
  66     ! Save and restore error variables here, so that we don't
  67     ! pollute words such as :error and :c for the user.
  68     error get-global error-continuation get-global
  69     [ [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ] 2dip
  70     [ error set-global ] [ error-continuation set-global ] bi* ;
  71
  72 : cached-effect-valid? ( quot -- ? )
  73     cache-counter>> effect-counter eq? ; inline
  74
  75 : save-effect ( effect quot -- )
  76     [ effect-counter ] dip
  77     [ cached-effect<< ] [ cache-counter<< ] bi-curry bi* ;
  78
  79 M: quotation cached-effect
  80     dup cached-effect-valid?
  81     [ cached-effect>> ] [ [ safe-infer dup ] keep save-effect ] if ;
  82
  83 : call-effect-unsafe? ( quot effect -- ? )
  84     [ cached-effect ] dip
  85     over +unknown+ eq?
  86     [ 2drop f ] [ [ { effect } declare ] dip effect<= ] if ; inline
  87
  88 : call-effect-slow>quot ( effect -- quot )
  89     [ \ call-effect def>> curry ] [ add-effect-input ] bi
  90     '[ _ _ call-effect-unsafe ] ;
  91
  92 : call-effect-slow ( quot effect -- ) drop call ;
  93
  94 \ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
  95
  96 \ call-effect-slow t "no-compile" set-word-prop
  97
  98 : call-effect-fast ( quot effect inline-cache -- )
  99     2over call-effect-unsafe?
 100     [ [ nip update-inline-cache ] [ drop call-effect-unsafe ] 3bi ]
 101     [ drop call-effect-slow ]
 102     if ; inline
 103
 104 : call-effect-ic ( quot effect inline-cache -- )
 105     3dup nip inline-cache-hit?
 106     [ drop call-effect-unsafe ]
 107     [ call-effect-fast ]
 108     if ; inline
 109
 110 : call-effect>quot ( effect -- quot )
 111     inline-cache new '[ drop _ _ call-effect-ic ] ;
 112
 113 : execute-effect-slow ( word effect -- )
 114     [ '[ _ execute ] ] dip call-effect-slow ; inline
 115
 116 : execute-effect-unsafe? ( word effect -- ? )
 117     over optimized?
 118     [ [ stack-effect { effect } declare ] dip effect<= ]
 119     [ 2drop f ]
 120     if ; inline
 121
 122 : execute-effect-fast ( word effect inline-cache -- )
 123     2over execute-effect-unsafe?
 124     [ [ nip update-inline-cache ] [ drop execute-effect-unsafe ] 3bi ]
 125     [ drop execute-effect-slow ]
 126     if ; inline
 127
 128 : execute-effect-ic ( word effect inline-cache -- )
 129     3dup nip inline-cache-hit?
 130     [ drop execute-effect-unsafe ]
 131     [ execute-effect-fast ]
 132     if ; inline
 133
 134 : execute-effect>quot ( effect -- quot )
 135     inline-cache new '[ drop _ _ execute-effect-ic ] ;
 136
 137 ! Some bookkeeping to make sure that crap like
 138 ! [ dup curry call( quot -- ) ] dup curry call( quot -- ) ]
 139 ! doesn't hang the compiler.
 140 GENERIC: already-inlined-quot? ( quot -- ? )
 141
 142 M: curry already-inlined-quot? quot>> already-inlined-quot? ;
 143
 144 M: compose already-inlined-quot?
 145     [ first>> already-inlined-quot? ]
 146     [ second>> already-inlined-quot? ] bi or ;
 147
 148 M: quotation already-inlined-quot? already-inlined? ;
 149
 150 GENERIC: add-quot-to-history ( quot -- )
 151
 152 M: curry add-quot-to-history quot>> add-quot-to-history ;
 153
 154 M: compose add-quot-to-history
 155     [ first>> add-quot-to-history ]
 156     [ second>> add-quot-to-history ] bi ;
 157
 158 M: quotation add-quot-to-history add-to-history ;
 159
 160 : last2 ( seq -- penultimate ultimate )
 161     2 tail* first2 ;
 162
 163 : top-two ( #call -- effect value )
 164     in-d>> last2 [ value-info ] bi@
 165     literal>> swap ;
 166
 167 ERROR: uninferable ;
 168
 169 : remove-effect-input ( effect -- effect' )
 170     ( -- object ) swap compose-effects ;
 171
 172 : (infer-value) ( value-info -- effect )
 173     dup literal?>> [
 174         literal>>
 175         [ callable? [ uninferable ] unless ]
 176         [ already-inlined-quot? [ uninferable ] when ]
 177         [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
 178     ] [
 179         dup class>> {
 180             { \ curry [ slots>> third (infer-value) remove-effect-input ] }
 181             { \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
 182             [ uninferable ]
 183         } case
 184     ] if ;
 185
 186 : infer-value ( value-info -- effect/f )
 187     [ (infer-value) ]
 188     [ dup uninferable? [ 2drop f ] [ rethrow ] if ]
 189     recover ;
 190
 191 : (value>quot) ( value-info -- quot )
 192     dup literal?>> [
 193         literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
 194     ] [
 195         dup class>> {
 196             { \ curry [
 197                 slots>> third (value>quot)
 198                 '[ [ obj>> ] [ quot>> @ ] bi ]
 199             ] }
 200             { \ compose [
 201                 slots>> last2 [ (value>quot) ] bi@
 202                 '[ [ first>> @ ] [ second>> @ ] bi ]
 203             ] }
 204         } case
 205     ] if ;
 206
 207 : value>quot ( value-info -- quot: ( code effect -- ) )
 208     (value>quot) '[ drop @ ] ;
 209
 210 : call-inlining ( #call -- quot/f )
 211     top-two dup infer-value [
 212         pick effect<=
 213         [ nip value>quot ]
 214         [ drop call-effect>quot ] if
 215     ] [ drop call-effect>quot ] if* ;
 216
 217 \ call-effect [ call-inlining ] "custom-inlining" set-word-prop
 218
 219 : execute-inlining ( #call -- quot/f )
 220     top-two >literal< [
 221         2dup swap execute-effect-unsafe?
 222         [ nip '[ 2drop _ execute ] ]
 223         [ drop execute-effect>quot ] if
 224     ] [ drop execute-effect>quot ] if ;
 225
 226 \ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop