basis/stack-checker/backend/backend.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry arrays generic io io.streams.string kernel math
   4 namespaces parser sequences strings vectors words quotations
   5 effects classes continuations assocs combinators
   6 compiler.errors accessors math.order definitions sets
   7 generic.standard.engines.tuple hints stack-checker.state
   8 stack-checker.visitor stack-checker.errors stack-checker.values
   9 stack-checker.recursive-state ;
  10 IN: stack-checker.backend
  11
  12 : push-d ( obj -- ) meta-d push ;
  13
  14 : pop-d  ( -- obj )
  15     meta-d [
  16         <value> dup 1array #introduce, d-in inc
  17     ] [ pop ] if-empty ;
  18
  19 : peek-d ( -- obj ) pop-d dup push-d ;
  20
  21 : make-values ( n -- values )
  22     [ <value> ] replicate ;
  23
  24 : ensure-d ( n -- values )
  25     meta-d 2dup length > [
  26         2dup
  27         [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
  28         [ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri
  29         meta-d push-all
  30     ] when swap tail* ;
  31
  32 : shorten-by ( n seq -- )
  33     [ length swap - ] keep shorten ; inline
  34
  35 : consume-d ( n -- seq )
  36     [ ensure-d ] [ meta-d shorten-by ] bi ;
  37
  38 : output-d ( values -- ) meta-d push-all ;
  39
  40 : produce-d ( n -- values )
  41     make-values dup meta-d push-all ;
  42
  43 : push-r ( obj -- ) meta-r push ;
  44
  45 : pop-r ( -- obj )
  46     meta-r dup empty?
  47     [ too-many-r> inference-error ] [ pop ] if ;
  48
  49 : consume-r ( n -- seq )
  50     meta-r 2dup length >
  51     [ too-many-r> inference-error ] when
  52     [ swap tail* ] [ shorten-by ] 2bi ;
  53
  54 : output-r ( seq -- ) meta-r push-all ;
  55
  56 : push-literal ( obj -- )
  57     literals get push ;
  58
  59 : pop-literal ( -- rstate obj )
  60     literals get [
  61         pop-d
  62         [ 1array #drop, ]
  63         [ literal [ recursion>> ] [ value>> ] bi ] bi
  64     ] [ pop recursive-state get swap ] if-empty ;
  65
  66 : literals-available? ( n -- literals ? )
  67     literals get 2dup length <=
  68     [ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ;
  69
  70 GENERIC: apply-object ( obj -- )
  71
  72 M: wrapper apply-object
  73     wrapped>>
  74     [ dup word? [ called-dependency depends-on ] [ drop ] if ]
  75     [ push-literal ]
  76     bi ;
  77
  78 M: object apply-object push-literal ;
  79
  80 : terminate ( -- )
  81     terminated? on meta-d clone meta-r clone #terminate, ;
  82
  83 : check->r ( -- )
  84     meta-r empty? [ \ too-many->r inference-error ] unless ;
  85
  86 : infer-quot-here ( quot -- )
  87     meta-r [
  88         V{ } clone \ meta-r set
  89         [ apply-object terminated? get not ] all?
  90         [ commit-literals check->r ] [ literals get delete-all ] if
  91     ] dip \ meta-r set ;
  92
  93 : infer-quot ( quot rstate -- )
  94     recursive-state get [
  95         recursive-state set
  96         infer-quot-here
  97     ] dip recursive-state set ;
  98
  99 : time-bomb ( error -- )
 100     '[ _ throw ] infer-quot-here ;
 101
 102 : bad-call ( -- )
 103     "call must be given a callable" time-bomb ;
 104
 105 : infer-literal-quot ( literal -- )
 106     dup recursive-quotation? [
 107         value>> recursive-quotation-error inference-error
 108     ] [
 109         dup value>> callable? [
 110             [ value>> ]
 111             [ [ recursion>> ] keep add-local-quotation ]
 112             bi infer-quot
 113         ] [
 114             drop bad-call
 115         ] if
 116     ] if ;
 117
 118 : infer->r ( n -- )
 119     consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
 120
 121 : infer-r> ( n -- )
 122     consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
 123
 124 : undo-infer ( -- )
 125     recorded get [ f "inferred-effect" set-word-prop ] each ;
 126
 127 : consume/produce ( effect quot -- )
 128     #! quot is ( inputs outputs -- )
 129     [
 130         [
 131             [ in>> length consume-d ]
 132             [ out>> length produce-d ]
 133             bi
 134         ] dip call
 135     ] [
 136         drop
 137         terminated?>> [ terminate ] when
 138     ] 2bi ; inline
 139
 140 : infer-word-def ( word -- )
 141     [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
 142
 143 : end-infer ( -- )
 144     meta-d clone #return, ;
 145
 146 : effect-required? ( word -- ? )
 147     {
 148         { [ dup inline? ] [ drop f ] }
 149         { [ dup deferred? ] [ drop f ] }
 150         { [ dup crossref? not ] [ drop f ] }
 151         [ def>> [ word? ] contains? ]
 152     } cond ;
 153
 154 : ?missing-effect ( word -- )
 155     dup effect-required?
 156     [ missing-effect inference-error ] [ drop ] if ;
 157
 158 : check-effect ( word effect -- )
 159     over stack-effect {
 160         { [ dup not ] [ 2drop ?missing-effect ] }
 161         { [ 2dup effect<= ] [ 3drop ] }
 162         [ effect-error ]
 163     } cond ;
 164
 165 : finish-word ( word -- )
 166     current-effect
 167     [ check-effect ]
 168     [ drop recorded get push ]
 169     [ "inferred-effect" set-word-prop ]
 170     2tri ;
 171
 172 : cannot-infer-effect ( word -- * )
 173     "cannot-infer" word-prop throw ;
 174
 175 : maybe-cannot-infer ( word quot -- )
 176     [ [ "cannot-infer" set-word-prop ] keep throw ] recover ; inline
 177
 178 : infer-word ( word -- effect )
 179     [
 180         [
 181             init-inference
 182             init-known-values
 183             stack-visitor off
 184             dependencies off
 185             generic-dependencies off
 186             [ infer-word-def end-infer ]
 187             [ finish-word current-effect ]
 188             bi
 189         ] with-scope
 190     ] maybe-cannot-infer ;
 191
 192 : apply-word/effect ( word effect -- )
 193     swap '[ _ #call, ] consume/produce ;
 194
 195 : required-stack-effect ( word -- effect )
 196     dup stack-effect [ ] [ \ missing-effect inference-error ] ?if ;
 197
 198 : call-recursive-word ( word -- )
 199     dup required-stack-effect apply-word/effect ;
 200
 201 : cached-infer ( word -- )
 202     dup "inferred-effect" word-prop apply-word/effect ;
 203
 204 : with-infer ( quot -- effect visitor )
 205     [
 206         [
 207             V{ } clone recorded set
 208             init-inference
 209             init-known-values
 210             stack-visitor off
 211             call
 212             end-infer
 213             current-effect
 214             stack-visitor get
 215         ] [ ] [ undo-infer ] cleanup
 216     ] with-scope ; inline