core/compiler/inference/inference.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: inference
   4 USING: arrays errors generic io kernel
   5 math namespaces parser prettyprint sequences strings
   6 vectors words tools ;
   7
   8 TUPLE: inference-error rstate major? ;
   9
  10 C: inference-error ( msg rstate important? -- error )
  11     [ set-inference-error-major? ] keep
  12     [ set-inference-error-rstate ] keep
  13     [ set-delegate ] keep ;
  14
  15 : inference-error ( msg -- * )
  16     recursive-state get t <inference-error> throw ;
  17
  18 : inference-warning ( msg -- * )
  19     recursive-state get f <inference-error> throw ;
  20
  21 TUPLE: literal-expected ;
  22
  23 M: object value-literal
  24     <literal-expected> inference-warning ;
  25
  26 : pop-literal ( -- rstate obj )
  27     1 #drop node,
  28     pop-d dup value-recursion swap value-literal ;
  29
  30 : value-vector ( n -- vector ) [ drop <computed> ] map >vector ;
  31
  32 : add-inputs ( seq stack -- n stack )
  33     tuck [ length ] 2apply - dup 0 >
  34     [ dup value-vector [ rot nappend ] keep ]
  35     [ drop 0 swap ] if ;
  36
  37 : ensure-values ( seq -- )
  38     meta-d [ add-inputs ] change d-in [ + ] change ;
  39
  40 SYMBOL: terminated?
  41
  42 : current-effect ( -- effect )
  43     d-in get meta-d get length <effect>
  44     terminated? get over set-effect-terminated? ;
  45
  46 SYMBOL: recorded
  47
  48 : init-inference ( recursive-state -- )
  49     terminated? off
  50     V{ } clone meta-d set
  51     V{ } clone meta-r set
  52     V{ } clone meta-n set
  53     empty-vars inferred-vars set
  54     0 d-in set
  55     recursive-state set
  56     dataflow-graph off
  57     current-node off ;
  58
  59 GENERIC: apply-object ( obj -- )
  60
  61 : apply-literal ( obj -- )
  62     #push dup node,
  63     swap <value> push-d
  64     1 d-tail swap set-node-out-d ;
  65
  66 M: object apply-object apply-literal ;
  67
  68 M: wrapper apply-object wrapped apply-literal ;
  69
  70 GENERIC: apply-word ( word -- )
  71
  72 M: word apply-object apply-word ;
  73
  74 : terminate ( -- )
  75     terminated? on #terminate node, ;
  76
  77 GENERIC: infer-quot ( quot -- )
  78
  79 M: f infer-quot drop ;
  80
  81 M: quotation infer-quot
  82     [ apply-object terminated? get not ] all? drop ;
  83
  84 : infer-quot-value ( rstate quot -- )
  85     recursive-state get >r swap recursive-state set
  86     infer-quot r> recursive-state set ;
  87
  88 TUPLE: too-many->r ;
  89
  90 : check->r ( -- )
  91     meta-r get empty? [
  92         <too-many->r> inference-error
  93     ] unless ;
  94
  95 TUPLE: too-many-r> ;
  96
  97 : check-r> ( -- )
  98     meta-r get empty? [
  99         <too-many-r>> inference-error
 100     ] when ;
 101
 102 : undo-infer ( -- )
 103     recorded get [ custom-infer? not ] subset [
 104         dup
 105         f "inferred-vars" set-word-prop
 106         f "inferred-effect" set-word-prop
 107     ] each ;
 108
 109 : with-infer ( quot -- )
 110     [
 111         [
 112             { } recursive-state set
 113             V{ } clone recorded set
 114             f init-inference
 115             call
 116             check->r
 117         ] [
 118             undo-infer
 119             rethrow
 120         ] recover
 121     ] with-scope ;
 122
 123 : infer ( quot -- effect infer-vars )
 124     [ infer-quot inferred-vars get current-effect ] with-infer ;
 125
 126 : vars. ( seq str -- )
 127     over empty? [ 2drop ] [ print [ . ] each ] if ;
 128
 129 : infer. ( quot -- )
 130     infer
 131     "* Stack effect:" print effect>string print
 132     dup inferred-vars-reads "* Reads free variables:" vars.
 133     dup inferred-vars-writes "* Writes free variables:" vars.
 134     dup inferred-vars-reads-globals "* Reads global variables:" vars.
 135     inferred-vars-writes-globals "* Writes global variables:" vars. ;
 136
 137 : (dataflow) ( quot -- dataflow )
 138     infer-quot f #return node, dataflow-graph get ;
 139
 140 : dataflow ( quot -- dataflow )
 141     [ (dataflow) ] with-infer ;
 142
 143 : dataflow-with ( quot stack -- effect )
 144     [ meta-d set (dataflow) ] with-infer ;