Skip to content

Commit e74e38c

Browse files
jnthnjnthn
committed
Give PIRT::Sub support for loadlibs, name, subid and pirflags; also emit calls.
1 parent 544a992 commit e74e38c

File tree

2 files changed

+128
-5
lines changed

2 files changed

+128
-5
lines changed

‎src/QAST/PIRT.nqp‎

Lines changed: 76 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -3,10 +3,27 @@
33
# in QAST::Compiler. Since the mapping is pretty close, the nodes themselves
44
# know how to become PIR.
55

6+
class PIRT::CallResult {
7+
has str $!result;
8+
9+
method new(:$result!) {
10+
my $obj := nqp::create(self);
11+
nqp::bindattr_s($obj, PIRT::CallResult, '$!result',
12+
$result ~~ PIRT::Node ?? $result.result !! $result);
13+
$obj
14+
}
15+
16+
method result() {
17+
$!result
18+
}
19+
}
20+
621
class PIRT::Node {
722
my %op_compilers := nqp::hash(
823
'call', sub (@args) {
9-
nqp::die("NYI");
24+
" " ~
25+
($*HAS_RESULT ?? @args.shift() ~ " = " !! '') ~
26+
@args.shift() ~ "(" ~ nqp::join(", ", @args) ~ ")"
1027
},
1128
'callmethod', sub (@args) {
1229
nqp::die("NYI");
@@ -33,16 +50,25 @@ class PIRT::Node {
3350
my $i := 1;
3451
my $c := nqp::elems($_);
3552
my $arg;
53+
my $*HAS_RESULT := 0;
54+
my $result;
3655
while $i < $c {
3756
$arg := $_[$i];
3857
if $arg ~~ PIRT::Node {
3958
nqp::push(@op_args, $arg.result);
4059
}
60+
elsif $arg ~~ PIRT::CallResult {
61+
$result := $arg.result;
62+
$*HAS_RESULT := 1;
63+
}
4164
else {
4265
nqp::push(@op_args, $arg);
4366
}
4467
$i := $i + 1;
4568
}
69+
if $*HAS_RESULT {
70+
nqp::unshift(@op_args, $result);
71+
}
4672
if nqp::existskey(%op_compilers, $op_name) {
4773
nqp::push(@parts, %op_compilers{$op_name}(@op_args));
4874
}
@@ -67,9 +93,23 @@ class PIRT::Node {
6793

6894
class PIRT::Sub is PIRT::Node {
6995
has @!children;
96+
has str $!subid;
97+
has str $!pirflags;
98+
has str $!name;
99+
has @!loadlibs;
100+
70101
has @!nested_blocks;
71102
has str $!cached_pir;
72103

104+
method escape($str) {
105+
my $esc := pir::escape__Ss($str);
106+
nqp::index($esc, '\x', 0) >= 0 ??
107+
'utf8:"' ~ $esc ~ '"' !!
108+
(nqp::index($esc, '\u', 0) >= 0 ??
109+
'unicode:"' ~ $esc ~ '"' !!
110+
'"' ~ $esc ~ '"')
111+
}
112+
73113
method new() {
74114
my $obj := nqp::create(self);
75115
nqp::bindattr($obj, PIRT::Sub, '@!children', nqp::list());
@@ -80,10 +120,29 @@ class PIRT::Sub is PIRT::Node {
80120
nqp::push(@!children, $node);
81121
}
82122

83-
method push_pirop(*@opbits) {
123+
method push_pirop(*@opbits, :$result) {
124+
if $result {
125+
nqp::push(@opbits, PIRT::CallResult.new($result));
126+
}
84127
nqp::push(@!children, @opbits)
85128
}
86129

130+
method subid(*@value) {
131+
@value ?? ($!subid := @value[0]) !! $!subid
132+
}
133+
134+
method pirflags(*@value) {
135+
@value ?? ($!pirflags := @value[0]) !! $!pirflags
136+
}
137+
138+
method name(*@value) {
139+
@value ?? ($!name := @value[0]) !! $!name
140+
}
141+
142+
method loadlibs(@libs?) {
143+
@libs ?? (@!loadlibs := @libs) !! @!loadlibs
144+
}
145+
87146
method result() {
88147
nqp::die("Cannot use a PIRT::Sub in a context expecting a result");
89148
}
@@ -92,7 +151,17 @@ class PIRT::Sub is PIRT::Node {
92151
my @parts;
93152

94153
# Sub prelude.
95-
nqp::push(@parts, ".sub ''");
154+
for @!loadlibs {
155+
nqp::push(@parts, ".loadlib " ~ self.escape($_));
156+
}
157+
my $sub_decl := ".sub " ~ self.escape($!name || '');
158+
if $!subid {
159+
$sub_decl := $sub_decl ~ " :subid(" ~ self.escape($!subid) ~ ")";
160+
}
161+
if $!pirflags {
162+
$sub_decl := $sub_decl ~ ' ' ~ $!pirflags
163+
}
164+
nqp::push(@parts, $sub_decl);
96165

97166
# Compile sub contents, collecting any nested blocks.
98167
my @*PIRT_BLOCKS;
@@ -138,7 +207,10 @@ class PIRT::Ops is PIRT::Node {
138207
nqp::push(@!children, $node)
139208
}
140209

141-
method push_pirop(*@opbits) {
210+
method push_pirop(*@opbits, :$result) {
211+
if $result {
212+
nqp::push(@opbits, PIRT::CallResult.new($result));
213+
}
142214
nqp::push(@!children, @opbits)
143215
}
144216

‎t/qast/pirt.t‎

Lines changed: 52 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
use QAST;
22

3-
plan(3);
3+
plan(5);
44

55
sub is_pirt_result($producer, $expected, $desc) {
66
my $pirt := $producer();
@@ -54,3 +54,54 @@ is_pirt_result({
5454
},
5555
"c'est l'awesome",
5656
"Basic use of labels");
57+
58+
is_pirt_result({
59+
# Create a nested sub.
60+
my $n_ops := PIRT::Ops.new();
61+
$n_ops.push_pirop('return', '"nested sub"');
62+
my $n_sub := PIRT::Sub.new();
63+
$n_sub.push($n_ops);
64+
$n_sub.subid('n_sub');
65+
66+
# Create the outer sub that looks it up and calls it.
67+
my $ops := PIRT::Ops.new();
68+
$ops.push($n_sub);
69+
$ops.push_pirop(".const 'Sub' \$P0 = 'n_sub'");
70+
$ops.push_pirop('call', '$P0', :result('$S0'));
71+
$ops.push_pirop('concat', '$S1', '$S0', '" outer sub"');
72+
$ops.push_pirop('return', '$S1');
73+
my $sub := PIRT::Sub.new();
74+
$sub.push($ops);
75+
76+
$sub
77+
},
78+
"nested sub outer sub",
79+
"Calling subs");
80+
81+
is_pirt_result({
82+
# Create a nested sub that looks up a lexical.
83+
my $n_ops := PIRT::Ops.new();
84+
$n_ops.push_pirop('find_lex', '$P0', '"$foo"');
85+
$n_ops.push_pirop('return', '$P0');
86+
my $n_sub := PIRT::Sub.new();
87+
$n_sub.push($n_ops);
88+
$n_sub.subid('n_sub');
89+
$n_sub.pirflags(':outer("o_sub")');
90+
91+
# Create the outer sub that looks it up and calls it.
92+
my $ops := PIRT::Ops.new();
93+
$ops.push($n_sub);
94+
$ops.push_pirop('box', '$P1', '"lexicals work!"');
95+
$ops.push_pirop('.lex', '"$foo"', '$P1');
96+
$ops.push_pirop(".const 'Sub' \$P0 = 'n_sub'");
97+
$ops.push_pirop('capture_lex', '$P0');
98+
$ops.push_pirop('call', '$P0', :result('$S0'));
99+
$ops.push_pirop('return', '$S0');
100+
my $sub := PIRT::Sub.new();
101+
$sub.push($ops);
102+
$sub.subid('o_sub');
103+
104+
$sub
105+
},
106+
'lexicals work!',
107+
"pirflags emitted correctly");

0 commit comments

Comments
 (0)