basis/stack-checker/inlining/inlining.factor

   1 ! Copyright (C) 2008 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 arrays
   6 stack-checker.state
   7 stack-checker.visitor
   8 stack-checker.backend
   9 stack-checker.branches
  10 stack-checker.errors
  11 stack-checker.known-words ;
  12 IN: stack-checker.inlining
  13
  14 ! Code to handle inline words. Much of the complexity stems from
  15 ! having to handle recursive inline words.
  16
  17 : (inline-word) ( word label -- )
  18     [ [ def>> ] keep ] dip infer-quot-recursive ;
  19
  20 TUPLE: inline-recursive < identity-tuple
  21 id
  22 word
  23 enter-out enter-recursive
  24 return calls
  25 fixed-point
  26 introductions
  27 loop? ;
  28
  29 M: inline-recursive hashcode* id>> hashcode* ;
  30
  31 : inlined-block? ( word -- ? ) "inlined-block" word-prop ;
  32
  33 : <inline-recursive> ( word -- label )
  34     inline-recursive new
  35         gensym dup t "inlined-block" set-word-prop >>id
  36         swap >>word ;
  37
  38 : quotation-param? ( obj -- ? )
  39     dup pair? [ second effect? ] [ drop f ] if ;
  40
  41 : make-copies ( values effect-in -- values' )
  42     [ length cut* ] keep
  43     [ quotation-param? [ copy-value ] [ drop <value> ] if ] 2map
  44     [ make-values ] dip append ;
  45
  46 SYMBOL: enter-in
  47 SYMBOL: enter-out
  48
  49 : prepare-stack ( word -- )
  50     required-stack-effect in>>
  51     [ length ensure-d drop ] [
  52         meta-d get clone enter-in set
  53         meta-d get swap make-copies enter-out set
  54     ] bi ;
  55
  56 : emit-enter-recursive ( label -- )
  57     enter-out get >>enter-out
  58     enter-in get enter-out get #enter-recursive,
  59     enter-out get >vector meta-d set ;
  60
  61 : entry-stack-height ( label -- stack )
  62     enter-out>> length ;
  63
  64 : check-return ( word label -- )
  65     2dup
  66     [ stack-effect effect-height ]
  67     [ entry-stack-height current-stack-height swap - ]
  68     bi*
  69     = [ 2drop ] [
  70         terminated? get [ 2drop ] [
  71             word>> current-stack-height
  72             unbalanced-recursion-error inference-error
  73         ] if
  74     ] if ;
  75
  76 : end-recursive-word ( word label -- )
  77     [ check-return ]
  78     [ meta-d get dup copy-values dup meta-d set #return-recursive, ]
  79     bi ;
  80
  81 : recursive-word-inputs ( label -- n )
  82     entry-stack-height d-in get + ;
  83
  84 : (inline-recursive-word) ( word -- label in out visitor terminated? )
  85     dup prepare-stack
  86     [
  87         init-inference
  88         nest-visitor
  89
  90         dup <inline-recursive>
  91         [ dup emit-enter-recursive (inline-word) ]
  92         [ end-recursive-word ]
  93         [ nip ]
  94         2tri
  95
  96         check->r
  97
  98         dup recursive-word-inputs
  99         meta-d get
 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 get trim-stack ;
 118
 119 : trimmed-enter-out ( label -- stack )
 120     dup enter-out>> trim-stack ;
 121
 122 : check-call-site-stack ( label -- )
 123     [ ] [ call-site-stack ] [ trimmed-enter-out ] tri
 124     [ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all?
 125     [ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
 126
 127 : check-call ( label -- )
 128     [ check-call-height ] [ check-call-site-stack ] bi ;
 129
 130 : adjust-stack-effect ( effect -- effect' )
 131     [ in>> ] [ out>> ] bi
 132     meta-d get length pick length [-]
 133     object <repetition> '[ _ prepend ] bi@
 134     <effect> ;
 135
 136 : call-recursive-inline-word ( word -- )
 137     dup "recursive" word-prop [
 138         [ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
 139         [ 2nip check-call ] [ nip '[ _ #call-recursive, ] consume/produce ] 3bi
 140     ] [ undeclared-recursion-error inference-error ] if ;
 141
 142 : inline-word ( word -- )
 143     [ inlined-dependency depends-on ]
 144     [
 145         {
 146             { [ dup inline-recursive-label ] [ call-recursive-inline-word ] }
 147             { [ dup "recursive" word-prop ] [ inline-recursive-word ] }
 148             [ dup (inline-word) ]
 149         } cond
 150     ] bi ;
 151
 152 M: word apply-object
 153     dup inline? [ inline-word ] [ non-inline-word ] if ;