basis/stack-checker/inlining/inlining.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry namespaces assocs kernel sequences words accessors
   4 definitions math math.order effects classes arrays combinators
   5 vectors hints
   6 stack-checker.state
   7 stack-checker.errors
   8 stack-checker.values
   9 stack-checker.visitor
  10 stack-checker.backend
  11 stack-checker.branches
  12 stack-checker.known-words
  13 stack-checker.dependencies
  14 stack-checker.row-polymorphism
  15 stack-checker.recursive-state ;
  16 IN: stack-checker.inlining
  17
  18 ! Code to handle inline words. Much of the complexity stems from
  19 ! having to handle recursive inline words.
  20
  21 : infer-inline-word-def ( word label -- )
  22     [ drop specialized-def ] [ add-inline-word ] 2bi infer-quot ;
  23
  24 TUPLE: inline-recursive < identity-tuple
  25 id
  26 word
  27 enter-out enter-recursive
  28 return calls
  29 fixed-point
  30 introductions
  31 loop? ;
  32
  33 : inlined-block? ( word -- ? ) "inlined-block" word-prop ;
  34
  35 : <inline-recursive> ( word -- label )
  36     inline-recursive new
  37         gensym dup t "inlined-block" set-word-prop >>id
  38         swap >>word ;
  39
  40 : quotation-param? ( obj -- ? )
  41     dup pair? [ second effect? ] [ drop f ] if ;
  42
  43 : make-copies ( values effect-in -- values' )
  44     [ length cut* ] keep
  45     [ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map
  46     [ length make-values ] dip append ;
  47
  48 SYMBOL: enter-in
  49 SYMBOL: enter-out
  50
  51 : prepare-stack ( word -- )
  52     required-stack-effect in>>
  53     [ length ensure-d drop ] [
  54         meta-d clone enter-in set
  55         meta-d swap make-copies enter-out set
  56     ] bi ;
  57
  58 : emit-enter-recursive ( label -- )
  59     enter-out get >>enter-out
  60     enter-in get enter-out get #enter-recursive,
  61     enter-out get >vector (meta-d) set ;
  62
  63 : entry-stack-height ( label -- stack )
  64     enter-out>> length ;
  65
  66 : check-return ( word label -- )
  67     2dup
  68     [ stack-height ]
  69     [ entry-stack-height current-stack-height swap - ]
  70     bi*
  71     = [ 2drop ] [
  72         terminated? get [ 2drop ] [
  73             word>> current-stack-height
  74             unbalanced-recursion-error inference-error
  75         ] if
  76     ] if ;
  77
  78 : end-recursive-word ( word label -- )
  79     [ check-return ]
  80     [ meta-d dup copy-values dup (meta-d) set #return-recursive, ]
  81     bi ;
  82
  83 : recursive-word-inputs ( label -- n )
  84     entry-stack-height input-count get + ;
  85
  86 : (inline-recursive-word) ( word -- label in out visitor terminated? )
  87     dup prepare-stack
  88     [
  89         init-inference
  90         nest-visitor
  91
  92         dup <inline-recursive>
  93         [ dup emit-enter-recursive infer-inline-word-def ]
  94         [ end-recursive-word ]
  95         [ nip ]
  96         2tri
  97
  98         dup recursive-word-inputs
  99         meta-d
 100         stack-visitor get
 101         terminated? get
 102     ] with-scope ;
 103
 104 : inline-recursive-word ( word -- )
 105     (inline-recursive-word)
 106     [ [ consume-d ] [ output-d ] [ ] tri* #recursive, ] dip
 107     [ terminate ] when ;
 108
 109 : check-call-height ( label -- )
 110     dup entry-stack-height current-stack-height >
 111     [ word>> diverging-recursion-error inference-error ] [ drop ] if ;
 112
 113 : trim-stack ( label seq -- stack )
 114     swap word>> required-stack-effect in>> length tail* ;
 115
 116 : call-site-stack ( label -- stack )
 117     meta-d trim-stack ;
 118
 119 : trimmed-enter-out ( label -- stack )
 120     dup enter-out>> trim-stack ;
 121
 122 GENERIC: (undeclared-known) ( value -- known )
 123 M: object (undeclared-known) ;
 124 M: declared-effect (undeclared-known) known>> (undeclared-known) ;
 125
 126 : undeclared-known ( value -- known ) known (undeclared-known) ;
 127
 128 : check-call-site-stack ( label -- )
 129     [ ] [ call-site-stack ] [ trimmed-enter-out ] tri
 130     [ dup undeclared-known [ [ undeclared-known ] same? ] [ 2drop t ] if ] 2all?
 131     [ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
 132
 133 : check-call ( label -- )
 134     [ check-call-height ] [ check-call-site-stack ] bi ;
 135
 136 : adjust-stack-effect ( effect -- effect' )
 137     [ in>> ] [ out>> ] bi
 138     meta-d length pick length [-]
 139     object <repetition> '[ _ prepend ] bi@
 140     <effect> ;
 141
 142 : call-recursive-inline-word ( word label -- )
 143     over "recursive" word-prop [
 144         [ required-stack-effect adjust-stack-effect ] dip
 145         [ check-call ] [ '[ _ #call-recursive, ] consume/produce ] bi
 146     ] [ drop undeclared-recursion-error inference-error ] if ;
 147
 148 : inline-word ( word -- )
 149     commit-literals
 150     [ add-depends-on-definition ]
 151     [ declare-input-effects ]
 152     [
 153         dup inline-recursive-label [
 154             call-recursive-inline-word
 155         ] [
 156             dup "recursive" word-prop
 157             [ inline-recursive-word ]
 158             [ dup infer-inline-word-def ]
 159             if
 160         ] if*
 161     ] tri ;
 162
 163 M: word apply-object
 164     dup inline? [ inline-word ] [ non-inline-word ] if ;