basis/stack-checker/backend/backend.factor

   1 ! Copyright (C) 2004, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry arrays generic io io.streams.string kernel math namespaces
   4 parser sequences strings vectors words quotations effects classes
   5 continuations assocs combinators compiler.errors accessors math.order
   6 definitions locals sets hints macros stack-checker.state
   7 stack-checker.visitor stack-checker.errors stack-checker.values
   8 stack-checker.recursive-state stack-checker.dependencies summary ;
   9 FROM: sequences.private => from-end ;
  10 FROM: namespaces => set ;
  11 IN: stack-checker.backend
  12
  13 : push-d ( obj -- ) meta-d push ;
  14
  15 : introduce-values ( values -- )
  16     [ [ [ input-parameter ] dip set-known ] each ]
  17     [ length input-count +@ ]
  18     [ #introduce, ]
  19     tri ;
  20
  21 : update-inner-d ( new -- )
  22     inner-d-index get min inner-d-index set ;
  23
  24 : pop-d  ( -- obj )
  25     meta-d
  26     [ <value> dup 1array introduce-values ]
  27     [ pop meta-d length update-inner-d ] if-empty ;
  28
  29 : peek-d ( -- obj ) pop-d dup push-d ;
  30
  31 : make-values ( n -- values )
  32     [ <value> ] replicate ;
  33
  34 : ensure-d ( n -- values )
  35     meta-d 2dup length > [
  36         2dup
  37         [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
  38         [ introduce-values ] [ meta-d push-all ] bi
  39         meta-d push-all
  40     ] when
  41     swap from-end [ tail ] [ update-inner-d ] bi ;
  42
  43 : shorten-by ( n seq -- )
  44     [ length swap - ] keep shorten ; inline
  45
  46 : shorten-d ( n -- )
  47     meta-d shorten-by meta-d length update-inner-d ;
  48
  49 : consume-d ( n -- seq )
  50     [ ensure-d ] [ shorten-d ] bi ;
  51
  52 : output-d ( values -- ) meta-d push-all ;
  53
  54 : produce-d ( n -- values )
  55     make-values dup meta-d push-all ;
  56
  57 : push-r ( obj -- ) meta-r push ;
  58
  59 : pop-r ( -- obj )
  60     meta-r dup empty?
  61     [ too-many-r> ] [ pop ] if ;
  62
  63 : consume-r ( n -- seq )
  64     meta-r 2dup length >
  65     [ too-many-r> ] when
  66     [ swap tail* ] [ shorten-by ] 2bi ;
  67
  68 : output-r ( seq -- ) meta-r push-all ;
  69
  70 : push-literal ( obj -- )
  71     literals get push ;
  72
  73 : pop-literal ( -- rstate obj )
  74     literals get [
  75         pop-d
  76         [ 1array #drop, ]
  77         [ literal [ recursion>> ] [ value>> ] bi ] bi
  78     ] [ pop recursive-state get swap ] if-empty ;
  79
  80 : literals-available? ( n -- literals ? )
  81     literals get 2dup length <=
  82     [ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ;
  83
  84 GENERIC: apply-object ( obj -- )
  85
  86 M: wrapper apply-object
  87     wrapped>>
  88     [ dup word? [ add-depends-on-effect ] [ drop ] if ]
  89     [ push-literal ]
  90     bi ;
  91
  92 M: object apply-object push-literal ;
  93
  94 : terminate ( -- )
  95     terminated? on meta-d clone meta-r clone #terminate, ;
  96
  97 : check->r ( -- )
  98     meta-r empty? [ too-many->r ] unless ;
  99
 100 : infer-quot-here ( quot -- )
 101     meta-r [
 102         V{ } clone (meta-r) set
 103         [ apply-object terminated? get not ] all?
 104         [ commit-literals check->r ] [ literals get delete-all ] if
 105     ] dip (meta-r) set ;
 106
 107 : infer-quot ( quot rstate -- )
 108     recursive-state get [
 109         recursive-state set
 110         infer-quot-here
 111     ] dip recursive-state set ;
 112
 113 : time-bomb-quot ( obj generic -- quot )
 114     [ literalize ] [ "default-method" word-prop ] bi* [ ] 2sequence ;
 115
 116 : time-bomb ( obj generic -- )
 117     time-bomb-quot infer-quot-here ;
 118
 119 : infer-literal-quot ( literal -- )
 120     dup recursive-quotation? [
 121         value>> recursive-quotation-error
 122     ] [
 123         dup value>> callable? [
 124             [ value>> ]
 125             [ [ recursion>> ] keep add-local-quotation ]
 126             bi infer-quot
 127         ] [
 128             value>> \ call time-bomb
 129         ] if
 130     ] if ;
 131
 132 : infer->r ( n -- )
 133     consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
 134
 135 : infer-r> ( n -- )
 136     consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
 137
 138 : consume/produce ( ..a effect quot: ( ..a inputs outputs -- ..b ) -- ..b )
 139     '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ]
 140     [ terminated?>> [ terminate ] when ]
 141     bi ; inline
 142
 143 : apply-word/effect ( word effect -- )
 144     swap '[ _ #call, ] consume/produce ;
 145
 146 : end-infer ( -- )
 147     meta-d clone #return, ;
 148
 149 : required-stack-effect ( word -- effect )
 150     dup stack-effect [ ] [ missing-effect ] ?if ;
 151
 152 : with-infer ( quot -- effect visitor )
 153     [
 154         init-inference
 155         init-known-values
 156         stack-visitor off
 157         call
 158         end-infer
 159         current-effect
 160         stack-visitor get
 161     ] with-scope ; inline
 162
 163 : (infer) ( quot -- effect )
 164     [ infer-quot-here ] with-infer drop ;
 165
 166 : ?quotation-effect ( in -- effect/f )
 167     dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ;
 168
 169 :: declare-effect-d ( word effect variables branches n -- )
 170     meta-d length :> d-length
 171     n d-length < [
 172         d-length 1 - n - :> n'
 173         n' meta-d nth :> value
 174         value known :> known
 175         known word effect variables branches <declared-effect> :> known'
 176         known' value set-known
 177         known' branches push
 178     ] [ word unknown-macro-input ] if ;
 179
 180 :: declare-input-effects ( word -- )
 181     H{ } clone :> variables
 182     V{ } clone :> branches
 183     word stack-effect in>> <reversed> [| in n |
 184         in ?quotation-effect [| effect |
 185             word effect variables branches n declare-effect-d
 186         ] when*
 187     ] each-index ;