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 effects 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 ;
  46
  47 : #shuffle ( inputs outputs mapping -- node )
  48     \ #shuffle new
  49         swap >>mapping
  50         swap >>out-d
  51         swap >>in-d ;
  52
  53 : #drop ( inputs -- node )
  54     { } { } #shuffle ;
  55
  56 TUPLE: #>r < #renaming in-d out-r ;
  57
  58 : #>r ( inputs outputs -- node )
  59     \ #>r new
  60         swap >>out-r
  61         swap >>in-d ;
  62
  63 TUPLE: #r> < #renaming in-r out-d ;
  64
  65 : #r> ( inputs outputs -- node )
  66     \ #r> new
  67         swap >>out-d
  68         swap >>in-r ;
  69
  70 TUPLE: #terminate < node in-d in-r ;
  71
  72 : #terminate ( in-d in-r -- node )
  73     \ #terminate new
  74         swap >>in-r
  75         swap >>in-d ;
  76
  77 TUPLE: #branch < node in-d children live-branches ;
  78
  79 : new-branch ( value children class -- node )
  80     new
  81         swap >>children
  82         swap 1array >>in-d ; inline
  83
  84 TUPLE: #if < #branch ;
  85
  86 : #if ( ? true false -- node )
  87     2array \ #if new-branch ;
  88
  89 TUPLE: #dispatch < #branch ;
  90
  91 : #dispatch ( n branches -- node )
  92     \ #dispatch new-branch ;
  93
  94 TUPLE: #phi < node phi-in-d phi-info-d out-d terminated ;
  95
  96 : #phi ( d-phi-in d-phi-out terminated -- node )
  97     \ #phi new
  98         swap >>terminated
  99         swap >>out-d
 100         swap >>phi-in-d ;
 101
 102 TUPLE: #declare < node declaration ;
 103
 104 : #declare ( declaration -- node )
 105     \ #declare new
 106         swap >>declaration ;
 107
 108 TUPLE: #return < node in-d info ;
 109
 110 : #return ( stack -- node )
 111     \ #return new
 112         swap >>in-d ;
 113
 114 TUPLE: #recursive < node in-d word label loop? child ;
 115
 116 : #recursive ( label inputs child -- node )
 117     \ #recursive new
 118         swap >>child
 119         swap >>in-d
 120         swap >>label ;
 121
 122 TUPLE: #enter-recursive < node in-d out-d label info ;
 123
 124 : #enter-recursive ( label inputs outputs -- node )
 125     \ #enter-recursive new
 126         swap >>out-d
 127         swap >>in-d
 128         swap >>label ;
 129
 130 TUPLE: #return-recursive < #renaming in-d out-d label info ;
 131
 132 : #return-recursive ( label inputs outputs -- node )
 133     \ #return-recursive new
 134         swap >>out-d
 135         swap >>in-d
 136         swap >>label ;
 137
 138 TUPLE: #copy < #renaming in-d out-d ;
 139
 140 : #copy ( inputs outputs -- node )
 141     \ #copy new
 142         swap >>out-d
 143         swap >>in-d ;
 144
 145 TUPLE: #alien-node < node params ;
 146
 147 : new-alien-node ( params class -- node )
 148     new
 149         over in-d>> >>in-d
 150         over out-d>> >>out-d
 151         swap >>params ; inline
 152
 153 TUPLE: #alien-invoke < #alien-node in-d out-d ;
 154
 155 : #alien-invoke ( params -- node )
 156     \ #alien-invoke new-alien-node ;
 157
 158 TUPLE: #alien-indirect < #alien-node in-d out-d ;
 159
 160 : #alien-indirect ( params -- node )
 161     \ #alien-indirect new-alien-node ;
 162
 163 TUPLE: #alien-callback < #alien-node ;
 164
 165 : #alien-callback ( params -- node )
 166     \ #alien-callback new
 167         swap >>params ;
 168
 169 : node, ( node -- ) stack-visitor get push ;
 170
 171 GENERIC: inputs/outputs ( #renaming -- inputs outputs )
 172
 173 M: #shuffle inputs/outputs mapping>> unzip swap ;
 174 M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ;
 175 M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
 176 M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
 177 M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
 178
 179 : shuffle-effect ( #shuffle -- effect )
 180     [ in-d>> ] [ out-d>> ] [ mapping>> ] tri
 181     '[ _ at ] map
 182     <effect> ;
 183
 184 : recursive-phi-in ( #enter-recursive -- seq )
 185     [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
 186
 187 : ends-with-terminate? ( nodes -- ? )
 188     [ f ] [ peek #terminate? ] if-empty ;
 189
 190 M: vector child-visitor V{ } clone ;
 191 M: vector #introduce, #introduce node, ;
 192 M: vector #call, #call node, ;
 193 M: vector #push, #push node, ;
 194 M: vector #shuffle, #shuffle node, ;
 195 M: vector #drop, #drop node, ;
 196 M: vector #>r, #>r node, ;
 197 M: vector #r>, #r> node, ;
 198 M: vector #return, #return node, ;
 199 M: vector #enter-recursive, #enter-recursive node, ;
 200 M: vector #return-recursive, #return-recursive node, ;
 201 M: vector #call-recursive, #call-recursive node, ;
 202 M: vector #terminate, #terminate node, ;
 203 M: vector #if, #if node, ;
 204 M: vector #dispatch, #dispatch node, ;
 205 M: vector #phi, #phi node, ;
 206 M: vector #declare, #declare node, ;
 207 M: vector #recursive, #recursive node, ;
 208 M: vector #copy, #copy node, ;
 209 M: vector #alien-invoke, #alien-invoke node, ;
 210 M: vector #alien-indirect, #alien-indirect node, ;
 211 M: vector #alien-callback, #alien-callback node, ;