core/compiler/inference/variables.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: inference
   4 USING: kernel sequences hashtables kernel-internals words
   5 namespaces generic vectors namespaces ;
   6
   7 ! Name stack and variable binding simulation
   8 SYMBOL: meta-n
   9
  10 : push-n meta-n get push ;
  11 : pop-n meta-n get pop ;
  12 : peek-n meta-n get peek ;
  13
  14 TUPLE: inferred-vars reads writes reads-globals writes-globals ;
  15
  16 : vars-trivial? ( vars -- ? ) tuple-slots [ empty? ] all? ;
  17
  18 : empty-vars ( -- vars )
  19     V{ } clone V{ } clone V{ } clone V{ } clone
  20     <inferred-vars> ;
  21
  22 : apply-var-seq ( seq -- )
  23     inferred-vars [
  24         >r [ tuple-slots ] map r> tuple-slots add flip
  25         [ concat prune >vector ] map first4 <inferred-vars>
  26     ] change ;
  27
  28 : apply-var-read ( symbol -- )
  29     dup meta-n get [ hash-member? ] contains-with? [
  30         drop
  31     ] [
  32         inferred-vars get 2dup inferred-vars-writes member? [
  33             2drop
  34         ] [
  35             inferred-vars-reads push-new
  36         ] if
  37     ] if ;
  38
  39 : apply-var-write ( symbol -- )
  40     meta-n get empty? [
  41         inferred-vars get inferred-vars-writes push-new
  42     ] [
  43         dup peek-n set-hash
  44     ] if ;
  45
  46 : apply-global-read ( symbol -- )
  47     inferred-vars get
  48     2dup inferred-vars-writes-globals member? [
  49         2drop
  50     ] [
  51         inferred-vars-reads-globals push-new
  52     ] if ;
  53
  54 : apply-global-write ( symbol -- )
  55     inferred-vars get inferred-vars-writes-globals push-new ;
  56
  57 : apply-vars ( vars -- )
  58     [
  59         dup inferred-vars-reads [ apply-var-read ] each
  60         dup inferred-vars-writes [ apply-var-write ] each
  61         dup inferred-vars-reads-globals [ apply-global-read ] each
  62         inferred-vars-writes-globals [ apply-global-write ] each
  63     ] when* ;