|
| 1 | +# PIRT is a very lightweight PIR tree representation. It does very little |
| 2 | +# really, besides being much more pleasant than working with strings directly |
| 3 | +# in QAST::Compiler. Since the mapping is pretty close, the nodes themselves |
| 4 | +# know how to become PIR. |
| 5 | + |
| 6 | +class PIRT::Node { |
| 7 | + my %op_compilers := nqp::hash( |
| 8 | + 'call', sub (@args) { |
| 9 | + nqp::die("NYI"); |
| 10 | + }, |
| 11 | + 'callmethod', sub (@args) { |
| 12 | + nqp::die("NYI"); |
| 13 | + }, |
| 14 | + 'return', sub (@args) { |
| 15 | + " .return (" ~ nqp::join(", ", @args) ~ ")" |
| 16 | + }, |
| 17 | + 'yield', sub (@args) { |
| 18 | + nqp::die("NYI"); |
| 19 | + }, |
| 20 | + 'tailcall', sub (@args) { |
| 21 | + nqp::die("NYI"); |
| 22 | + }, |
| 23 | + 'inline', sub (@args) { |
| 24 | + nqp::die("NYI"); |
| 25 | + }); |
| 26 | + |
| 27 | + method children_pir(@children) { |
| 28 | + my @parts; |
| 29 | + for @children { |
| 30 | + if nqp::islist($_) { |
| 31 | + my $op_name := $_[0]; |
| 32 | + my @op_args; |
| 33 | + my $i := 1; |
| 34 | + my $c := nqp::elems($_); |
| 35 | + my $arg; |
| 36 | + while $i < $c { |
| 37 | + $arg := $_[$i]; |
| 38 | + if $arg ~~ PIRT::Node { |
| 39 | + nqp::push(@op_args, $arg.result); |
| 40 | + } |
| 41 | + else { |
| 42 | + nqp::push(@op_args, $arg); |
| 43 | + } |
| 44 | + $i := $i + 1; |
| 45 | + } |
| 46 | + if nqp::existskey(%op_compilers, $op_name) { |
| 47 | + nqp::push(@parts, %op_compilers{$op_name}(@op_args)); |
| 48 | + } |
| 49 | + else { |
| 50 | + nqp::push(@parts, ' ' ~ $op_name ~ ' ' ~ nqp::join(", ", @op_args)); |
| 51 | + } |
| 52 | + } |
| 53 | + elsif $_ ~~ PIRT::Sub { |
| 54 | + nqp::push(@*PIRT_BLOCKS, $_); |
| 55 | + } |
| 56 | + elsif $_ ~~ PIRT::Node { |
| 57 | + my $pir := $_.pir; |
| 58 | + nqp::push(@parts, $pir) unless $pir eq ''; |
| 59 | + } |
| 60 | + else { |
| 61 | + nqp::die("Unexpected object in PIRT tree"); |
| 62 | + } |
| 63 | + } |
| 64 | + nqp::join("\n", @parts) |
| 65 | + } |
| 66 | +} |
| 67 | + |
| 68 | +class PIRT::Sub is PIRT::Node { |
| 69 | + has @!children; |
| 70 | + has @!nested_blocks; |
| 71 | + has str $!cached_pir; |
| 72 | + |
| 73 | + method new() { |
| 74 | + my $obj := nqp::create(self); |
| 75 | + nqp::bindattr($obj, PIRT::Sub, '@!children', nqp::list()); |
| 76 | + $obj |
| 77 | + } |
| 78 | + |
| 79 | + method push($node) { |
| 80 | + nqp::push(@!children, $node); |
| 81 | + } |
| 82 | + |
| 83 | + method push_pirop(*@opbits) { |
| 84 | + nqp::push(@!children, @opbits) |
| 85 | + } |
| 86 | + |
| 87 | + method result() { |
| 88 | + nqp::die("Cannot use a PIRT::Sub in a context expecting a result"); |
| 89 | + } |
| 90 | + |
| 91 | + method close_sub() { |
| 92 | + my @parts; |
| 93 | + |
| 94 | + # Sub prelude. |
| 95 | + nqp::push(@parts, ".sub ''"); |
| 96 | + |
| 97 | + # Compile sub contents, collecting any nested blocks. |
| 98 | + my @*PIRT_BLOCKS; |
| 99 | + nqp::push(@parts, self.children_pir(@!children)); |
| 100 | + |
| 101 | + # Sub postlude. |
| 102 | + nqp::push(@parts, ".end"); |
| 103 | + |
| 104 | + # Store the compiled PIR and collected inner blocks. Also, null out |
| 105 | + # the children array, to free up memory. |
| 106 | + $!cached_pir := nqp::join("\n", @parts); |
| 107 | + @!nested_blocks := @*PIRT_BLOCKS; |
| 108 | + } |
| 109 | + |
| 110 | + method pir() { |
| 111 | + # If we don't already have the sub body, then close the sub now. |
| 112 | + unless $!cached_pir { |
| 113 | + self.close_sub(); |
| 114 | + } |
| 115 | + |
| 116 | + # Our PIR is ourselve plus the PIR of any nested blocks. |
| 117 | + my @parts := [$!cached_pir]; |
| 118 | + for @!nested_blocks { |
| 119 | + nqp::push(@parts, $_.pir()); |
| 120 | + } |
| 121 | + nqp::join("\n", @parts) |
| 122 | + } |
| 123 | +} |
| 124 | + |
| 125 | +class PIRT::Ops is PIRT::Node { |
| 126 | + has @!children; |
| 127 | + has str $!result; |
| 128 | + |
| 129 | + method new(:$result = '') { |
| 130 | + my $obj := nqp::create(self); |
| 131 | + nqp::bindattr($obj, PIRT::Ops, '@!children', nqp::list()); |
| 132 | + nqp::bindattr_s($obj, PIRT::Ops, '$!result', |
| 133 | + $result ~~ PIRT::Node ?? $result.result !! $result); |
| 134 | + $obj |
| 135 | + } |
| 136 | + |
| 137 | + method push($node) { |
| 138 | + nqp::push(@!children, $node) |
| 139 | + } |
| 140 | + |
| 141 | + method push_pirop(*@opbits) { |
| 142 | + nqp::push(@!children, @opbits) |
| 143 | + } |
| 144 | + |
| 145 | + method result(*@value) { |
| 146 | + if @value { |
| 147 | + $!result := @value[0] ~~ PIRT::Node ?? @value[0].result !! @value[0]; |
| 148 | + } |
| 149 | + else { |
| 150 | + $!result |
| 151 | + } |
| 152 | + } |
| 153 | + |
| 154 | + method pir() { |
| 155 | + self.children_pir(@!children) |
| 156 | + } |
| 157 | +} |
| 158 | + |
| 159 | +class PIRT::Label is PIRT::Node { |
| 160 | + has str $!name; |
| 161 | + |
| 162 | + method new(:$name!) { |
| 163 | + my $obj := nqp::create(self); |
| 164 | + nqp::bindattr_s($obj, PIRT::Label, '$!name', $name); |
| 165 | + $obj |
| 166 | + } |
| 167 | + |
| 168 | + method name(*@value) { |
| 169 | + @value ?? ($!name := @value[0]) !! $!name |
| 170 | + } |
| 171 | + |
| 172 | + method result() { |
| 173 | + $!name |
| 174 | + } |
| 175 | + |
| 176 | + method pir() { |
| 177 | + ' ' ~ $!name ~ ':' |
| 178 | + } |
| 179 | +} |
0 commit comments