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