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

   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
  10
  11 TUPLE: inline-cache value counter ;
  12
  13 : inline-cache-hit? ( word/quot ic -- ? )
  14     { [ value>> eq? ] [ nip counter>> effect-counter eq? ] } 2&& ; inline
  15
  16 : update-inline-cache ( word/quot ic -- )
  17     swap >>value effect-counter >>counter drop ; inline
  18
  19 SINGLETON: +unknown+
  20
  21 GENERIC: cached-effect ( quot -- effect )
  22
  23 M: object cached-effect drop +unknown+ ;
  24
  25 GENERIC: curry-effect* ( effect -- effect' )
  26
  27 M: +unknown+ curry-effect* ;
  28
  29 M: effect curry-effect* curry-effect ;
  30
  31 M: curried cached-effect
  32     quot>> cached-effect curry-effect* ;
  33
  34 : compose-effects* ( effect1 effect2 -- effect' )
  35     {
  36         { [ 2dup [ effect? ] both? ] [ compose-effects ] }
  37         { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
  38     } cond ;
  39
  40 M: composed cached-effect
  41     [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
  42
  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* ;
  47
  48 : cached-effect-valid? ( quot -- ? )
  49     cache-counter>> effect-counter eq? ; inline
  50
  51 : save-effect ( effect quot -- )
  52     swap >>cached-effect effect-counter >>cache-counter drop ;
  53
  54 M: quotation cached-effect
  55     dup cached-effect-valid?
  56     [ cached-effect>> ] [ [ safe-infer dup ] keep save-effect ] if ;
  57
  58 : call-effect-slow>quot ( effect -- quot )
  59     [ \ call-effect def>> curry ] [ add-effect-input ] bi
  60     '[ _ _ call-effect-unsafe ] ;
  61
  62 : call-effect-slow ( quot effect -- ) drop call ;
  63
  64 \ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
  65
  66 \ call-effect-slow t "no-compile" set-word-prop
  67
  68 : call-effect-unsafe? ( quot effect -- ? )
  69     [ cached-effect ] dip
  70     over +unknown+ eq?
  71     [ 2drop f ] [ [ { effect } declare ] dip effect<= ] if ; inline
  72
  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 ]
  77     if ; inline
  78
  79 : call-effect-ic ( quot effect inline-cache -- )
  80     3dup nip inline-cache-hit?
  81     [ drop call-effect-unsafe ]
  82     [ call-effect-fast ]
  83     if ; inline
  84
  85 : call-effect>quot ( effect -- quot )
  86     inline-cache new '[ drop _ _ call-effect-ic ] ;
  87
  88 : execute-effect-slow ( word effect -- )
  89     [ '[ _ execute ] ] dip call-effect-slow ; inline
  90
  91 : execute-effect-unsafe? ( word effect -- ? )
  92     over word-optimized?
  93     [ [ stack-effect { effect } declare ] dip effect<= ]
  94     [ 2drop f ]
  95     if ; inline
  96
  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 ]
 101     if ; inline
 102
 103 : execute-effect-ic ( word effect inline-cache -- )
 104     3dup nip inline-cache-hit?
 105     [ drop execute-effect-unsafe ]
 106     [ execute-effect-fast ]
 107     if ; inline
 108
 109 : execute-effect>quot ( effect -- quot )
 110     inline-cache new '[ drop _ _ execute-effect-ic ] ;
 111
 112 GENERIC: already-inlined-quot? ( quot -- ? )
 113
 114 M: curried already-inlined-quot? quot>> already-inlined-quot? ;
 115
 116 M: composed already-inlined-quot?
 117     [ first>> already-inlined-quot? ]
 118     [ second>> already-inlined-quot? ] bi or ;
 119
 120 M: quotation already-inlined-quot? already-inlined? ;
 121
 122 GENERIC: add-quot-to-history ( quot -- )
 123
 124 M: curried add-quot-to-history quot>> add-quot-to-history ;
 125
 126 M: composed add-quot-to-history
 127     [ first>> add-quot-to-history ]
 128     [ second>> add-quot-to-history ] bi ;
 129
 130 M: quotation add-quot-to-history add-to-history ;
 131
 132 : last2 ( seq -- penultimate ultimate )
 133     2 tail* first2 ;
 134
 135 : top-two ( #call -- effect value )
 136     in-d>> last2 [ value-info ] bi@
 137     literal>> swap ;
 138
 139 ERROR: uninferable ;
 140
 141 : remove-effect-input ( effect -- effect' )
 142     ( -- object ) swap compose-effects ;
 143
 144 : (infer-value) ( value-info -- effect )
 145     dup literal?>> [
 146         literal>>
 147         [ callable? [ uninferable ] unless ]
 148         [ already-inlined-quot? [ uninferable ] when ]
 149         [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
 150     ] [
 151         dup { [ slots>> empty? not ] [ class>> ] } 1&& {
 152             { \ curried [ slots>> third (infer-value) remove-effect-input ] }
 153             { \ composed [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
 154             [ uninferable ]
 155         } case
 156     ] if ;
 157
 158 : infer-value ( value-info -- effect/f )
 159     '[ _ (infer-value) ] [ uninferable? ] ignore-error/f ;
 160
 161 : (value>quot) ( value-info -- quot )
 162     dup literal?>> [
 163         literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
 164     ] [
 165         dup class>> {
 166             { \ curried [
 167                 slots>> third (value>quot)
 168                 '[ [ obj>> ] [ quot>> @ ] bi ]
 169             ] }
 170             { \ composed [
 171                 slots>> last2 [ (value>quot) ] bi@
 172                 '[ [ first>> @ ] [ second>> @ ] bi ]
 173             ] }
 174         } case
 175     ] if ;
 176
 177 : value>quot ( value-info -- quot: ( code effect -- ) )
 178     (value>quot) '[ drop @ ] ;
 179
 180 : call-inlining ( #call -- quot/f )
 181     top-two dup infer-value [
 182         pick effect<=
 183         [ nip value>quot ]
 184         [ drop call-effect>quot ] if
 185     ] [ drop call-effect>quot ] if* ;
 186
 187 \ call-effect [ call-inlining ] "custom-inlining" set-word-prop
 188
 189 : execute-inlining ( #call -- quot/f )
 190     top-two >literal< [
 191         2dup swap execute-effect-unsafe?
 192         [ nip '[ 2drop _ execute ] ]
 193         [ drop execute-effect>quot ] if
 194     ] [ drop execute-effect>quot ] if ;
 195
 196 \ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop