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