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