basis/compiler/tree/tree.factor

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