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 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: namespaces => set ;
  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 : pop-d  ( -- obj )
  21     meta-d [ <value> dup 1array introduce-values ] [ pop ] if-empty ;
  22
  23 : peek-d ( -- obj ) pop-d dup push-d ;
  24
  25 : make-values ( n -- values )
  26     [ <value> ] replicate ;
  27
  28 : ensure-d ( n -- values )
  29     meta-d 2dup length > [
  30         2dup
  31         [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
  32         [ introduce-values ] [ meta-d push-all ] bi
  33         meta-d push-all
  34     ] when swap tail* ;
  35
  36 : shorten-by ( n seq -- )
  37     [ length swap - ] keep shorten ; inline
  38
  39 : consume-d ( n -- seq )
  40     [ ensure-d ] [ meta-d shorten-by ] bi ;
  41
  42 : output-d ( values -- ) meta-d push-all ;
  43
  44 : produce-d ( n -- values )
  45     make-values dup meta-d push-all ;
  46
  47 : push-r ( obj -- ) meta-r push ;
  48
  49 : pop-r ( -- obj )
  50     meta-r dup empty?
  51     [ too-many-r> ] [ pop ] if ;
  52
  53 : consume-r ( n -- seq )
  54     meta-r 2dup length >
  55     [ too-many-r> ] when
  56     [ swap tail* ] [ shorten-by ] 2bi ;
  57
  58 : output-r ( seq -- ) meta-r push-all ;
  59
  60 : push-literal ( obj -- )
  61     literals get push ;
  62
  63 : pop-literal ( -- rstate obj )
  64     literals get [
  65         pop-d
  66         [ 1array #drop, ]
  67         [ literal [ recursion>> ] [ value>> ] bi ] bi
  68     ] [ pop recursive-state get swap ] if-empty ;
  69
  70 : literals-available? ( n -- literals ? )
  71     literals get 2dup length <=
  72     [ [ swap tail* ] [ shorten-by ] 2bi t ] [ 2drop f f ] if ;
  73
  74 GENERIC: apply-object ( obj -- )
  75
  76 M: wrapper apply-object
  77     wrapped>>
  78     [ dup word? [ depends-on-effect ] [ drop ] if ]
  79     [ push-literal ]
  80     bi ;
  81
  82 M: object apply-object push-literal ;
  83
  84 : terminate ( -- )
  85     terminated? on meta-d clone meta-r clone #terminate, ;
  86
  87 : check->r ( -- )
  88     meta-r empty? [ too-many->r ] unless ;
  89
  90 : infer-quot-here ( quot -- )
  91     meta-r [
  92         V{ } clone \ meta-r set
  93         [ apply-object terminated? get not ] all?
  94         [ commit-literals check->r ] [ literals get delete-all ] if
  95     ] dip \ meta-r set ;
  96
  97 : infer-quot ( quot rstate -- )
  98     recursive-state get [
  99         recursive-state set
 100         infer-quot-here
 101     ] dip recursive-state set ;
 102
 103 : time-bomb ( error -- )
 104     '[ _ throw ] infer-quot-here ;
 105
 106 ERROR: bad-call obj ;
 107
 108 M: bad-call summary
 109     drop "call must be given a callable" ;
 110
 111 : infer-literal-quot ( literal -- )
 112     dup recursive-quotation? [
 113         value>> recursive-quotation-error
 114     ] [
 115         dup value>> callable? [
 116             [ value>> ]
 117             [ [ recursion>> ] keep add-local-quotation ]
 118             bi infer-quot
 119         ] [
 120             value>> \ bad-call boa time-bomb
 121         ] if
 122     ] if ;
 123
 124 : infer->r ( n -- )
 125     consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
 126
 127 : infer-r> ( n -- )
 128     consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
 129
 130 : consume/produce ( effect quot: ( inputs outputs -- ) -- )
 131     '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ]
 132     [ terminated?>> [ terminate ] when ]
 133     bi ; inline
 134
 135 : apply-word/effect ( word effect -- )
 136     swap '[ _ #call, ] consume/produce ;
 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 : infer-word ( word -- )
 145     {
 146         { [ dup macro? ] [ do-not-compile ] }
 147         { [ dup "no-compile" word-prop ] [ do-not-compile ] }
 148         [ dup required-stack-effect apply-word/effect ]
 149     } cond ;
 150
 151 : with-infer ( quot -- effect visitor )
 152     [
 153         init-inference
 154         init-known-values
 155         stack-visitor off
 156         call
 157         end-infer
 158         current-effect
 159         stack-visitor get
 160     ] with-scope ; inline