basis/compiler/tree/tree.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry arrays generic assocs kernel math namespaces parser
   4 sequences words vectors math.intervals classes
   5 accessors combinators stack-checker.state stack-checker.visitor
   6 stack-checker.inlining ;
   7 IN: compiler.tree
   8
   9 ! High-level tree SSA form.
  10
  11 TUPLE: node < identity-tuple ;
  12
  13 M: node hashcode* drop node hashcode* ;
  14
  15 TUPLE: #introduce < node out-d ;
  16
  17 : #introduce ( out-d -- node )
  18     \ #introduce new swap >>out-d ;
  19
  20 TUPLE: #call < node word in-d out-d body method class info ;
  21
  22 : #call ( inputs outputs word -- node )
  23     \ #call new
  24         swap >>word
  25         swap >>out-d
  26         swap >>in-d ;
  27
  28 TUPLE: #call-recursive < node label in-d out-d info ;
  29
  30 : #call-recursive ( inputs outputs label -- node )
  31     \ #call-recursive new
  32         swap >>label
  33         swap >>out-d
  34         swap >>in-d ;
  35
  36 TUPLE: #push < node literal out-d ;
  37
  38 : #push ( literal value -- node )
  39     \ #push new
  40         swap 1array >>out-d
  41         swap >>literal ;
  42
  43 TUPLE: #renaming < node ;
  44
  45 TUPLE: #shuffle < #renaming mapping in-d out-d in-r out-r ;
  46
  47 : #shuffle ( in-d out-d in-r out-r mapping -- node )
  48     \ #shuffle new
  49         swap >>mapping
  50         swap >>out-r
  51         swap >>in-r
  52         swap >>out-d
  53         swap >>in-d ;
  54
  55 : #data-shuffle ( in-d out-d mapping -- node )
  56     [ f f ] dip #shuffle ; inline
  57
  58 : #drop ( inputs -- node )
  59     { } { } #data-shuffle ;
  60
  61 TUPLE: #terminate < node in-d in-r ;
  62
  63 : #terminate ( in-d in-r -- node )
  64     \ #terminate new
  65         swap >>in-r
  66         swap >>in-d ;
  67
  68 TUPLE: #branch < node in-d children live-branches ;
  69
  70 : new-branch ( value children class -- node )
  71     new
  72         swap >>children
  73         swap 1array >>in-d ; inline
  74
  75 TUPLE: #if < #branch ;
  76
  77 : #if ( ? true false -- node )
  78     2array \ #if new-branch ;
  79
  80 TUPLE: #dispatch < #branch ;
  81
  82 : #dispatch ( n branches -- node )
  83     \ #dispatch new-branch ;
  84
  85 TUPLE: #phi < node phi-in-d phi-info-d out-d terminated ;
  86
  87 : #phi ( d-phi-in d-phi-out terminated -- node )
  88     \ #phi new
  89         swap >>terminated
  90         swap >>out-d
  91         swap >>phi-in-d ;
  92
  93 TUPLE: #declare < node declaration ;
  94
  95 : #declare ( declaration -- node )
  96     \ #declare new
  97         swap >>declaration ;
  98
  99 TUPLE: #return < node in-d info ;
 100
 101 : #return ( stack -- node )
 102     \ #return new
 103         swap >>in-d ;
 104
 105 TUPLE: #recursive < node in-d word label loop? child ;
 106
 107 : #recursive ( label inputs child -- node )
 108     \ #recursive new
 109         swap >>child
 110         swap >>in-d
 111         swap >>label ;
 112
 113 TUPLE: #enter-recursive < node in-d out-d label info ;
 114
 115 : #enter-recursive ( label inputs outputs -- node )
 116     \ #enter-recursive new
 117         swap >>out-d
 118         swap >>in-d
 119         swap >>label ;
 120
 121 TUPLE: #return-recursive < #renaming in-d out-d label info ;
 122
 123 : #return-recursive ( label inputs outputs -- node )
 124     \ #return-recursive new
 125         swap >>out-d
 126         swap >>in-d
 127         swap >>label ;
 128
 129 TUPLE: #copy < #renaming in-d out-d ;
 130
 131 : #copy ( inputs outputs -- node )
 132     \ #copy new
 133         swap >>out-d
 134         swap >>in-d ;
 135
 136 TUPLE: #alien-node < node params ;
 137
 138 : new-alien-node ( params class -- node )
 139     new
 140         over in-d>> >>in-d
 141         over out-d>> >>out-d
 142         swap >>params ; inline
 143
 144 TUPLE: #alien-invoke < #alien-node in-d out-d ;
 145
 146 : #alien-invoke ( params -- node )
 147     \ #alien-invoke new-alien-node ;
 148
 149 TUPLE: #alien-indirect < #alien-node in-d out-d ;
 150
 151 : #alien-indirect ( params -- node )
 152     \ #alien-indirect new-alien-node ;
 153
 154 TUPLE: #alien-callback < #alien-node ;
 155
 156 : #alien-callback ( params -- node )
 157     \ #alien-callback new
 158         swap >>params ;
 159
 160 : node, ( node -- ) stack-visitor get push ;
 161
 162 GENERIC: inputs/outputs ( #renaming -- inputs outputs )
 163
 164 M: #shuffle inputs/outputs mapping>> unzip swap ;
 165 M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
 166 M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
 167
 168 : recursive-phi-in ( #enter-recursive -- seq )
 169     [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
 170
 171 : ends-with-terminate? ( nodes -- ? )
 172     [ f ] [ peek #terminate? ] if-empty ;
 173
 174 M: vector child-visitor V{ } clone ;
 175 M: vector #introduce, #introduce node, ;
 176 M: vector #call, #call node, ;
 177 M: vector #push, #push node, ;
 178 M: vector #shuffle, #shuffle node, ;
 179 M: vector #drop, #drop node, ;
 180 M: vector #>r, [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
 181 M: vector #r>, [ swap [ f swap ] dip f ] [ swap zip ] 2bi #shuffle, ;
 182 M: vector #return, #return node, ;
 183 M: vector #enter-recursive, #enter-recursive node, ;
 184 M: vector #return-recursive, #return-recursive node, ;
 185 M: vector #call-recursive, #call-recursive node, ;
 186 M: vector #terminate, #terminate node, ;
 187 M: vector #if, #if node, ;
 188 M: vector #dispatch, #dispatch node, ;
 189 M: vector #phi, #phi node, ;
 190 M: vector #declare, #declare node, ;
 191 M: vector #recursive, #recursive node, ;
 192 M: vector #copy, #copy node, ;
 193 M: vector #alien-invoke, #alien-invoke node, ;
 194 M: vector #alien-indirect, #alien-indirect node, ;
 195 M: vector #alien-callback, #alien-callback node, ;