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