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