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