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> ] [ pop ] if ;
  48
  49 : consume-r ( n -- seq )
  50     meta-r 2dup length >
  51     [ too-many-r> ] 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 ] 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
 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 -- inputs outputs )
 128     [ in>> length consume-d ] [ out>> length produce-d ] bi ;
 129
 130 : consume/produce ( effect quot: ( inputs outputs -- ) -- )
 131     '[ (consume/produce) @ ]
 132     [ terminated?>> [ terminate ] when ]
 133     bi ; inline
 134
 135 : infer-word-def ( word -- )
 136     [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
 137
 138 : end-infer ( -- )
 139     meta-d clone #return, ;
 140
 141 : required-stack-effect ( word -- effect )
 142     dup stack-effect [ ] [ missing-effect ] ?if ;
 143
 144 : check-effect ( word effect -- )
 145     over required-stack-effect 2dup effect<=
 146     [ 3drop ] [ effect-error ] if ;
 147
 148 : finish-word ( word -- )
 149     [ current-effect check-effect ]
 150     [ recorded get push ]
 151     [ t "inferred-effect" set-word-prop ]
 152     tri ;
 153
 154 : cannot-infer-effect ( word -- * )
 155     "cannot-infer" word-prop rethrow ;
 156
 157 : maybe-cannot-infer ( word quot -- )
 158     [ [ "cannot-infer" set-word-prop ] keep throw ] recover ; inline
 159
 160 : infer-word ( word -- effect )
 161     [
 162         [
 163             init-inference
 164             init-known-values
 165             stack-visitor off
 166             dependencies off
 167             generic-dependencies off
 168             [ infer-word-def end-infer ]
 169             [ finish-word ]
 170             [ stack-effect ]
 171             tri
 172         ] with-scope
 173     ] maybe-cannot-infer ;
 174
 175 : apply-word/effect ( word effect -- )
 176     swap '[ _ #call, ] consume/produce ;
 177
 178 : call-recursive-word ( word -- )
 179     dup required-stack-effect apply-word/effect ;
 180
 181 : cached-infer ( word -- )
 182     dup stack-effect apply-word/effect ;
 183
 184 : with-infer ( quot -- effect visitor )
 185     [
 186         [
 187             V{ } clone recorded set
 188             init-inference
 189             init-known-values
 190             stack-visitor off
 191             call
 192             end-infer
 193             current-effect
 194             stack-visitor get
 195         ] [ ] [ undo-infer ] cleanup
 196     ] with-scope ; inline