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

   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
   9
  10 ! call( and execute( have complex expansions.
  11
  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.
  18
  19 ! execute( uses a similar strategy.
  20
  21 TUPLE: inline-cache value ;
  22
  23 : cache-hit? ( word/quot ic -- ? )
  24     [ value>> eq? ] [ value>> ] bi and ; inline
  25
  26 SINGLETON: +unknown+
  27
  28 GENERIC: cached-effect ( quot -- effect )
  29
  30 M: object cached-effect drop +unknown+ ;
  31
  32 GENERIC: curry-effect ( effect -- effect' )
  33
  34 M: +unknown+ curry-effect ;
  35
  36 M: effect curry-effect
  37     [ in>> length ] [ out>> length ] [ terminated?>> ] tri
  38     pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
  39     effect boa ;
  40
  41 M: curry cached-effect
  42     quot>> cached-effect curry-effect ;
  43
  44 : compose-effects* ( effect1 effect2 -- effect' )
  45     {
  46         { [ 2dup [ effect? ] both? ] [ compose-effects ] }
  47         { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
  48     } cond ;
  49
  50 M: compose cached-effect
  51     [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
  52
  53 M: quotation cached-effect
  54     dup cached-effect>>
  55     [ ] [
  56         [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
  57         (>>cached-effect)
  58     ] ?if ;
  59
  60 : call-effect-unsafe? ( quot effect -- ? )
  61     [ cached-effect ] dip
  62     over +unknown+ eq?
  63     [ 2drop f ] [ effect<= ] if ; inline
  64
  65 : (call-effect-slow>quot) ( in out effect -- quot )
  66     [
  67         [ [ datastack ] dip dip ] %
  68         [ [ , ] bi@ \ check-datastack , ] dip
  69         '[ _ wrong-values ] , \ unless ,
  70     ] [ ] make ;
  71
  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 ;
  76
  77 : call-effect-slow ( quot effect -- ) drop call ;
  78
  79 \ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
  80
  81 \ call-effect-slow t "no-compile" set-word-prop
  82
  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 ]
  87     if ; inline
  88
  89 : call-effect-ic ( quot effect inline-cache -- )
  90     3dup nip cache-hit?
  91     [ drop call-effect-unsafe ]
  92     [ call-effect-fast ]
  93     if ; inline
  94
  95 : call-effect>quot ( effect -- quot )
  96     inline-cache new '[ drop _ _ call-effect-ic ] ;
  97
  98 : execute-effect-slow ( word effect -- )
  99     [ '[ _ execute ] ] dip call-effect-slow ; inline
 100
 101 : execute-effect-unsafe? ( word effect -- ? )
 102     over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
 103
 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 ]
 108     if ; inline
 109
 110 : execute-effect-ic ( word effect inline-cache -- )
 111     3dup nip cache-hit?
 112     [ drop execute-effect-unsafe ]
 113     [ execute-effect-fast ]
 114     if ; inline
 115
 116 : execute-effect>quot ( effect -- quot )
 117     inline-cache new '[ drop _ _ execute-effect-ic ] ;
 118
 119 : last2 ( seq -- penultimate ultimate )
 120     2 tail* first2 ;
 121
 122 : top-two ( #call -- effect value )
 123     in-d>> last2 [ value-info ] bi@
 124     literal>> swap ;
 125
 126 ERROR: uninferable ;
 127
 128 : remove-effect-input ( effect -- effect' )
 129     (( -- object )) swap compose-effects ;
 130
 131 : (infer-value) ( value-info -- effect )
 132     dup class>> {
 133         { \ quotation [
 134             literal>> [ uninferable ] unless*
 135             dup already-inlined? [ uninferable ] when
 136             cached-effect dup +unknown+ = [ uninferable ] when
 137         ] }
 138         { \ curry [
 139             slots>> third (infer-value)
 140             remove-effect-input
 141         ] }
 142         { \ compose [
 143             slots>> last2 [ (infer-value) ] bi@
 144             compose-effects
 145         ] }
 146         [ uninferable ]
 147     } case ;
 148
 149 : infer-value ( value-info -- effect/f )
 150     [ (infer-value) ]
 151     [ dup uninferable? [ 2drop f ] [ rethrow ] if ]
 152     recover ;
 153
 154 : (value>quot) ( value-info -- quot )
 155     dup class>> {
 156         { \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] }
 157         { \ curry [
 158             slots>> third (value>quot)
 159             '[ [ obj>> ] [ quot>> @ ] bi ]
 160         ] }
 161         { \ compose [
 162             slots>> last2 [ (value>quot) ] bi@
 163             '[ [ first>> @ ] [ second>> @ ] bi ]
 164         ] }
 165     } case ;
 166
 167 : value>quot ( value-info -- quot: ( code effect -- ) )
 168     (value>quot) '[ drop @ ] ;
 169
 170 : call-inlining ( #call -- quot/f )
 171     top-two dup infer-value [
 172         pick effect<=
 173         [ nip value>quot ]
 174         [ drop call-effect>quot ] if
 175     ] [ drop call-effect>quot ] if* ;
 176
 177 \ call-effect [ call-inlining ] "custom-inlining" set-word-prop
 178
 179 : execute-inlining ( #call -- quot/f )
 180     top-two >literal< [
 181         2dup swap execute-effect-unsafe?
 182         [ nip '[ 2drop _ execute ] ]
 183         [ drop execute-effect>quot ] if
 184     ] [ drop execute-effect>quot ] if ;
 185
 186 \ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop