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