← Back to branch summary

~ubuntu-branches/ubuntu/vivid/nqp/vivid-proposed

« back to all changes in this revision

Viewing changes to src/vm/parrot/QAST/Operations.nqp

  • Committer: Package Import Robot
  • Author(s): Alessandro Ghedini
  • Date: 2013-11-01 12:09:18 UTC
  • mfrom: (1.1.4)
  • Revision ID: package-import@ubuntu.com-20131101120918-kx51sl0sxl3exsxi
Tags: 2013.10-1
* New upstream release
* Bump versioned (Build-)Depends on parrot
* Update patches
* Install new README.pod
* Fix vcs-field-not-canonical
* Do not install rubyish examples
* Do not Depends on parrot-devel anymore
* Add 07_disable-serialization-tests.patch

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/vm/parrot/QAST/Operations.nqp
 
1
use NQPHLL;
 
2
 
 
3
class QAST::Operations {
 
4
    # Maps operations to code that will handle them. Hash of code.
 
5
    my %core_ops;
 
6
 
 
7
    # Maps HLL-specific operations to code that will handle them.
 
8
    # Hash of hash of code.
 
9
    my %hll_ops;
 
10
 
 
11
    # Cached pirop compilers.
 
12
    my %cached_pirops;
 
13
 
 
14
    # Mapping of how to box/unbox by HLL.
 
15
    my %hll_box;
 
16
    my %hll_unbox;
 
17
 
 
18
    # What we know about inlinability.
 
19
    my %core_inlinability;
 
20
    my %hll_inlinability;
 
21
 
 
22
    # What we know about op native results types.
 
23
    my %core_result_type;
 
24
    my %hll_result_type;
 
25
 
 
26
    # Compiles an operation to POST.
 
27
    method compile_op($qastcomp, $hll, $op) {
 
28
        my $name := $op.op;
 
29
        if $hll {
 
30
            if %hll_ops{$hll} && %hll_ops{$hll}{$name} -> $mapper {
 
31
                return $mapper($qastcomp, $op);
 
32
            }
 
33
        }
 
34
        if %core_ops{$name} -> $mapper {
 
35
            return $mapper($qastcomp, $op);
 
36
        }
 
37
        nqp::die("No registered operation handler for '$name'");
 
38
    }
 
39
 
 
40
    # Compiles a PIR operation.
 
41
    method compile_pirop($qastcomp, $op_name, @op_args) {
 
42
        if nqp::index($op_name, ' ') {
 
43
            $op_name := nqp::join('__', nqp::split(' ', $op_name));
 
44
        }
 
45
        unless nqp::existskey(%cached_pirops, $op_name) {
 
46
            my @pieces := nqp::split('__', $op_name);
 
47
            %cached_pirops{$op_name} := pirop_mapper(@pieces[0], @pieces[1]);
 
48
        }
 
49
        %cached_pirops{$op_name}($qastcomp, $op_name, @op_args)
 
50
    }
 
51
 
 
52
    # Adds a core op handler.
 
53
    method add_core_op($op, $handler, :$inlinable = 0) {
 
54
        %core_ops{$op} := $handler;
 
55
        self.set_core_op_inlinability($op, $inlinable);
 
56
    }
 
57
 
 
58
    # Adds a HLL op handler.
 
59
    method add_hll_op($hll, $op, $handler, :$inlinable = 0) {
 
60
        %hll_ops{$hll} := {} unless nqp::existskey(%hll_ops, $hll);
 
61
        %hll_ops{$hll}{$op} := $handler;
 
62
        self.set_hll_op_inlinability($hll, $op, $inlinable);
 
63
    }
 
64
 
 
65
    # Adds a core op that maps to a PIR op.
 
66
    method add_core_pirop_mapping($op, $pirop, $sig, :$inlinable = 0) {
 
67
        my $pirop_mapper := pirop_mapper($pirop, $sig);
 
68
        %core_ops{$op} := -> $qastcomp, $op {
 
69
            $pirop_mapper($qastcomp, $op.op, $op.list)
 
70
        };
 
71
        self.set_core_op_inlinability($op, $inlinable);
 
72
        self.set_core_op_result_type($op, nqp::substr($sig, 0, 1));
 
73
    }
 
74
 
 
75
    # Adds a HLL op that maps to a PIR op.
 
76
    method add_hll_pirop_mapping($hll, $op, $pirop, $sig, :$inlinable = 0) {
 
77
        my $pirop_mapper := pirop_mapper($pirop, $sig);
 
78
        %hll_ops{$hll} := {} unless nqp::existskey(%hll_ops, $hll);
 
79
        %hll_ops{$hll}{$op} := -> $qastcomp, $op {
 
80
            $pirop_mapper($qastcomp, $op.op, $op.list)
 
81
        };
 
82
        self.set_hll_op_inlinability($hll, $op, $inlinable);
 
83
        self.set_hll_op_result_type($hll, $op, nqp::substr($sig, 0, 1));
 
84
    }
 
85
 
 
86
    # Sets op inlinability at a core level.
 
87
    method set_core_op_inlinability($op, $inlinable) {
 
88
        %core_inlinability{$op} := $inlinable;
 
89
    }
 
90
 
 
91
    # Sets op inlinability at a HLL level. (Can override at HLL level whether
 
92
    # or not the HLL overrides the op itself.)
 
93
    method set_hll_op_inlinability($hll, $op, $inlinable) {
 
94
        %hll_inlinability{$hll} := {} unless nqp::existskey(%hll_inlinability, $hll);
 
95
        %hll_inlinability{$hll}{$op} := $inlinable;
 
96
    }
 
97
 
 
98
    # Checks if an op is considered inlinable.
 
99
    method is_inlinable($hll, $op) {
 
100
        if nqp::existskey(%hll_inlinability, $hll) {
 
101
            if nqp::existskey(%hll_inlinability{$hll}, $op) {
 
102
                return %hll_inlinability{$hll}{$op};
 
103
            }
 
104
        }
 
105
        return %core_inlinability{$op} // 0;
 
106
    }
 
107
 
 
108
    # Sets op native result type at a core level.
 
109
    method set_core_op_result_type($op, $type_char) {
 
110
        if $type_char eq 'I' {
 
111
            %core_result_type{$op} := int;
 
112
        }
 
113
        elsif $type_char eq 'N' {
 
114
            %core_result_type{$op} := num;
 
115
        }
 
116
        elsif $type_char eq 'S' {
 
117
            %core_result_type{$op} := str;
 
118
        }
 
119
    }
 
120
 
 
121
    # Sets op inlinability at a HLL level. (Can override at HLL level whether
 
122
    # or not the HLL overrides the op itself.)
 
123
    method set_hll_op_result_type($hll, $op, $type_char) {
 
124
        %hll_result_type{$hll} := {} unless nqp::existskey(%hll_result_type, $hll);
 
125
        if $type_char eq 'I' {
 
126
            %hll_result_type{$hll}{$op} := int;
 
127
        }
 
128
        elsif $type_char eq 'N' {
 
129
            %hll_result_type{$hll}{$op} := num;
 
130
        }
 
131
        elsif $type_char eq 'S' {
 
132
            %hll_result_type{$hll}{$op} := str;
 
133
        }
 
134
    }
 
135
 
 
136
    # Sets returns on an op node if we it has a native result type.
 
137
    method attach_result_type($hll, $node) {
 
138
        my $op := $node.op;
 
139
        if nqp::existskey(%hll_result_type, $hll) {
 
140
            if nqp::existskey(%hll_result_type{$hll}, $op) {
 
141
                $node.returns(%hll_result_type{$hll}{$op});
 
142
                return 1;
 
143
            }
 
144
        }
 
145
        if nqp::existskey(%core_result_type, $op) {
 
146
            $node.returns(%core_result_type{$op});
 
147
        }
 
148
    }
 
149
 
 
150
    # Adds a HLL box handler.
 
151
    method add_hll_box($hll, $type, $handler) {
 
152
        unless $type eq 'i' || $type eq 'n' || $type eq 's' {
 
153
            nqp::die("Unknown box type '$type'");
 
154
        }
 
155
        %hll_box{$hll} := {} unless nqp::existskey(%hll_box, $hll);
 
156
        %hll_box{$hll}{$type} := $handler;
 
157
    }
 
158
 
 
159
    # Adds a HLL unbox handler.
 
160
    method add_hll_unbox($hll, $type, $handler) {
 
161
        unless $type eq 'i' || $type eq 'n' || $type eq 's' {
 
162
            nqp::die("Unknown unbox type '$type'");
 
163
        }
 
164
        %hll_unbox{$hll} := {} unless nqp::existskey(%hll_unbox, $hll);
 
165
        %hll_unbox{$hll}{$type} := $handler;
 
166
    }
 
167
 
 
168
    # Generates a box. Takes a POST tree.
 
169
    method box($qastcomp, $hll, $type, $post) {
 
170
        (%hll_box{$hll}{$type} // %hll_box{'nqp'}{$type})($qastcomp, $post)
 
171
    }
 
172
 
 
173
    # Generates an unbox. Takes a POST tree.
 
174
    method unbox($qastcomp, $hll, $type, $post) {
 
175
        (%hll_unbox{$hll}{$type} // %hll_unbox{'nqp'}{$type})($qastcomp, $post)
 
176
    }
 
177
 
 
178
    # Returns a mapper closure for turning an operation into a PIR op.
 
179
    # The signature argument consists of characters indicating the
 
180
    # register types and conversions.  The characters are:
 
181
    #    P,S,I,N   PMC, string, int, or num register
 
182
    #    Q         keyed PMC, next character indicates type of key
 
183
    #    s         string register or constant
 
184
    #    i         int register or constant
 
185
    #    n         num register or constant
 
186
    #    r         any register result
 
187
    #    v         void (no result)
 
188
    #    0-9       use the nth input operand as the output result of this operation
 
189
    sub pirop_mapper($pirop, $sig) {
 
190
        # Parse arg types out.
 
191
        my @arg_types := nqp::split('', $sig);
 
192
        my $ret_type  := @arg_types.shift();
 
193
 
 
194
        # Work out register method for return type, if any.
 
195
        my $ret_meth;
 
196
        if $ret_type eq 'P'    { $ret_meth := "fresh_p"; }
 
197
        elsif $ret_type eq 'S' { $ret_meth := "fresh_s"; }
 
198
        elsif $ret_type eq 'I' { $ret_meth := "fresh_i"; }
 
199
        elsif $ret_type eq 'N' { $ret_meth := "fresh_n"; }
 
200
 
 
201
        -> $qastcomp, $op_name, @op_args {
 
202
            my $ops := PIRT::Ops.new();
 
203
 
 
204
            # If we need a result register, create it and make it the
 
205
            # first argument.
 
206
            my @args;
 
207
            if $ret_meth {
 
208
                my $reg := $*REGALLOC."$ret_meth"();
 
209
                @args.push($reg);
 
210
                $ops.result($reg);
 
211
            }
 
212
 
 
213
            # Build the arguments list.
 
214
            my $num_args := +@op_args;
 
215
            if +@arg_types != $num_args {
 
216
                nqp::die("Operation '$op_name' requires " ~
 
217
                    +@arg_types ~ " operands, but got $num_args");
 
218
            }
 
219
            my $i := 0;
 
220
            my $last_argtype_was_Q := 0;
 
221
            my $aggregate := '';
 
222
            while $i < $num_args {
 
223
                my $arg_type := @arg_types[$i];
 
224
                my $operand  := @op_args[$i];
 
225
                if $arg_type eq 'Q' {
 
226
                    my $post := $qastcomp.coerce($qastcomp.as_post($operand), 'P');
 
227
                    $ops.push($post);
 
228
                    $aggregate := $post.result;
 
229
                    $last_argtype_was_Q := 1;
 
230
                }
 
231
                elsif $last_argtype_was_Q {
 
232
                    if $arg_type ne 'P' {
 
233
                        $operand := $qastcomp.apply_context($operand, $arg_type);
 
234
                    }
 
235
                    my $post := $qastcomp.coerce($qastcomp.as_post($operand), $arg_type);
 
236
                    $ops.push($post);
 
237
                    @args.push("$aggregate[" ~ $post.result ~ "]");
 
238
                    $last_argtype_was_Q := 0;
 
239
                }
 
240
                else {
 
241
                    if $arg_type ne 'P' {
 
242
                        $operand := $qastcomp.apply_context($operand, $arg_type);
 
243
                    }
 
244
                    my $post := $qastcomp.coerce($qastcomp.as_post($operand), $arg_type);
 
245
                    $ops.push($post);
 
246
                    @args.push($post.result);
 
247
                }
 
248
                $i := $i + 1;
 
249
            }
 
250
 
 
251
            # If we have an integer as the return type, find the arg that
 
252
            # becomes the result.
 
253
            if !$ret_meth && $ret_type ne 'v' && +$ret_type eq $ret_type {
 
254
                my $rreg := @args[+$ret_type];
 
255
                my $brak := nqp::index($rreg, '[');
 
256
                if $brak > 0 {
 
257
                    $rreg := nqp::substr($rreg, $brak + 1, nqp::chars($rreg) - ($brak + 2));
 
258
                }
 
259
                $ops.result($rreg);
 
260
            }
 
261
 
 
262
            # Construct and return the op.
 
263
            $ops.push_pirop($pirop, |@args);
 
264
            $ops
 
265
        }
 
266
    }
 
267
}
 
268
 
 
269
# Data structures
 
270
QAST::Operations.add_core_op('list', :inlinable(1), -> $qastcomp, $op {
 
271
    # Create register for the resulting list and make an empty one.
 
272
    my $list_reg := $*REGALLOC.fresh_p();
 
273
    my $ops := PIRT::Ops.new(:result($list_reg));
 
274
    $ops.push_pirop('new', $list_reg, "'ResizablePMCArray'");
 
275
 
 
276
    # Push all the things.
 
277
    for $op.list {
 
278
        my $post := $qastcomp.coerce($qastcomp.as_post($_), 'P');
 
279
        $ops.push($post);
 
280
        $ops.push_pirop('push', $list_reg, $post.result);
 
281
    }
 
282
 
 
283
    $ops
 
284
});
 
285
 
 
286
QAST::Operations.add_core_op('qlist', :inlinable(1), -> $qastcomp, $op {
 
287
    # Create register for the resulting list and make an empty one.
 
288
    my $list_reg := $*REGALLOC.fresh_p();
 
289
    my $ops := PIRT::Ops.new(:result($list_reg));
 
290
    $ops.push_pirop('new', $list_reg, "'QRPA'");
 
291
 
 
292
    # Push all the things.
 
293
    for $op.list {
 
294
        my $post := $qastcomp.coerce($qastcomp.as_post($_), 'P');
 
295
        $ops.push($post);
 
296
        $ops.push_pirop('push', $list_reg, $post.result);
 
297
    }
 
298
 
 
299
    $ops
 
300
});
 
301
 
 
302
QAST::Operations.add_core_op('list_i', :inlinable(1), -> $qastcomp, $op {
 
303
    # Create register for the resulting list and make an empty one.
 
304
    my $list_reg := $*REGALLOC.fresh_p();
 
305
    my $ops := PIRT::Ops.new(:result($list_reg));
 
306
    $ops.push_pirop('new', $list_reg, "'ResizableIntegerArray'");
 
307
 
 
308
    # Push all the things.
 
309
    for $op.list {
 
310
        my $post := $qastcomp.coerce($qastcomp.as_post($_), 'i');
 
311
        $ops.push($post);
 
312
        $ops.push_pirop('push', $list_reg, $post.result);
 
313
    }
 
314
 
 
315
    $ops
 
316
});
 
317
 
 
318
QAST::Operations.add_core_op('list_s', :inlinable(1), -> $qastcomp, $op {
 
319
    # Create register for the resulting list and make an empty one.
 
320
    my $list_reg := $*REGALLOC.fresh_p();
 
321
    my $ops := PIRT::Ops.new(:result($list_reg));
 
322
    $ops.push_pirop('new', $list_reg, "'ResizableStringArray'");
 
323
 
 
324
    # Push all the things.
 
325
    for $op.list {
 
326
        my $post := $qastcomp.coerce($qastcomp.as_post($_), 's');
 
327
        $ops.push($post);
 
328
        $ops.push_pirop('push', $list_reg, $post.result);
 
329
    }
 
330
 
 
331
    $ops
 
332
});
 
333
 
 
334
QAST::Operations.add_core_op('list_b', :inlinable(1), -> $qastcomp, $op {
 
335
    # Create register for the resulting list and make an empty one.
 
336
    my $list_reg := $*REGALLOC.fresh_p();
 
337
    my $ops := PIRT::Ops.new(:result($list_reg));
 
338
    $ops.push_pirop('new', $list_reg, "'ResizablePMCArray'");
 
339
 
 
340
    # Push all the things.
 
341
    my $block_reg := $*REGALLOC.fresh_p();
 
342
    for $op.list {
 
343
        my $cuid := $_.cuid;
 
344
        $ops.push_pirop(".const 'Sub' $block_reg = \"$cuid\"");
 
345
        $ops.push_pirop('push', $list_reg, $block_reg);
 
346
    }
 
347
 
 
348
    $ops
 
349
});
 
350
 
 
351
QAST::Operations.add_core_op('hash', :inlinable(1), -> $qastcomp, $op {
 
352
    # Create register for the resulting hash and make an empty one.
 
353
    my $hash_reg := $*REGALLOC.fresh_p();
 
354
    my $ops := PIRT::Ops.new(:result($hash_reg));
 
355
    $ops.push_pirop('new', $hash_reg, "'Hash'");
 
356
 
 
357
    # Set all the values by key on the hash.
 
358
    my $i := 0;
 
359
    my @op_list := $op.list;
 
360
    while $i < +@op_list {
 
361
        my $kpost := $qastcomp.coerce($qastcomp.as_post(@op_list[$i]), 's');
 
362
        $ops.push($kpost);
 
363
        $i := $i + 1;
 
364
 
 
365
        my $vpost := $qastcomp.coerce($qastcomp.as_post(@op_list[$i]), 'P');
 
366
        $ops.push($vpost);
 
367
        $i := $i + 1;
 
368
 
 
369
        $ops.push_pirop('set', $hash_reg ~ '[' ~ $kpost.result ~ ']', $vpost.result);
 
370
    }
 
371
 
 
372
    $ops
 
373
});
 
374
 
 
375
# Chaining.
 
376
QAST::Operations.add_core_op('chain', :inlinable(1), -> $qastcomp, $op {
 
377
    # First, we build up the list of nodes in the chain
 
378
    my @clist;
 
379
    my $cpast := $op;
 
380
    while $cpast ~~ QAST::Op && $cpast.op eq 'chain' {
 
381
        nqp::push(@clist, $cpast);
 
382
        $cpast := $cpast[0];
 
383
    }
 
384
 
 
385
    my $ops := PIRT::Ops.new(:result($*REGALLOC.fresh_p()));
 
386
    my $endlabel := PIRT::Label.new(:name($qastcomp.unique('chain_end_')));
 
387
 
 
388
    $cpast := nqp::pop(@clist);
 
389
    my $apast := $cpast[0];
 
390
    my $apost := $qastcomp.coerce($qastcomp.as_post($apast), 'P');
 
391
    $ops.push($apost);
 
392
 
 
393
    my $more := 1;
 
394
    while $more {
 
395
        my $bpast := $cpast[1];
 
396
        my $bpost := $qastcomp.coerce($qastcomp.as_post($bpast), 'P');
 
397
        $ops.push($bpost);
 
398
 
 
399
        my $name := $qastcomp.escape($cpast.name());
 
400
        $ops.push_pirop('call', $name, $apost, $bpost, :result($ops));
 
401
 
 
402
        if @clist {
 
403
            $ops.push_pirop('unless', $ops, $endlabel);
 
404
            $cpast := nqp::pop(@clist);
 
405
            $apost := $bpost;
 
406
        }
 
407
        else {
 
408
            $more := 0;
 
409
        }
 
410
    }
 
411
 
 
412
    $ops.push($endlabel);
 
413
    $ops
 
414
});
 
415
 
 
416
 
 
417
# Set of sequential statements
 
418
QAST::Operations.add_core_op('stmts', :inlinable(1), -> $qastcomp, $op {
 
419
    $qastcomp.as_post(QAST::Stmts.new( |@($op) ))
 
420
});
 
421
 
 
422
# Conditionals.
 
423
for <if unless> -> $op_name {
 
424
    QAST::Operations.add_core_op($op_name, :inlinable(1), -> $qastcomp, $op {
 
425
        # Check operand count.
 
426
        my $operands := +$op.list;
 
427
        nqp::die("Operation '$op_name' needs either 2 or 3 operands")
 
428
            if $operands < 2 || $operands > 3;
 
429
 
 
430
        # Create labels.
 
431
        my $if_id    := $qastcomp.unique($op_name);
 
432
        my $else_lbl := PIRT::Label.new(:name($if_id ~ '_else'));
 
433
        my $end_lbl  := PIRT::Label.new(:name($if_id ~ '_end'));
 
434
 
 
435
        # Compile each of the children; we'll need to look at the result
 
436
        # types and pick an overall result type if in non-void context.
 
437
        my @comp_ops;
 
438
        my @op_types;
 
439
        my @im_args;
 
440
        for $op.list {
 
441
            my $*HAVE_IMM_ARG := $_.arity > 0 && !($_ =:= $op[0]);
 
442
            my $*IMM_ARG;
 
443
            my $comp := $qastcomp.as_post($_);
 
444
            @comp_ops.push($comp);
 
445
            @op_types.push(nqp::uc($qastcomp.infer_type($comp.result)));
 
446
            if $*HAVE_IMM_ARG {
 
447
                if $*IMM_ARG {
 
448
                    @im_args.push($*IMM_ARG);
 
449
                }
 
450
                else {
 
451
                    nqp::die("$op_name block expects an argument, but there's no immediate block to take it");
 
452
                }
 
453
            }
 
454
        }
 
455
        my $res_type;
 
456
        my $res_reg;
 
457
        if $*WANT ne 'v' {
 
458
            $res_type := $operands == 3 ??
 
459
                (@op_types[1] eq @op_types[2] ?? nqp::lc(@op_types[1]) !! 'p') !!
 
460
                (@op_types[0] eq @op_types[1] ?? nqp::lc(@op_types[0]) !! 'p');
 
461
            $res_reg := $*REGALLOC."fresh_$res_type"();
 
462
        }
 
463
 
 
464
        # Evaluate the condition first; store result if needed.
 
465
        my $ops := PIRT::Ops.new();
 
466
        my $cond_result;
 
467
        if $res_reg && $operands == 2 {
 
468
            my $coerced := $qastcomp.coerce(@comp_ops[0], $res_type);
 
469
            $ops.push($coerced);
 
470
            $ops.push_pirop('set', $res_reg, $coerced.result);
 
471
            $cond_result := $coerced;
 
472
        }
 
473
        else {
 
474
            $ops.push(@comp_ops[0]);
 
475
            $cond_result := @comp_ops[0];
 
476
        }
 
477
 
 
478
        # If needed, set up passing condition value to blocks.
 
479
        for @im_args {
 
480
            $_($cond_result.result);
 
481
        }
 
482
 
 
483
        # Emit the jump.
 
484
        $ops.push_pirop(($op_name eq 'if' ?? 'unless ' !! 'if ') ~
 
485
            @comp_ops[0].result ~ ' goto ' ~
 
486
            ($operands == 2 ?? $end_lbl.result !! $else_lbl.result));
 
487
 
 
488
        # Emit the then; stash the result.
 
489
        if $res_reg {
 
490
            my $then := $qastcomp.coerce(@comp_ops[1], $res_type);
 
491
            $ops.push($then);
 
492
            $ops.push_pirop('set', $res_reg, $then.result);
 
493
        }
 
494
        else {
 
495
            $ops.push(@comp_ops[1]);
 
496
        }
 
497
 
 
498
        # Handle else branch if needed.
 
499
        if $operands == 3 {
 
500
            $ops.push_pirop('goto', $end_lbl.result);
 
501
            $ops.push($else_lbl);
 
502
            if $res_reg {
 
503
                my $else := $qastcomp.coerce(@comp_ops[2], $res_type);
 
504
                $ops.push($else);
 
505
                $ops.push_pirop('set', $res_reg, $else.result);
 
506
            }
 
507
            else {
 
508
                $ops.push(@comp_ops[2]);
 
509
            }
 
510
        }
 
511
 
 
512
        # Emit end label and tag ops with result.
 
513
        $ops.push($end_lbl);
 
514
        $ops.result($res_reg || 'null');
 
515
        $ops;
 
516
    });
 
517
}
 
518
 
 
519
# XXX make 3-arg...
 
520
QAST::Operations.add_core_op('ifnull', :inlinable(1), -> $qastcomp, $op {
 
521
    if +$op.list != 2 {
 
522
        nqp::die("The 'ifnull' op expects two children");
 
523
    }
 
524
 
 
525
    my $exprpost := $qastcomp.as_post($op[0]);
 
526
    my $vivipost := $qastcomp.coerce($qastcomp.as_post($op[1]),
 
527
        $qastcomp.infer_type($exprpost.result));
 
528
    my $vivlabel := PIRT::Label.new(:name($qastcomp.unique('vivi_')));
 
529
 
 
530
    my $ops := PIRT::Ops.new();
 
531
    $ops.push($exprpost);
 
532
    $ops.push_pirop('unless_null', $exprpost, $vivlabel);
 
533
    $ops.push($vivipost);
 
534
    $ops.push_pirop('set', $exprpost, $vivipost);
 
535
    $ops.push($vivlabel);
 
536
    $ops.result($exprpost.result);
 
537
    $ops
 
538
});
 
539
 
 
540
# Loops.
 
541
for ('', 'repeat_') -> $repness {
 
542
    for <while until> -> $op_name {
 
543
        QAST::Operations.add_core_op("$repness$op_name", :inlinable(1), -> $qastcomp, $op {
 
544
            # Create labels.
 
545
            my $while_id := $qastcomp.unique($op_name);
 
546
            my $test_lbl := PIRT::Label.new(:name($while_id ~ '_test'));
 
547
            my $next_lbl := PIRT::Label.new(:name($while_id ~ '_next'));
 
548
            my $redo_lbl := PIRT::Label.new(:name($while_id ~ '_redo'));
 
549
            my $hand_lbl := PIRT::Label.new(:name($while_id ~ '_handlers'));
 
550
            my $done_lbl := PIRT::Label.new(:name($while_id ~ '_done'));
 
551
 
 
552
            # Compile each of the children; we'll need to look at the result
 
553
            # types and pick an overall result type if in non-void context.
 
554
            my @comp_ops;
 
555
            my @comp_types;
 
556
            my $handler := 1;
 
557
            my $*IMM_ARG;
 
558
            for $op.list {
 
559
                if $_.named eq 'nohandler' { $handler := 0; }
 
560
                else {
 
561
                    my $*HAVE_IMM_ARG := $_.arity > 0 && $_ =:= $op.list[1];
 
562
                    my $comp := $qastcomp.as_post($_);
 
563
                    @comp_ops.push($comp);
 
564
                    @comp_types.push($qastcomp.infer_type($comp.result));
 
565
                    if $*HAVE_IMM_ARG && !$*IMM_ARG {
 
566
                        nqp::die("$op_name block expects an argument, but there's no immediate block to take it");
 
567
                    }
 
568
                }
 
569
            }
 
570
            my $res_type := @comp_types[0] eq @comp_types[1] ?? nqp::lc(@comp_types[0]) !! 'p';
 
571
            my $res_reg  := $*REGALLOC."fresh_$res_type"();
 
572
 
 
573
            # Check operand count.
 
574
            my $operands := +@comp_ops;
 
575
            nqp::die("Operation '$repness$op_name' needs 2 or 3 operands")
 
576
                if $operands != 2 && $operands != 3;
 
577
 
 
578
            # Emit the prelude.
 
579
            my $ops := PIRT::Ops.new();
 
580
            $ops.result($res_reg);
 
581
 
 
582
            my $exc_reg;
 
583
            if $handler {
 
584
                $exc_reg := $*REGALLOC.fresh_p();
 
585
                $ops.push_pirop('new', $exc_reg, "'ExceptionHandler'",
 
586
                    '[.CONTROL_LOOP_NEXT;.CONTROL_LOOP_REDO;.CONTROL_LOOP_LAST]');
 
587
                $ops.push_pirop('set_label', $exc_reg, $hand_lbl);
 
588
                $ops.push_pirop('push_eh', $exc_reg);
 
589
            }
 
590
 
 
591
            # Test the condition and jump to the loop end if it's
 
592
            # not met.
 
593
            my $coerced := $qastcomp.coerce(@comp_ops[0], $res_type);
 
594
            if $repness {
 
595
                # It's a repeat_ variant, need to go straight into the
 
596
                # loop body unconditionally. Be sure to set the register
 
597
                # for the result to something first.
 
598
                if $res_type eq 'p' || $res_type eq 's' {
 
599
                    $ops.push_pirop('null', $res_reg);
 
600
                }
 
601
                else {
 
602
                    $ops.push_pirop('set', $res_reg, '0');
 
603
                }
 
604
                $ops.push_pirop('goto', $redo_lbl);
 
605
            }
 
606
            $ops.push($test_lbl);
 
607
            $ops.push($coerced);
 
608
            $ops.push_pirop('set', $res_reg, $coerced.result);
 
609
            $ops.push_pirop(($op_name eq 'while' ?? 'unless ' !! 'if ') ~
 
610
                @comp_ops[0].result ~ ' goto ' ~ $done_lbl.result);
 
611
 
 
612
            # Handle immediate blocks wanting the value as an arg.
 
613
            if $*IMM_ARG {
 
614
                $*IMM_ARG($res_reg);
 
615
            }
 
616
 
 
617
            # Emit the loop body; stash the result.
 
618
            my $body := $qastcomp.coerce(@comp_ops[1], $res_type);
 
619
            $ops.push($redo_lbl);
 
620
            $ops.push($body);
 
621
            $ops.push_pirop('set', $res_reg, $body.result);
 
622
 
 
623
            # If there's a third child, evaluate it as part of the
 
624
            # "next".
 
625
            if $operands == 3 {
 
626
                $ops.push($next_lbl);
 
627
                $ops.push(@comp_ops[2]);
 
628
            }
 
629
 
 
630
            # Emit the iteration jump.
 
631
            $ops.push_pirop('goto ' ~ $test_lbl.result);
 
632
 
 
633
            # Emit postlude, with exception handlers.
 
634
            if $handler {
 
635
                $ops.push($hand_lbl);
 
636
                $ops.push_pirop('.get_results', '(' ~ $exc_reg ~ ')');
 
637
                $ops.push_pirop('pop_upto_eh', $exc_reg);
 
638
                $ops.push_pirop('getattribute', $exc_reg, $exc_reg, "'type'");
 
639
                $ops.push_pirop('eq', $exc_reg, '.CONTROL_LOOP_NEXT',
 
640
                    $operands == 3 ?? $next_lbl !! $test_lbl);
 
641
                $ops.push_pirop('eq', $exc_reg, '.CONTROL_LOOP_REDO', $redo_lbl);
 
642
                $ops.push($done_lbl);
 
643
                $ops.push_pirop('pop_eh');
 
644
            }
 
645
            else {
 
646
                $ops.push($done_lbl);
 
647
            }
 
648
 
 
649
            $ops;
 
650
        });
 
651
    }
 
652
}
 
653
 
 
654
QAST::Operations.add_core_op('for', :inlinable(1), -> $qastcomp, $op {
 
655
    my $handler := 1;
 
656
    my @operands;
 
657
    for $op.list {
 
658
        if $_.named eq 'nohandler' { $handler := 0; }
 
659
        else { @operands.push($_) }
 
660
    }
 
661
 
 
662
    if +@operands != 2 {
 
663
        nqp::die("Operation 'for' needs 2 operands");
 
664
    }
 
665
    unless nqp::istype(@operands[1], QAST::Block) {
 
666
        nqp::die("Operation 'for' expects a block as its second operand");
 
667
    }
 
668
    if @operands[1].blocktype eq 'immediate' {
 
669
        @operands[1].blocktype('declaration');
 
670
    }
 
671
    elsif @operands[1].blocktype eq 'immediate_static' {
 
672
        @operands[1].blocktype('declaration_static');
 
673
    }
 
674
 
 
675
    # Evaluate the thing we'll iterate over and the block.
 
676
    my $res       := $*REGALLOC.fresh_p();
 
677
    my $curval    := $*REGALLOC.fresh_p();
 
678
    my $iter      := $*REGALLOC.fresh_p();
 
679
    my $ops       := PIRT::Ops.new();
 
680
    my $listpost  := $qastcomp.coerce($qastcomp.as_post(@operands[0]), "P");
 
681
    my $blockpost := $qastcomp.coerce($qastcomp.as_post(@operands[1]), "P");
 
682
    $ops.push($listpost);
 
683
 
 
684
    # Get the iterator.
 
685
    $ops.push_pirop('set', $res, $listpost);
 
686
    $ops.push_pirop('iter', $iter, $listpost);
 
687
 
 
688
    # Set up exception handler.
 
689
    my $exc_reg;
 
690
    my $hand_lbl;
 
691
    if $handler {
 
692
        $exc_reg  := $*REGALLOC.fresh_p();
 
693
        $hand_lbl := PIRT::Label.new(:name('for_handlers'));
 
694
        $ops.push_pirop('new', $exc_reg, "'ExceptionHandler'",
 
695
            '[.CONTROL_LOOP_NEXT;.CONTROL_LOOP_REDO;.CONTROL_LOOP_LAST]');
 
696
        $ops.push_pirop('set_label', $exc_reg, $hand_lbl);
 
697
        $ops.push_pirop('push_eh', $exc_reg);
 
698
    }
 
699
 
 
700
    # Loop while we still have values.
 
701
    my $lbl_next := PIRT::Label.new(:name('for_next'));
 
702
    my $lbl_redo := PIRT::Label.new(:name('for_redo'));
 
703
    my $lbl_done := PIRT::Label.new(:name('for_done'));
 
704
    $ops.push($lbl_next);
 
705
    $ops.push_pirop('unless', $iter, $lbl_done);
 
706
 
 
707
    # Fetch values.
 
708
    my @valreg;
 
709
    my $arity := @operands[1].arity || 1;
 
710
    while $arity > 0 {
 
711
        my $reg := $*REGALLOC.fresh_p();
 
712
        $ops.push_pirop('shift', $reg, $iter);
 
713
        nqp::push(@valreg, $reg);
 
714
        $arity := $arity - 1;
 
715
    }
 
716
 
 
717
    # Emit call.
 
718
    $ops.push($lbl_redo);
 
719
    $ops.push($blockpost);
 
720
    $ops.push_pirop('call', $blockpost, |@valreg, :result($res));
 
721
 
 
722
    # Loop.
 
723
    $ops.push_pirop('goto', $lbl_next);
 
724
 
 
725
    # Handlers.
 
726
    if $handler {
 
727
        $ops.push($hand_lbl);
 
728
        $ops.push_pirop('.get_results', '(' ~ $exc_reg ~ ')');
 
729
        $ops.push_pirop('pop_upto_eh', $exc_reg);
 
730
        $ops.push_pirop('getattribute', $exc_reg, $exc_reg, "'type'");
 
731
        $ops.push_pirop('eq', $exc_reg, '.CONTROL_LOOP_NEXT', $lbl_next);
 
732
        $ops.push_pirop('eq', $exc_reg, '.CONTROL_LOOP_REDO', $lbl_redo);
 
733
        $ops.push($lbl_done);
 
734
        $ops.push_pirop('pop_eh');
 
735
    }
 
736
    else {
 
737
        $ops.push($lbl_done);
 
738
    }
 
739
 
 
740
    # Set result.
 
741
    $ops.result($res);
 
742
    $ops
 
743
});
 
744
 
 
745
QAST::Operations.add_core_op('defor', :inlinable(1), -> $qastcomp, $op {
 
746
    if +$op.list != 2 {
 
747
        nqp::die("Operation 'defor' needs 2 operands");
 
748
    }
 
749
    my $ops := PIRT::Ops.new();
 
750
    my $lbl := PIRT::Label.new(:name('defor'));
 
751
    my $dreg := $*REGALLOC.fresh_i();
 
752
    my $rreg := $*REGALLOC.fresh_p();
 
753
    my $test := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
754
    my $then := $qastcomp.coerce($qastcomp.as_post($op[1]), 'P');
 
755
    $ops.push($test);
 
756
    $ops.push_pirop('set', $rreg, $test);
 
757
    $ops.push_pirop('defined', $dreg, $rreg);
 
758
    $ops.push_pirop('if', $dreg, $lbl);
 
759
    $ops.push($then);
 
760
    $ops.push_pirop('set', $rreg, $then);
 
761
    $ops.push($lbl);
 
762
    $ops.result($rreg);
 
763
    $ops
 
764
});
 
765
 
 
766
QAST::Operations.add_core_op('xor', :inlinable(1), -> $qastcomp, $op {
 
767
    my $ops := PIRT::Ops.new();
 
768
    $ops.result($*REGALLOC.fresh_p());
 
769
 
 
770
    my $falselabel := PIRT::Label.new(:name('xor_false'));
 
771
    my $endlabel   := PIRT::Label.new(:name('xor_end'));
 
772
 
 
773
    my @childlist;
 
774
    my $fpast;
 
775
    for $op.list {
 
776
        if $_.named eq 'false' {
 
777
            $fpast := $_;
 
778
        }
 
779
        else {
 
780
            nqp::push(@childlist, $_);
 
781
        }
 
782
    }
 
783
 
 
784
    my $i := $*REGALLOC.fresh_i();
 
785
    my $t := $*REGALLOC.fresh_i();
 
786
    my $u := $*REGALLOC.fresh_i();
 
787
 
 
788
    my $apast := nqp::shift(@childlist);
 
789
    my $apost := $qastcomp.coerce($qastcomp.as_post($apast), 'P');
 
790
    $ops.push($apost);
 
791
    $ops.push_pirop('set', $ops, $apost);
 
792
    $ops.push_pirop('istrue', $t, $apost);
 
793
 
 
794
    my $have_middle_child := 1;
 
795
    my $bpost;
 
796
    while $have_middle_child {
 
797
        my $bpast := nqp::shift(@childlist);
 
798
        $bpost := $qastcomp.coerce($qastcomp.as_post($bpast), 'P');
 
799
        $ops.push($bpost);
 
800
        $ops.push_pirop('istrue', $u, $bpost);
 
801
        $ops.push_pirop('and', $i, $t, $u);
 
802
        $ops.push_pirop('if', $i, $falselabel);
 
803
        if @childlist {
 
804
            my $truelabel := PIRT::Label.new(:name('xor_true'));
 
805
            $ops.push_pirop('if', $t, $truelabel);
 
806
            $ops.push_pirop('set', $ops, $bpost);
 
807
            $ops.push_pirop('set', $t, $u);
 
808
            $ops.push($truelabel);
 
809
        }
 
810
        else {
 
811
            $have_middle_child := 0;
 
812
        }
 
813
    }
 
814
 
 
815
    $ops.push_pirop('if', $t, $endlabel);
 
816
    $ops.push_pirop('set', $ops, $bpost);
 
817
    $ops.push_pirop('goto', $endlabel);
 
818
    $ops.push($falselabel);
 
819
 
 
820
    if $fpast {
 
821
        my $fpost := $qastcomp.coerce($qastcomp.as_post($fpast), 'P');
 
822
        $ops.push($fpost);
 
823
        $ops.push_pirop('set', $ops, $fpost);
 
824
    }
 
825
    else {
 
826
        $ops.push_pirop('new', $ops, '["Undef"]');
 
827
    }
 
828
 
 
829
    $ops.push($endlabel);
 
830
 
 
831
    $ops
 
832
});
 
833
 
 
834
# Binding
 
835
QAST::Operations.add_core_op('bind', :inlinable(1), -> $qastcomp, $op {
 
836
    # Sanity checks.
 
837
    my @children := $op.list;
 
838
    if +@children != 2 {
 
839
        nqp::die("A 'bind' op must have exactly two children");
 
840
    }
 
841
    unless nqp::istype(@children[0], QAST::Var) {
 
842
        nqp::die("First child of a 'bind' op must be a QAST::Var");
 
843
    }
 
844
 
 
845
    # Set the QAST of the think we're to bind, then delegate to
 
846
    # the compilation of the QAST::Var to handle the rest.
 
847
    my $*BINDVAL := @children[1];
 
848
    $qastcomp.as_post(@children[0])
 
849
});
 
850
 
 
851
# Calling.
 
852
sub handle_arg($arg, $qastcomp, $ops, @pos_arg_results, @named_arg_results, :$coerce) {
 
853
    my $arg_post := $qastcomp.as_post($arg);
 
854
    if $coerce {
 
855
        $arg_post := $qastcomp.coerce($arg_post, $coerce);
 
856
    }
 
857
    $ops.push($arg_post);
 
858
    my $result := $arg_post.result;
 
859
    if $arg.flat {
 
860
        $result := "$result :flat";
 
861
        if $arg.named {
 
862
            $result := "$result :named";
 
863
        }
 
864
    }
 
865
    elsif $arg.named -> $name {
 
866
        $result := "$result :named(" ~ $qastcomp.escape($name) ~ ")";
 
867
    }
 
868
    if $arg.named {
 
869
        @named_arg_results.push($result);
 
870
    }
 
871
    else {
 
872
        @pos_arg_results.push($result);
 
873
    }
 
874
}
 
875
 
 
876
QAST::Operations.add_core_op('call', -> $qastcomp, $op {
 
877
    # Work out what callee is.
 
878
    my $callee;
 
879
    my @args := nqp::clone($op.list);
 
880
    if $op.name {
 
881
        $callee := PIRT::Ops.new(:result($qastcomp.escape($op.name)));
 
882
    }
 
883
    elsif +@args {
 
884
        $callee := $qastcomp.as_post(@args.shift());
 
885
    }
 
886
    else {
 
887
        nqp::die("No name for call and empty children list");
 
888
    }
 
889
 
 
890
    # Process arguments.
 
891
    my $ops := PIRT::Ops.new();
 
892
    $ops.node($op.node) if $op.node;
 
893
    my @pos_arg_results;
 
894
    my @named_arg_results;
 
895
    for @args {
 
896
        handle_arg($_, $qastcomp, $ops, @pos_arg_results, @named_arg_results);
 
897
    }
 
898
 
 
899
    # Generate call, with a result register if we're not in void context.
 
900
    $ops.push($callee);
 
901
    if $*WANT eq 'v' {
 
902
        $ops.push_pirop('call', $callee.result, |@pos_arg_results, |@named_arg_results);
 
903
    }
 
904
    else {
 
905
        my $res_type := $qastcomp.type_to_register_type($op.returns);
 
906
        my $res_reg := $*REGALLOC."fresh_{nqp::lc($res_type)}"();
 
907
        $ops.push_pirop('call', $callee.result, |@pos_arg_results, |@named_arg_results, :result($res_reg));
 
908
        $ops.result($res_reg);
 
909
    }
 
910
    $ops
 
911
});
 
912
QAST::Operations.add_core_op('callmethod', :inlinable(1), -> $qastcomp, $op {
 
913
    # Ensure we at least have an invocant.
 
914
    my @args := nqp::clone($op.list);
 
915
    if +@args == 0 {
 
916
        nqp::die('Method call node requires at least one child');
 
917
    }
 
918
 
 
919
    # Where is the name coming from?
 
920
    my $name;
 
921
    if $op.name {
 
922
        $name := PIRT::Ops.new(:result($qastcomp.escape($op.name)));
 
923
    }
 
924
    elsif +@args >= 2 {
 
925
        my $invocant := @args.shift();
 
926
        $name := $qastcomp.coerce($qastcomp.as_post(@args.shift()), 's');
 
927
        @args.unshift($invocant);
 
928
    }
 
929
    else {
 
930
        nqp::die("Method call must either supply a name or have a child node that evaluates to the name");
 
931
    }
 
932
 
 
933
    # Process arguments.
 
934
    my $ops := PIRT::Ops.new();
 
935
    $ops.node($op.node) if $op.node;
 
936
    my @pos_arg_results;
 
937
    my @named_arg_results;
 
938
    my $inv := 1;
 
939
    for @args {
 
940
        if $inv {
 
941
            handle_arg($_, $qastcomp, $ops, @pos_arg_results, @named_arg_results, :coerce('P'));
 
942
            $inv := 0;
 
943
        }
 
944
        else {
 
945
            handle_arg($_, $qastcomp, $ops, @pos_arg_results, @named_arg_results);
 
946
        }
 
947
    }
 
948
 
 
949
    # Generate call, with a result register if we're not in void context.
 
950
    $ops.push($name);
 
951
    if $*WANT eq 'v' {
 
952
        $ops.push_pirop('callmethod', $name.result, |@pos_arg_results, |@named_arg_results);
 
953
    }
 
954
    else {
 
955
        my $res_type := $qastcomp.type_to_register_type($op.returns);
 
956
        my $res_reg := $*REGALLOC."fresh_{nqp::lc($res_type)}"();
 
957
        $ops.push_pirop('callmethod', $name.result, |@pos_arg_results, |@named_arg_results, :result($res_reg));
 
958
        $ops.result($res_reg);
 
959
    }
 
960
 
 
961
    $ops
 
962
});
 
963
 
 
964
QAST::Operations.add_core_op('lexotic', -> $qastcomp, $op {
 
965
    my $label1  := PIRT::Label.new(:name('lexotic_'));
 
966
    my $label2  := PIRT::Label.new(:name('lexotic_'));
 
967
    my $lexname := $qastcomp.escape($op.name);
 
968
 
 
969
    my $ops := PIRT::Ops.new();
 
970
    my $handler := $*BLOCK.fresh_lex_p();
 
971
    $ops.push_pirop('root_new', $handler, "['parrot';'Continuation']");
 
972
    $ops.push_pirop('set_label', $handler, $label1);
 
973
    $ops.push_pirop('.lex', $lexname, $handler);
 
974
 
 
975
    my $cpost := $qastcomp.coerce($qastcomp.compile_all_the_stmts($op.list()), 'P');
 
976
    $ops.push($cpost);
 
977
    $ops.result($cpost);
 
978
 
 
979
    $ops.push_pirop('goto', $label2);
 
980
    $ops.push($label1);
 
981
    $ops.push_pirop('.get_results', '(' ~ $ops.result() ~ ')');
 
982
    $ops.push($label2);
 
983
 
 
984
    $ops
 
985
});
 
986
 
 
987
# Context introspection
 
988
QAST::Operations.add_core_op('ctx', -> $qastcomp, $op {
 
989
    my $reg := $*REGALLOC.fresh_p();
 
990
    my $ops := PIRT::Ops.new();
 
991
    $ops.push_pirop('getinterp', $reg);
 
992
    $ops.push_pirop('set', $reg, $reg ~ "['context']");
 
993
    $ops.result($reg);
 
994
    $ops
 
995
});
 
996
QAST::Operations.add_core_op('ctxouter', -> $qastcomp, $op {
 
997
    my $reg := $*REGALLOC.fresh_p();
 
998
    my $ops := PIRT::Ops.new();
 
999
    my $ctxpost := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
1000
    $ops.push($ctxpost);
 
1001
    $ops.push_pirop('getattribute', $reg, $ctxpost, "'outer_ctx'");
 
1002
    $ops.result($reg);
 
1003
    $ops
 
1004
});
 
1005
QAST::Operations.add_core_op('ctxcaller', -> $qastcomp, $op {
 
1006
    my $reg := $*REGALLOC.fresh_p();
 
1007
    my $ops := PIRT::Ops.new();
 
1008
    my $ctxpost := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
1009
    $ops.push($ctxpost);
 
1010
    $ops.push_pirop('getattribute', $reg, $ctxpost, "'caller_ctx'");
 
1011
    $ops.result($reg);
 
1012
    $ops
 
1013
});
 
1014
QAST::Operations.add_core_op('ctxlexpad', -> $qastcomp, $op {
 
1015
    my $reg := $*REGALLOC.fresh_p();
 
1016
    my $ops := PIRT::Ops.new();
 
1017
    my $ctxpost := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
1018
    $ops.push($ctxpost);
 
1019
    $ops.push_pirop('getattribute', $reg, $ctxpost, "'lex_pad'");
 
1020
    $ops.result($reg);
 
1021
    $ops
 
1022
});
 
1023
QAST::Operations.add_core_op('curlexpad', -> $qastcomp, $op {
 
1024
    my $reg := $*REGALLOC.fresh_p();
 
1025
    my $ops := PIRT::Ops.new();
 
1026
    $ops.push_pirop('getinterp', $reg);
 
1027
    $ops.push_pirop('set', $reg, $reg ~ "['lexpad']");
 
1028
    $ops.result($reg);
 
1029
    $ops
 
1030
});
 
1031
QAST::Operations.add_core_op('curcode', -> $qastcomp, $op {
 
1032
    my $reg := $*REGALLOC.fresh_p();
 
1033
    my $ops := PIRT::Ops.new();
 
1034
    $ops.push_pirop('getinterp', $reg);
 
1035
    $ops.push_pirop('set', $reg, $reg ~ "['sub']");
 
1036
    $ops.result($reg);
 
1037
    $ops
 
1038
});
 
1039
QAST::Operations.add_core_op('callercode', -> $qastcomp, $op {
 
1040
    my $reg := $*REGALLOC.fresh_p();
 
1041
    my $ops := PIRT::Ops.new();
 
1042
    $ops.push_pirop('getinterp', $reg);
 
1043
    $ops.push_pirop('set', $reg, $reg ~ "['sub';1]");
 
1044
    $ops.result($reg);
 
1045
    $ops
 
1046
});
 
1047
QAST::Operations.add_core_op('lexprimspec', -> $qastcomp, $op {
 
1048
    unless +@($op) == 2 {
 
1049
        nqp::die("Operation 'lexprimspec' expects two operands");
 
1050
    }
 
1051
    $qastcomp.as_post(QAST::Op.new(
 
1052
        :op('callmethod'), :name('get_lex_type'), :returns(int),
 
1053
        $op[0], $op[1]
 
1054
    ))
 
1055
});
 
1056
 
 
1057
# Argument capture processing, for writing things like multi-dispatchers in
 
1058
# high level languages.
 
1059
QAST::Operations.add_core_op('usecapture', -> $qastcomp, $op {
 
1060
    # On Parrot, the current CallContext has the current args, so just use it.
 
1061
    my $reg := $*REGALLOC.fresh_p();
 
1062
    my $ops := PIRT::Ops.new();
 
1063
    $ops.push_pirop('getinterp', $reg);
 
1064
    $ops.push_pirop('set', $reg, $reg ~ "['context']");
 
1065
    $ops.result($reg);
 
1066
    $ops
 
1067
});
 
1068
QAST::Operations.add_core_op('savecapture', -> $qastcomp, $op {
 
1069
    # On Parrot, CallContext contains the args and is immutable, so we
 
1070
    # don't need to do anything more than map this to returning the
 
1071
    # current context.
 
1072
    my $reg := $*REGALLOC.fresh_p();
 
1073
    my $ops := PIRT::Ops.new();
 
1074
    $ops.push_pirop('getinterp', $reg);
 
1075
    $ops.push_pirop('set', $reg, $reg ~ "['context']");
 
1076
    $ops.result($reg);
 
1077
    $ops
 
1078
});
 
1079
QAST::Operations.add_core_pirop_mapping('captureposelems', 'elements', 'IP');
 
1080
QAST::Operations.add_core_pirop_mapping('captureposarg', 'set', 'PQi');
 
1081
QAST::Operations.add_core_pirop_mapping('captureposarg_i', 'set', 'IQi');
 
1082
QAST::Operations.add_core_pirop_mapping('captureposarg_n', 'set', 'NQi');
 
1083
QAST::Operations.add_core_pirop_mapping('captureposarg_s', 'set', 'SQi');
 
1084
QAST::Operations.add_core_pirop_mapping('captureposprimspec', 'captureposprimspec', 'IPi');
 
1085
QAST::Operations.add_core_pirop_mapping('captureexistsnamed', 'exists', 'IQs');
 
1086
QAST::Operations.add_core_pirop_mapping('capturehasnameds', 'nqp_capturehasnameds', 'IP');
 
1087
 
 
1088
# Multiple dispatch related.
 
1089
QAST::Operations.add_core_op('invokewithcapture', -> $qastcomp, $op {
 
1090
    unless $op.list == 2 {
 
1091
        nqp::die("The 'invokewithcapture' op requires two children");
 
1092
    }
 
1093
    my $pos_reg  := $*REGALLOC.fresh_p();
 
1094
    my $nam_reg  := $*REGALLOC.fresh_p();
 
1095
    my $res_reg  := $*REGALLOC.fresh_p();
 
1096
    my $inv_post := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
1097
    my $cap_post := $qastcomp.coerce($qastcomp.as_post($op[1]), 'P');
 
1098
    my $ops      := PIRT::Ops.new();
 
1099
    $ops.push($inv_post);
 
1100
    $ops.push($cap_post);
 
1101
    $ops.push_pirop('deconstruct_capture', $cap_post.result, $pos_reg, $nam_reg);
 
1102
    $ops.push_pirop('call', $inv_post.result, $pos_reg ~ ' :flat',
 
1103
        $nam_reg ~ ' :flat :named', :result($res_reg));
 
1104
    $ops.result($res_reg);
 
1105
    $ops
 
1106
});
 
1107
QAST::Operations.add_core_pirop_mapping('multicacheadd', 'multi_cache_add', 'PPPP');
 
1108
QAST::Operations.add_core_pirop_mapping('multicachefind', 'multi_cache_find', 'PPP');
 
1109
 
 
1110
# Constant mapping.
 
1111
my %const_map := nqp::hash(
 
1112
    'CCLASS_ANY',           pir::const::CCLASS_ANY,
 
1113
    'CCLASS_NUMERIC',       pir::const::CCLASS_NUMERIC,
 
1114
    'CCLASS_WHITESPACE',    pir::const::CCLASS_WHITESPACE,
 
1115
    'CCLASS_PRINTING',      pir::const::CCLASS_PRINTING,
 
1116
    'CCLASS_GRAPHICAL',     pir::const::CCLASS_GRAPHICAL,
 
1117
    'CCLASS_WORD',          pir::const::CCLASS_WORD,
 
1118
    'CCLASS_NEWLINE',       pir::const::CCLASS_NEWLINE,
 
1119
    'CCLASS_ALPHABETIC',    pir::const::CCLASS_ALPHABETIC,
 
1120
    'CCLASS_UPPERCASE',     pir::const::CCLASS_UPPERCASE,
 
1121
    'CCLASS_LOWERCASE',     pir::const::CCLASS_LOWERCASE,
 
1122
    'CCLASS_NUMERIC',       pir::const::CCLASS_NUMERIC,
 
1123
    'CCLASS_HEXADECIMAL',   pir::const::CCLASS_HEXADECIMAL,
 
1124
    'CCLASS_BLANK',         pir::const::CCLASS_BLANK,
 
1125
    'CCLASS_CONTROL',       pir::const::CCLASS_CONTROL,
 
1126
    'CCLASS_PUNCTUATION',   pir::const::CCLASS_PUNCTUATION,
 
1127
    'CCLASS_ALPHANUMERIC',  pir::const::CCLASS_ALPHANUMERIC,
 
1128
    
 
1129
    'HLL_ROLE_NONE',        0,
 
1130
    'HLL_ROLE_INT',         1,
 
1131
    'HLL_ROLE_NUM',         2,
 
1132
    'HLL_ROLE_STR',         3,
 
1133
    'HLL_ROLE_ARRAY',       4,
 
1134
    'HLL_ROLE_HASH',        5,
 
1135
    'HLL_ROLE_CODE',        6,
 
1136
    
 
1137
    'CONTROL_TAKE',         pir::const::CONTROL_TAKE,
 
1138
    'CONTROL_LAST',         pir::const::CONTROL_LOOP_LAST,
 
1139
    'CONTROL_NEXT',         pir::const::CONTROL_LOOP_NEXT,
 
1140
    'CONTROL_REDO',         pir::const::CONTROL_LOOP_REDO,
 
1141
    'CONTROL_SUCCEED',      pir::const::CONTROL_BREAK,
 
1142
    'CONTROL_PROCEED',      pir::const::CONTROL_CONTINUE,
 
1143
    'CONTROL_WARN',         pir::const::CONTROL_OK,
 
1144
 
 
1145
    'STAT_EXISTS',             pir::const::STAT_EXISTS,
 
1146
    'STAT_FILESIZE',           pir::const::STAT_FILESIZE,
 
1147
    'STAT_ISDIR',              pir::const::STAT_ISDIR,
 
1148
    'STAT_ISREG',              pir::const::STAT_ISREG,
 
1149
    'STAT_ISDEV',              pir::const::STAT_ISDEV,
 
1150
    'STAT_CREATETIME',         pir::const::STAT_CREATETIME,
 
1151
    'STAT_ACCESSTIME',         pir::const::STAT_ACCESSTIME,
 
1152
    'STAT_MODIFYTIME',         pir::const::STAT_MODIFYTIME,
 
1153
    'STAT_CHANGETIME',         pir::const::STAT_CHANGETIME,
 
1154
    'STAT_BACKUPTIME',         pir::const::STAT_BACKUPTIME,
 
1155
    'STAT_UID',                pir::const::STAT_UID,
 
1156
    'STAT_GID',                pir::const::STAT_GID,
 
1157
    'STAT_ISLNK',              pir::const::STAT_ISLNK,
 
1158
    'STAT_PLATFORM_DEV',       pir::const::STAT_PLATFORM_DEV,
 
1159
    'STAT_PLATFORM_INODE',     pir::const::STAT_PLATFORM_INODE,
 
1160
    'STAT_PLATFORM_MODE',      pir::const::STAT_PLATFORM_MODE,
 
1161
    'STAT_PLATFORM_NLINKS',    pir::const::STAT_PLATFORM_NLINKS,
 
1162
    'STAT_PLATFORM_DEVTYPE',   pir::const::STAT_PLATFORM_DEVTYPE,
 
1163
    'STAT_PLATFORM_BLOCKSIZE', pir::const::STAT_PLATFORM_BLOCKSIZE,
 
1164
    'STAT_PLATFORM_BLOCKS',    pir::const::STAT_PLATFORM_BLOCKS,
 
1165
 
 
1166
    'STAT_TYPE_UNKNOWN',       pir::const::STAT_TYPE_UNKNOWN,
 
1167
    'STAT_TYPE_FILE',          pir::const::STAT_TYPE_FILE,
 
1168
    'STAT_TYPE_DIRECTORY',     pir::const::STAT_TYPE_DIRECTORY,
 
1169
    'STAT_TYPE_PIPE',          pir::const::STAT_TYPE_PIPE,
 
1170
    'STAT_TYPE_LINK',          pir::const::STAT_TYPE_LINK,
 
1171
    'STAT_TYPE_DEVICE',        pir::const::STAT_TYPE_DEVICE
 
1172
);
 
1173
QAST::Operations.add_core_op('const', -> $qastcomp, $op {
 
1174
    if nqp::existskey(%const_map, $op.name) {
 
1175
        $qastcomp.as_post(QAST::IVal.new( :value(%const_map{$op.name}) ))
 
1176
    }
 
1177
    else {
 
1178
        nqp::die("Unknown constant '" ~ $op.name ~ "'");
 
1179
    }
 
1180
});
 
1181
 
 
1182
# Exception handling/munging.
 
1183
my $exc_exclude := 0;
 
1184
my $exc_include := 1;
 
1185
my %handler_names := nqp::hash(
 
1186
    'CATCH',   '.CONTROL_ALL',
 
1187
    'CONTROL', '.CONTROL_ALL',
 
1188
    'NEXT',    '.CONTROL_LOOP_NEXT',
 
1189
    'LAST',    '.CONTROL_LOOP_LAST',
 
1190
    'REDO',    '.CONTROL_LOOP_REDO',
 
1191
    'TAKE',    '.CONTROL_TAKE',
 
1192
    'SUCCEED', '.CONTROL_BREAK',
 
1193
    'PROCEED', '.CONTROL_CONTINUE'
 
1194
);
 
1195
QAST::Operations.add_core_op('handle', -> $qastcomp, $op {
 
1196
    my @children := nqp::clone($op.list());
 
1197
    if @children == 0 {
 
1198
        nqp::die("The 'handle' op requires at least one child");
 
1199
    }
 
1200
 
 
1201
    # Compile the protected statements. If we've no handlers at all
 
1202
    # then that's it.
 
1203
    my $protected := @children.shift();
 
1204
    my $procpost  := $qastcomp.coerce($qastcomp.as_post($protected), 'P');
 
1205
    unless @children {
 
1206
        return $procpost;
 
1207
    }
 
1208
 
 
1209
    # Process handlers.
 
1210
    my %handlers;
 
1211
    my $catch;
 
1212
    my $control;
 
1213
    my @other;
 
1214
    for @children -> $name, $handler_code {
 
1215
        if nqp::existskey(%handler_names, $name) {
 
1216
            if nqp::existskey(%handlers, $name) {
 
1217
                nqp::die("Multiple handlers for $name");
 
1218
            }
 
1219
            %handlers{$name} := $handler_code;
 
1220
            if $name eq 'CATCH' {
 
1221
                $catch := 1;
 
1222
            }
 
1223
            elsif $name eq 'CONTROL' {
 
1224
                $control := 1;
 
1225
            }
 
1226
            else {
 
1227
                nqp::push(@other, $name);
 
1228
            }
 
1229
        }
 
1230
        else {
 
1231
            nqp::die("Invalid handler type '$name'");
 
1232
        }
 
1233
    }
 
1234
 
 
1235
    # Handler prelude.
 
1236
    my $catch_label;
 
1237
    my $control_label;
 
1238
    my $other_label;
 
1239
    my $num_pops := 0;
 
1240
    my $skip_handler_label := PIRT::Label.new(:name($qastcomp.unique('skip_handler_')));
 
1241
    my $ops := PIRT::Ops.new();
 
1242
    my $reg := $*REGALLOC.fresh_p();
 
1243
    if $catch {
 
1244
        $catch_label := PIRT::Label.new(:name($qastcomp.unique('catch_handler_')));
 
1245
        $ops.push_pirop('new', $reg, "'ExceptionHandler'");
 
1246
        $ops.push_pirop('set_label', $reg, $catch_label);
 
1247
        $ops.push_pirop('callmethod', "'handle_types_except'", $reg, ".CONTROL_ALL");
 
1248
        $ops.push_pirop('push_eh', $reg);
 
1249
        $num_pops := $num_pops + 1;
 
1250
    }
 
1251
    if $control {
 
1252
        $control_label := PIRT::Label.new(:name($qastcomp.unique('catch_handler_')));
 
1253
        $ops.push_pirop('new', $reg, "'ExceptionHandler'", "[.CONTROL_ALL]");
 
1254
        $ops.push_pirop('set_label', $reg, $control_label);
 
1255
        $ops.push_pirop('push_eh', $reg);
 
1256
        $num_pops := $num_pops + 1;
 
1257
    }
 
1258
    if @other {
 
1259
        my @hnames;
 
1260
        for @other { nqp::push(@hnames, %handler_names{$_}); }
 
1261
        $other_label := PIRT::Label.new(:name($qastcomp.unique('catch_handler_')));
 
1262
        $ops.push_pirop('new', $reg, "'ExceptionHandler'",
 
1263
            "[" ~ nqp::join(", ", @hnames) ~ "]");
 
1264
        $ops.push_pirop('set_label', $reg, $other_label);
 
1265
        $ops.push_pirop('push_eh', $reg);
 
1266
        $num_pops := $num_pops + 1;
 
1267
    }
 
1268
 
 
1269
    # Protected code.
 
1270
    my $res_type := nqp::lc($qastcomp.infer_type($procpost.result));
 
1271
    my $res_reg := $*REGALLOC."fresh_$res_type"();
 
1272
    $ops.push($procpost);
 
1273
    $ops.push_pirop('set', $res_reg, $procpost.result);
 
1274
    while $num_pops {
 
1275
        $ops.push_pirop('pop_eh');
 
1276
        $num_pops := $num_pops - 1;
 
1277
    }
 
1278
    $ops.push_pirop('goto', $skip_handler_label);
 
1279
 
 
1280
    # Now emit the handlers.
 
1281
    my $orig_alloc := $*REGALLOC;
 
1282
    {
 
1283
        my $*CUR_EXCEPTION := $reg;
 
1284
        my $*REGALLOC := $orig_alloc.handler_allocator();
 
1285
        sub simple_handler($label, $handler_qast) {
 
1286
            my $handler_post := $qastcomp.coerce($qastcomp.as_post($handler_qast), 'P');
 
1287
            $ops.push($label);
 
1288
            $ops.push_pirop(".get_results ($reg)");
 
1289
            $ops.push($handler_post);
 
1290
            $ops.push_pirop('finalize', $reg);
 
1291
            $ops.push_pirop('pop_upto_eh', $reg);
 
1292
            $ops.push_pirop('pop_eh');
 
1293
            $ops.push_pirop('set', $res_reg, $handler_post.result);
 
1294
            $ops.push_pirop('goto', $skip_handler_label);
 
1295
        }
 
1296
        if $catch {
 
1297
            simple_handler($catch_label, %handlers<CATCH>);
 
1298
        }
 
1299
        if $control {
 
1300
            simple_handler($control_label, %handlers<CONTROL>);
 
1301
        }
 
1302
        if @other {
 
1303
            my $type_reg := $*REGALLOC.fresh_i();
 
1304
            $ops.push($other_label);
 
1305
            $ops.push_pirop(".get_results ($reg)");
 
1306
 
 
1307
            # Create labels for each type and emit type selection ladder.
 
1308
            my %type_labels;
 
1309
            $ops.push_pirop('set', $type_reg, $reg ~ '["type"]');
 
1310
            for @other {
 
1311
                my $lbl := PIRT::Label.new(:name($qastcomp.unique('handle_type_')));
 
1312
                $ops.push_pirop('eq', $type_reg, %handler_names{$_}, $lbl);
 
1313
                %type_labels{$_} := $lbl;
 
1314
            }
 
1315
 
 
1316
            # Emit handler for each type.
 
1317
            for @other {
 
1318
                my $handler_post := $qastcomp.coerce($qastcomp.as_post(%handlers{$_}), 'P');
 
1319
                $ops.push(%type_labels{$_});
 
1320
                $ops.push($handler_post);
 
1321
                $ops.push_pirop('finalize', $reg);
 
1322
                $ops.push_pirop('pop_upto_eh', $reg);
 
1323
                $ops.push_pirop('pop_eh');
 
1324
                $ops.push_pirop('set', $res_reg, $handler_post.result);
 
1325
                $ops.push_pirop('goto', $skip_handler_label);
 
1326
            }
 
1327
        }
 
1328
    }
 
1329
 
 
1330
    # Postlude.
 
1331
    $ops.push($skip_handler_label);
 
1332
    $ops.result($res_reg);
 
1333
 
 
1334
    $ops
 
1335
});
 
1336
QAST::Operations.add_core_op('exception', -> $qastcomp, $op {
 
1337
    my $exc_reg := try $*CUR_EXCEPTION;
 
1338
    unless $exc_reg {
 
1339
        nqp::die("Can only use 'exception' op in the context of an exception handler");
 
1340
    }
 
1341
    my $ops := PIRT::Ops.new();
 
1342
    $ops.result($exc_reg);
 
1343
    $ops
 
1344
});
 
1345
QAST::Operations.add_core_op('getpayload', -> $qastcomp, $op {
 
1346
    if +$op.list != 1 {
 
1347
        nqp::die("The 'getpayload' op expects one child");
 
1348
    }
 
1349
    my $exc := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
1350
    my $reg := $*REGALLOC.fresh_p();
 
1351
    my $ops := PIRT::Ops.new();
 
1352
    $ops.push($exc);
 
1353
    $ops.push_pirop('getattribute', $reg, $exc.result, '"payload"');
 
1354
    $ops.result($reg);
 
1355
    $ops
 
1356
});
 
1357
QAST::Operations.add_core_op('setpayload', -> $qastcomp, $op {
 
1358
    if +$op.list != 2 {
 
1359
        nqp::die("The 'setpayload' op expects two children");
 
1360
    }
 
1361
    my $exc := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
1362
    my $payload := $qastcomp.coerce($qastcomp.as_post($op[1]), 'P');
 
1363
    my $ops := PIRT::Ops.new();
 
1364
    $ops.push($exc);
 
1365
    $ops.push($payload);
 
1366
    $ops.push_pirop('setattribute', $exc, '"payload"', $payload);
 
1367
    $ops.result($payload.result);
 
1368
    $ops
 
1369
});
 
1370
QAST::Operations.add_core_op('getmessage', -> $qastcomp, $op {
 
1371
    if +$op.list != 1 {
 
1372
        nqp::die("The 'getmessage' op expects one child");
 
1373
    }
 
1374
    my $exc := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
1375
    my $pmc := $*REGALLOC.fresh_p();
 
1376
    my $reg := $*REGALLOC.fresh_s();
 
1377
    my $ops := PIRT::Ops.new();
 
1378
    $ops.push($exc);
 
1379
    $ops.push_pirop('getattribute', $pmc, $exc.result, '"message"');
 
1380
    $ops.push_pirop('set', $reg, $pmc);
 
1381
    $ops.result($reg);
 
1382
    $ops
 
1383
});
 
1384
QAST::Operations.add_core_op('setmessage', -> $qastcomp, $op {
 
1385
    if +$op.list != 2 {
 
1386
        nqp::die("The 'setmessage' op expects two children");
 
1387
    }
 
1388
    my $exc := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
1389
    my $message := $qastcomp.coerce($qastcomp.as_post($op[1]), 'S');
 
1390
    my $pmc := $*REGALLOC.fresh_p();
 
1391
    my $ops := PIRT::Ops.new();
 
1392
    $ops.push($exc);
 
1393
    $ops.push($message);
 
1394
    $ops.push_pirop('box', $pmc, $message);
 
1395
    $ops.push_pirop('setattribute', $exc, '"message"', $pmc);
 
1396
    $ops.result($message.result);
 
1397
    $ops
 
1398
});
 
1399
QAST::Operations.add_core_op('getextype', -> $qastcomp, $op {
 
1400
    if +$op.list != 1 {
 
1401
        nqp::die("The 'getextype' op expects one child");
 
1402
    }
 
1403
    my $exc := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
1404
    my $pmc := $*REGALLOC.fresh_p();
 
1405
    my $reg := $*REGALLOC.fresh_i();
 
1406
    my $ops := PIRT::Ops.new();
 
1407
    $ops.push($exc);
 
1408
    $ops.push_pirop('getattribute', $pmc, $exc.result, '"type"');
 
1409
    $ops.push_pirop('set', $reg, $pmc);
 
1410
    $ops.result($reg);
 
1411
    $ops
 
1412
});
 
1413
QAST::Operations.add_core_op('setextype', -> $qastcomp, $op {
 
1414
    if +$op.list != 2 {
 
1415
        nqp::die("The 'setextype' op expects two children");
 
1416
    }
 
1417
    my $exc := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
1418
    my $type := $qastcomp.coerce($qastcomp.as_post($op[1]), 'I');
 
1419
    my $pmc := $*REGALLOC.fresh_p();
 
1420
    my $ops := PIRT::Ops.new();
 
1421
    $ops.push($exc);
 
1422
    $ops.push($type);
 
1423
    $ops.push_pirop('box', $pmc, $type);
 
1424
    $ops.push_pirop('setattribute', $exc, '"type"', $pmc);
 
1425
    $ops.result($type.result);
 
1426
    $ops
 
1427
});
 
1428
QAST::Operations.add_core_op('backtracestrings', -> $qastcomp, $op {
 
1429
    if +$op.list != 1 {
 
1430
        nqp::die("The 'backtracestrings' op expects one child");
 
1431
    }
 
1432
    $qastcomp.as_post(QAST::Op.new(
 
1433
        :op('callmethod'), :name('backtrace_strings'),
 
1434
        $op[0]
 
1435
    ))
 
1436
});
 
1437
QAST::Operations.add_core_op('backtrace', -> $qastcomp, $op {
 
1438
    if +$op.list != 1 {
 
1439
        nqp::die("The 'backtrace' op expects one child");
 
1440
    }
 
1441
    $qastcomp.as_post(QAST::Op.new(
 
1442
        :op('callmethod'), :name('backtrace'),
 
1443
        $op[0]
 
1444
    ))
 
1445
});
 
1446
QAST::Operations.add_core_op('newexception', -> $qastcomp, $op {
 
1447
    if +$op.list != 0 {
 
1448
        nqp::die("The 'newexception' op expects no children");
 
1449
    }
 
1450
    my $reg := $*REGALLOC.fresh_p();
 
1451
    my $ops := PIRT::Ops.new();
 
1452
    $ops.push_pirop('new', $reg, '["Exception"]');
 
1453
    $ops.result($reg);
 
1454
    $ops
 
1455
});
 
1456
QAST::Operations.add_core_pirop_mapping('die_s', 'die', '0s');
 
1457
QAST::Operations.add_core_pirop_mapping('die', 'die', '0P');
 
1458
QAST::Operations.add_core_pirop_mapping('throw', 'throw', '0P');
 
1459
QAST::Operations.add_core_pirop_mapping('rethrow', 'rethrow', '0P');
 
1460
QAST::Operations.add_core_op('resume', -> $qastcomp, $op {
 
1461
    if +$op.list != 1 {
 
1462
        nqp::die("The 'resume' op expects 1 child");
 
1463
    }
 
1464
    $qastcomp.as_post(QAST::Op.new(
 
1465
        :op('call'),
 
1466
        QAST::Op.new(
 
1467
            :op('atkey'),
 
1468
            $op[0],
 
1469
            QAST::SVal.new( :value('resume') )
 
1470
        )))
 
1471
});
 
1472
 
 
1473
# Control exception throwing.
 
1474
my %control_map := nqp::hash(
 
1475
    'next', '.CONTROL_LOOP_NEXT',
 
1476
    'last', '.CONTROL_LOOP_LAST',
 
1477
    'redo', '.CONTROL_LOOP_REDO'
 
1478
);
 
1479
QAST::Operations.add_core_op('control', -> $qastcomp, $op {
 
1480
    my $name := $op.name;
 
1481
    if nqp::existskey(%control_map, $name) {
 
1482
        my $ops := PIRT::Ops.new(:result('0'));
 
1483
        $ops.push_pirop('die', '0', %control_map{$name});
 
1484
        $ops
 
1485
    }
 
1486
    else {
 
1487
        nqp::die("Unknown control exception type '$name'");
 
1488
    }
 
1489
});
 
1490
 
 
1491
# NQP box/unbox.
 
1492
for <i n s> {
 
1493
    QAST::Operations.add_hll_box('nqp', $_, -> $qastcomp, $post {
 
1494
        my $reg := $*REGALLOC.fresh_p();
 
1495
        my $ops := PIRT::Ops.new();
 
1496
        $ops.push($post);
 
1497
        $ops.push_pirop('box', $reg, $post);
 
1498
        $ops.result($reg);
 
1499
        $ops
 
1500
    });
 
1501
    QAST::Operations.add_hll_unbox('nqp', $_, -> $qastcomp, $post {
 
1502
        my $reg := $*REGALLOC."fresh_$_"();
 
1503
        my $ops := PIRT::Ops.new();
 
1504
        $ops.push($post);
 
1505
        $ops.push_pirop('set', $reg, $post);
 
1506
        $ops.result($reg);
 
1507
        $ops
 
1508
    });
 
1509
}
 
1510
 
 
1511
# Default way to do positional and associative lookups.
 
1512
QAST::Operations.add_core_pirop_mapping('positional_get', 'set', 'PQi', :inlinable(1));
 
1513
QAST::Operations.add_core_pirop_mapping('positional_bind', 'set', '1QiP', :inlinable(1));
 
1514
QAST::Operations.add_core_pirop_mapping('associative_get', 'set', 'PQs', :inlinable(1));
 
1515
QAST::Operations.add_core_pirop_mapping('associative_bind', 'set', '1QsP', :inlinable(1));
 
1516
 
 
1517
# I/O opcodes
 
1518
QAST::Operations.add_core_pirop_mapping('print', 'print', '0s', :inlinable(1));
 
1519
QAST::Operations.add_core_pirop_mapping('say', 'say', '0s', :inlinable(1));
 
1520
QAST::Operations.add_core_pirop_mapping('stat', 'stat', 'Isi', :inlinable(1));
 
1521
QAST::Operations.add_core_pirop_mapping('open', 'open', 'Pss', :inlinable(1));
 
1522
 
 
1523
QAST::Operations.add_core_op('filereadable', -> $qastcomp, $op {
 
1524
    if +$op.list != 1 {
 
1525
        nqp::die("The 'filereadable' op expects one child");
 
1526
    }
 
1527
    $qastcomp.as_post(QAST::Op.new(
 
1528
        :op('callmethod'),
 
1529
        :name('can_read'),
 
1530
        QAST::VM.new( :pirop('new__Ps'),
 
1531
                      QAST::SVal.new( :value('OS') ) ),
 
1532
        $op[0],) );
 
1533
});
 
1534
QAST::Operations.add_core_op('filewritable', -> $qastcomp, $op {
 
1535
    if +$op.list != 1 {
 
1536
        nqp::die("The 'filewritable' op expects one child");
 
1537
    }
 
1538
    $qastcomp.as_post(QAST::Op.new(
 
1539
        :op('callmethod'),
 
1540
        :name('can_write'),
 
1541
        QAST::VM.new( :pirop('new__Ps'),
 
1542
                      QAST::SVal.new( :value('OS') ) ),
 
1543
        $op[0],) );
 
1544
});
 
1545
QAST::Operations.add_core_op('fileexecutable', -> $qastcomp, $op {
 
1546
    if +$op.list != 1 {
 
1547
        nqp::die("The 'fileexecutable' op expects one child");
 
1548
    }
 
1549
    $qastcomp.as_post(QAST::Op.new(
 
1550
        :op('callmethod'),
 
1551
        :name('can_execute'),
 
1552
        QAST::VM.new( :pirop('new__Ps'),
 
1553
                      QAST::SVal.new( :value('OS') ) ),
 
1554
        $op[0],) );
 
1555
});
 
1556
QAST::Operations.add_core_op('fileislink', -> $qastcomp, $op {
 
1557
    if +$op.list != 1 {
 
1558
        nqp::die("The 'fileislink' op expects one child");
 
1559
    }
 
1560
    $qastcomp.as_post(QAST::Op.new(
 
1561
        :op('callmethod'),
 
1562
        :name('is_link'),
 
1563
        QAST::VM.new( :pirop('new__Ps'),
 
1564
                      QAST::SVal.new( :value('File') ) ),
 
1565
        $op[0],) );
 
1566
});
 
1567
 
 
1568
QAST::Operations.add_core_op('getstdin', -> $qastcomp, $op {
 
1569
    if +$op.list != 0 {
 
1570
        nqp::die("The 'getstdin' op expects no operands");
 
1571
    }
 
1572
    $qastcomp.as_post(QAST::Op.new(
 
1573
        :op('callmethod'), :name('stdin_handle'),
 
1574
        QAST::VM.new( :pirop('getinterp__P') )
 
1575
    ))
 
1576
});
 
1577
QAST::Operations.add_core_op('getstdout', -> $qastcomp, $op {
 
1578
    if +$op.list != 0 {
 
1579
        nqp::die("The 'getstdout' op expects no operands");
 
1580
    }
 
1581
    $qastcomp.as_post(QAST::Op.new(
 
1582
        :op('callmethod'), :name('stdout_handle'),
 
1583
        QAST::VM.new( :pirop('getinterp__P') )
 
1584
    ))
 
1585
});
 
1586
QAST::Operations.add_core_op('getstderr', -> $qastcomp, $op {
 
1587
    if +$op.list != 0 {
 
1588
        nqp::die("The 'getstderr' op expects no operands");
 
1589
    }
 
1590
    $qastcomp.as_post(QAST::Op.new(
 
1591
        :op('callmethod'), :name('stderr_handle'),
 
1592
        QAST::VM.new( :pirop('getinterp__P') )
 
1593
    ))
 
1594
});
 
1595
QAST::Operations.add_core_op('setencoding', -> $qastcomp, $op {
 
1596
    if +$op.list != 2 {
 
1597
        nqp::die("The 'setencoding' op expects two operands");
 
1598
    }
 
1599
    $qastcomp.as_post(QAST::Op.new(
 
1600
        :op('callmethod'), :name('encoding'),
 
1601
        $op[0], $op[1]
 
1602
    ))
 
1603
});
 
1604
QAST::Operations.add_core_op('tellfh', -> $qastcomp, $op {
 
1605
    if +$op.list != 1 {
 
1606
        nqp::die("The 'tellfh' op expects one operand");
 
1607
    }
 
1608
    $qastcomp.as_post(QAST::Op.new(
 
1609
        :op('callmethod'), :name('tell'),
 
1610
        $op[0]
 
1611
    ))
 
1612
});
 
1613
QAST::Operations.add_core_op('printfh', -> $qastcomp, $op {
 
1614
    if +$op.list != 2 {
 
1615
        nqp::die("The 'printfh' op expects two operands");
 
1616
    }
 
1617
    $qastcomp.as_post(QAST::Op.new(
 
1618
        :op('callmethod'), :name('print'),
 
1619
        $op[0], $op[1]
 
1620
    ))
 
1621
});
 
1622
QAST::Operations.add_core_op('sayfh', -> $qastcomp, $op {
 
1623
    if +$op.list != 2 {
 
1624
        nqp::die("The 'sayfh' op expects two operands");
 
1625
    }
 
1626
    $qastcomp.as_post(QAST::Op.new(
 
1627
        :op('callmethod'), :name('say'),
 
1628
        $op[0], $op[1]
 
1629
    ))
 
1630
});
 
1631
QAST::Operations.add_core_op('flushfh', -> $qastcomp, $op {
 
1632
    if +$op.list != 1 {
 
1633
        nqp::die("The 'flushfh' op expects two operands");
 
1634
    }
 
1635
    $qastcomp.as_post(QAST::Op.new(
 
1636
        :op('callmethod'), :name('flush'),
 
1637
        $op[0]
 
1638
    ))
 
1639
});
 
1640
QAST::Operations.add_core_op('readlinefh', -> $qastcomp, $op {
 
1641
    if +$op.list != 1 {
 
1642
        nqp::die("The 'readlinefh' op expects one operand");
 
1643
    }
 
1644
    $qastcomp.as_post(QAST::Op.new(
 
1645
        :op('callmethod'), :name('readline'),
 
1646
        $op[0]
 
1647
    ))
 
1648
});
 
1649
QAST::Operations.add_core_op('readlineintfh', -> $qastcomp, $op {
 
1650
    if +$op.list != 2 {
 
1651
        nqp::die("The 'readlineintfh' op expects two operands");
 
1652
    }
 
1653
    $qastcomp.as_post(QAST::Op.new(
 
1654
        :op('callmethod'), :name('readline_interactive'),
 
1655
        $op[0], $op[1]
 
1656
    ))
 
1657
});
 
1658
QAST::Operations.add_core_op('readallfh', -> $qastcomp, $op {
 
1659
    if +$op.list != 1 {
 
1660
        nqp::die("The 'readallfh' op expects one operand");
 
1661
    }
 
1662
    $qastcomp.as_post(QAST::Op.new(
 
1663
        :op('callmethod'), :name('readall'),
 
1664
        $op[0]
 
1665
    ))
 
1666
});
 
1667
QAST::Operations.add_core_op('getcfh', -> $qastcomp, $op {
 
1668
    if +$op.list != 1 {
 
1669
        nqp::die("The 'getcfh' op expects one operand");
 
1670
    }
 
1671
    $qastcomp.as_post(QAST::Op.new(
 
1672
        :op('callmethod'), :name('read'),
 
1673
        $op[0], QAST::IVal.new( :value(1) )
 
1674
    ))
 
1675
});
 
1676
QAST::Operations.add_core_op('eoffh', -> $qastcomp, $op {
 
1677
    if +$op.list != 1 {
 
1678
        nqp::die("The 'eoffh' op expects one operand");
 
1679
    }
 
1680
    $qastcomp.as_post(QAST::Op.new( :op('isfalse'), $op[0] ))
 
1681
});
 
1682
QAST::Operations.add_core_op('closefh', -> $qastcomp, $op {
 
1683
    if +$op.list != 1 {
 
1684
        nqp::die("The 'closefh' op expects one operand");
 
1685
    }
 
1686
    $qastcomp.as_post(QAST::Op.new(
 
1687
        :op('callmethod'), :name('close'),
 
1688
        $op[0]
 
1689
    ))
 
1690
});
 
1691
 
 
1692
QAST::Operations.add_core_op('chmod', -> $qastcomp, $op {
 
1693
    if +$op.list != 2 {
 
1694
        nqp::die("The 'chmod' op expects two operands");
 
1695
    }
 
1696
    $qastcomp.as_post(QAST::Op.new(
 
1697
        :op('callmethod'),
 
1698
        :name('chmod'),
 
1699
        QAST::VM.new( :pirop('new__Ps'),
 
1700
                      QAST::SVal.new( :value('OS') ) ),
 
1701
        $op[0],
 
1702
        $op[1]) );
 
1703
});
 
1704
QAST::Operations.add_core_pirop_mapping('unlink', 'nqp_delete_f', 'Is');
 
1705
QAST::Operations.add_core_op('rmdir', -> $qastcomp, $op {
 
1706
    if +$op.list != 1 {
 
1707
        nqp::die("The 'rmdir' op expects one operand");
 
1708
    }
 
1709
    $qastcomp.as_post(QAST::Op.new(
 
1710
        :op('callmethod'),
 
1711
        :name('rmdir'),
 
1712
        QAST::VM.new( :pirop('new__Ps'),
 
1713
                      QAST::SVal.new( :value('OS') ) ),
 
1714
        $op[0] ) );
 
1715
});
 
1716
QAST::Operations.add_core_op('cwd', -> $qastcomp, $op {
 
1717
    if +$op.list != 0 {
 
1718
        nqp::die("The 'cwd' op expects no operands");
 
1719
    }
 
1720
    $qastcomp.as_post(QAST::Op.new(
 
1721
        :op('callmethod'),
 
1722
        :name('cwd'),
 
1723
        QAST::VM.new( :pirop('new__Ps'),
 
1724
                      QAST::SVal.new( :value('OS') ) ) ) );
 
1725
});
 
1726
QAST::Operations.add_core_op('chdir', -> $qastcomp, $op {
 
1727
    if +$op.list != 1 {
 
1728
        nqp::die("The 'chdir' op expects one operand");
 
1729
    }
 
1730
    $qastcomp.as_post(QAST::Op.new(
 
1731
        :op('callmethod'),
 
1732
        :name('chdir'),
 
1733
        QAST::VM.new( :pirop('new__Ps'),
 
1734
                      QAST::SVal.new( :value('OS') ) ),
 
1735
        $op[0] ) );
 
1736
});
 
1737
QAST::Operations.add_core_op('mkdir', -> $qastcomp, $op {
 
1738
    if +$op.list != 2 {
 
1739
        nqp::die("The 'mkdir' op expects two operands");
 
1740
    }
 
1741
    $qastcomp.as_post(QAST::Op.new(
 
1742
        :op('callmethod'),
 
1743
        :name('mkdir'),
 
1744
        QAST::VM.new( :pirop('new__Ps'),
 
1745
                      QAST::SVal.new( :value('OS') ) ),
 
1746
        $op[0],
 
1747
        $op[1]) );
 
1748
});
 
1749
QAST::Operations.add_core_op('rename', -> $qastcomp, $op {
 
1750
    if +$op.list != 2 {
 
1751
        nqp::die("The 'rename' op expects two operands");
 
1752
    }
 
1753
    $qastcomp.as_post(QAST::Op.new(
 
1754
        :op('callmethod'),
 
1755
        :name('rename'),
 
1756
        QAST::VM.new( :pirop('new__Ps'),
 
1757
                      QAST::SVal.new( :value('OS') ) ),
 
1758
        $op[0],
 
1759
        $op[1]) );
 
1760
});
 
1761
QAST::Operations.add_core_op('copy', -> $qastcomp, $op {
 
1762
    if +$op.list != 2 {
 
1763
        nqp::die("The 'copy' op expects two operands");
 
1764
    }
 
1765
    $qastcomp.as_post(QAST::Op.new(
 
1766
        :op('callmethod'),
 
1767
        :name('copy'),
 
1768
        QAST::VM.new( :pirop('new__Ps'),
 
1769
                      QAST::SVal.new( :value('File') ) ),
 
1770
        $op[0],
 
1771
        $op[1]) );
 
1772
});
 
1773
QAST::Operations.add_core_op('symlink', -> $qastcomp, $op {
 
1774
    if +$op.list != 2 {
 
1775
        nqp::die("The 'symlink' op expects two operands");
 
1776
    }
 
1777
    $qastcomp.as_post(QAST::Op.new(
 
1778
        :op('callmethod'),
 
1779
        :name('symlink'),
 
1780
        QAST::VM.new( :pirop('new__Ps'),
 
1781
                      QAST::SVal.new( :value('OS') ) ),
 
1782
        $op[0],
 
1783
        $op[1]) );
 
1784
});
 
1785
QAST::Operations.add_core_op('link', -> $qastcomp, $op {
 
1786
    if +$op.list != 2 {
 
1787
        nqp::die("The 'link' op expects two operands");
 
1788
    }
 
1789
    $qastcomp.as_post(QAST::Op.new(
 
1790
        :op('callmethod'),
 
1791
        :name('link'),
 
1792
        QAST::VM.new( :pirop('new__Ps'),
 
1793
                      QAST::SVal.new( :value('OS') ) ),
 
1794
        $op[0],
 
1795
        $op[1]) );
 
1796
});
 
1797
 
 
1798
# terms
 
1799
QAST::Operations.add_core_pirop_mapping('time_i', 'time', 'I', :inlinable(1));
 
1800
QAST::Operations.add_core_pirop_mapping('time_n', 'time', 'N', :inlinable(1));
 
1801
 
 
1802
# arithmetic opcodes
 
1803
QAST::Operations.add_core_pirop_mapping('add_i', 'add', 'Iii', :inlinable(1));
 
1804
QAST::Operations.add_core_pirop_mapping('add_I', 'nqp_bigint_add', 'PPPP', :inlinable(1));
 
1805
QAST::Operations.add_core_pirop_mapping('add_n', 'add', 'Nnn', :inlinable(1));
 
1806
QAST::Operations.add_core_pirop_mapping('sub_i', 'sub', 'Iii', :inlinable(1));
 
1807
QAST::Operations.add_core_pirop_mapping('sub_I', 'nqp_bigint_sub', 'PPPP', :inlinable(1));
 
1808
QAST::Operations.add_core_pirop_mapping('sub_n', 'sub', 'Nnn', :inlinable(1));
 
1809
QAST::Operations.add_core_pirop_mapping('mul_i', 'mul', 'Iii', :inlinable(1));
 
1810
QAST::Operations.add_core_pirop_mapping('mul_I', 'nqp_bigint_mul', 'PPPP', :inlinable(1));
 
1811
QAST::Operations.add_core_pirop_mapping('mul_n', 'mul', 'Nnn', :inlinable(1));
 
1812
QAST::Operations.add_core_pirop_mapping('div_i', 'div', 'Iii', :inlinable(1));
 
1813
QAST::Operations.add_core_pirop_mapping('div_I', 'nqp_bigint_div', 'PPPP', :inlinable(1));
 
1814
QAST::Operations.add_core_pirop_mapping('div_In', 'nqp_bigint_div_num', 'NPP', :inlinable(1));
 
1815
QAST::Operations.add_core_pirop_mapping('div_n', 'div', 'Nnn', :inlinable(1));
 
1816
QAST::Operations.add_core_pirop_mapping('mod_i', 'mod', 'Iii', :inlinable(1));
 
1817
QAST::Operations.add_core_pirop_mapping('mod_I', 'nqp_bigint_mod', 'PPPP', :inlinable(1));
 
1818
QAST::Operations.add_core_pirop_mapping('expmod_I', 'nqp_bigint_exp_mod', 'PPPPP', :inlinable(1));
 
1819
QAST::Operations.add_core_pirop_mapping('isprime_I', 'nqp_bigint_is_prime', 'IPi', :inlinable(1));
 
1820
QAST::Operations.add_core_pirop_mapping('srand', 'srand', '0i', :inlinable(1));
 
1821
QAST::Operations.add_core_pirop_mapping('rand_n', 'rand', 'Nn', :inlinable(1));
 
1822
QAST::Operations.add_core_pirop_mapping('rand_I', 'nqp_bigint_rand', 'PPP', :inlinable(1));
 
1823
QAST::Operations.add_core_pirop_mapping('mod_n', 'mod', 'Nnn', :inlinable(1));
 
1824
QAST::Operations.add_core_pirop_mapping('pow_n', 'pow', 'Nnn', :inlinable(1));
 
1825
QAST::Operations.add_core_pirop_mapping('pow_I', 'nqp_bigint_pow', 'PPPPP', :inlinable(1));
 
1826
QAST::Operations.add_core_pirop_mapping('neg_i', 'neg', 'Ii', :inlinable(1));
 
1827
QAST::Operations.add_core_pirop_mapping('neg_I', 'nqp_bigint_neg', 'PPP', :inlinable(1));
 
1828
QAST::Operations.add_core_pirop_mapping('neg_n', 'neg', 'Nn', :inlinable(1));
 
1829
QAST::Operations.add_core_pirop_mapping('abs_i', 'abs', 'Ii', :inlinable(1));
 
1830
QAST::Operations.add_core_pirop_mapping('abs_I', 'nqp_bigint_abs', 'PPP', :inlinable(1));
 
1831
QAST::Operations.add_core_pirop_mapping('abs_n', 'abs', 'Nn', :inlinable(1));
 
1832
 
 
1833
QAST::Operations.add_core_pirop_mapping('gcd_i', 'gcd', 'Iii', :inlinable(1));
 
1834
QAST::Operations.add_core_pirop_mapping('gcd_I', 'nqp_bigint_gcd', 'PPPP', :inlinable(1));
 
1835
QAST::Operations.add_core_pirop_mapping('lcm_i', 'lcm', 'Iii', :inlinable(1));
 
1836
QAST::Operations.add_core_pirop_mapping('lcm_I', 'nqp_bigint_lcm', 'PPPP', :inlinable(1));
 
1837
 
 
1838
QAST::Operations.add_core_pirop_mapping('ceil_n', 'ceil', 'Nn', :inlinable(1));
 
1839
QAST::Operations.add_core_pirop_mapping('floor_n', 'floor', 'NN', :inlinable(1));
 
1840
QAST::Operations.add_core_pirop_mapping('ln_n', 'ln', 'Nn', :inlinable(1));
 
1841
QAST::Operations.add_core_pirop_mapping('sqrt_n', 'sqrt', 'Nn', :inlinable(1));
 
1842
QAST::Operations.add_core_pirop_mapping('radix', 'nqp_radix', 'Pisii', :inlinable(1));
 
1843
QAST::Operations.add_core_pirop_mapping('radix_I', 'nqp_bigint_radix', 'PisiiP', :inlinable(1));
 
1844
QAST::Operations.add_core_pirop_mapping('log_n', 'ln', 'NN', :inlinable(1));
 
1845
QAST::Operations.add_core_pirop_mapping('exp_n', 'exp', 'Nn', :inlinable(1));
 
1846
QAST::Operations.add_core_pirop_mapping('isnanorinf', 'is_inf_or_nan', 'In', :inlinable(1));
 
1847
QAST::Operations.add_core_op('inf', :inlinable(1), -> $qastcomp, $op {
 
1848
    $qastcomp.as_post(QAST::VM.new(
 
1849
        :pirop('set Ns'),
 
1850
        QAST::SVal.new( :value('Inf') )
 
1851
    ))
 
1852
});
 
1853
QAST::Operations.add_core_op('neginf', :inlinable(1), -> $qastcomp, $op {
 
1854
    $qastcomp.as_post(QAST::VM.new(
 
1855
        :pirop('set Ns'),
 
1856
        QAST::SVal.new( :value('-Inf') )
 
1857
    ))
 
1858
});
 
1859
QAST::Operations.add_core_op('nan', :inlinable(1), -> $qastcomp, $op {
 
1860
    $qastcomp.as_post(QAST::VM.new(
 
1861
        :pirop('set Ns'),
 
1862
        QAST::SVal.new( :value('NaN') )
 
1863
    ))
 
1864
});
 
1865
 
 
1866
# trig opcodes
 
1867
QAST::Operations.add_core_pirop_mapping('sin_n', 'sin', 'NN', :inlinable(1));
 
1868
QAST::Operations.add_core_pirop_mapping('asin_n', 'asin', 'NN', :inlinable(1));
 
1869
QAST::Operations.add_core_pirop_mapping('cos_n', 'cos', 'NN', :inlinable(1));
 
1870
QAST::Operations.add_core_pirop_mapping('acos_n', 'acos', 'NN', :inlinable(1));
 
1871
QAST::Operations.add_core_pirop_mapping('tan_n', 'tan', 'NN', :inlinable(1));
 
1872
QAST::Operations.add_core_pirop_mapping('atan_n', 'atan', 'NN', :inlinable(1));
 
1873
QAST::Operations.add_core_pirop_mapping('atan2_n', 'atan', 'NNN', :inlinable(1));
 
1874
QAST::Operations.add_core_pirop_mapping('sec_n', 'sec', 'NN', :inlinable(1));
 
1875
QAST::Operations.add_core_pirop_mapping('asec_n', 'asec', 'NN', :inlinable(1));
 
1876
QAST::Operations.add_core_pirop_mapping('sin_n', 'sin', 'NN', :inlinable(1));
 
1877
QAST::Operations.add_core_pirop_mapping('asin_n', 'asin', 'NN', :inlinable(1));
 
1878
QAST::Operations.add_core_pirop_mapping('sinh_n', 'sinh', 'NN', :inlinable(1));
 
1879
QAST::Operations.add_core_pirop_mapping('cosh_n', 'cosh', 'NN', :inlinable(1));
 
1880
QAST::Operations.add_core_pirop_mapping('tanh_n', 'tanh', 'NN', :inlinable(1));
 
1881
QAST::Operations.add_core_pirop_mapping('sech_n', 'sech', 'NN', :inlinable(1));
 
1882
 
 
1883
# bitwise ops
 
1884
QAST::Operations.add_core_pirop_mapping('bitor_i', 'bor', 'Iii', :inlinable(1));
 
1885
QAST::Operations.add_core_pirop_mapping('bitor_I', 'nqp_bigint_bor', 'PPPP', :inlinable(1));
 
1886
QAST::Operations.add_core_pirop_mapping('bitxor_i', 'bxor', 'Iii', :inlinable(1));
 
1887
QAST::Operations.add_core_pirop_mapping('bitxor_I', 'nqp_bigint_bxor', 'PPPP', :inlinable(1));
 
1888
QAST::Operations.add_core_pirop_mapping('bitand_i', 'band', 'Iii', :inlinable(1));
 
1889
QAST::Operations.add_core_pirop_mapping('bitand_I', 'nqp_bigint_band', 'PPPP', :inlinable(1));
 
1890
QAST::Operations.add_core_pirop_mapping('bitneg_i', 'bnot', 'Ii', :inlinable(1));
 
1891
QAST::Operations.add_core_pirop_mapping('bitneg_I', 'nqp_bigint_bnot', 'PPP', :inlinable(1));
 
1892
QAST::Operations.add_core_pirop_mapping('bitshiftl_i', 'shl', 'Iii', :inlinable(1));
 
1893
QAST::Operations.add_core_pirop_mapping('bitshiftl_I', 'nqp_bigint_shl', 'PPIP', :inlinable(1));
 
1894
QAST::Operations.add_core_pirop_mapping('bitshiftr_i', 'shr', 'Iii', :inlinable(1));
 
1895
QAST::Operations.add_core_pirop_mapping('bitshiftr_I', 'nqp_bigint_shr', 'PPIP', :inlinable(1));
 
1896
 
 
1897
# string bitwise ops
 
1898
QAST::Operations.add_core_pirop_mapping('bitor_s', 'bors', 'Sss', :inlinable(1));
 
1899
QAST::Operations.add_core_pirop_mapping('bitxor_s', 'bxors', 'Sss', :inlinable(1));
 
1900
QAST::Operations.add_core_pirop_mapping('bitand_s', 'bands', 'Sss', :inlinable(1));
 
1901
 
 
1902
# string opcodes
 
1903
QAST::Operations.add_core_pirop_mapping('chars', 'length', 'Is', :inlinable(1));
 
1904
QAST::Operations.add_core_pirop_mapping('concat', 'concat', 'Sss', :inlinable(1));
 
1905
QAST::Operations.add_core_pirop_mapping('concat_s', 'concat', 'Sss', :inlinable(1));
 
1906
QAST::Operations.add_core_pirop_mapping('join', 'join', 'SsP', :inlinable(1));
 
1907
QAST::Operations.add_core_pirop_mapping('split', 'split', 'Pss', :inlinable(1));
 
1908
QAST::Operations.add_core_pirop_mapping('chr', 'chr', 'Si', :inlinable(1));
 
1909
QAST::Operations.add_core_pirop_mapping('lc', 'downcase', 'Ss', :inlinable(1));
 
1910
QAST::Operations.add_core_pirop_mapping('uc', 'upcase', 'Ss', :inlinable(1));
 
1911
QAST::Operations.add_core_pirop_mapping('x', 'repeat', 'Ssi', :inlinable(1));
 
1912
QAST::Operations.add_core_pirop_mapping('iscclass', 'is_cclass', 'Iisi', :inlinable(1));
 
1913
QAST::Operations.add_core_pirop_mapping('findcclass', 'find_cclass', 'Iisii', :inlinable(1));
 
1914
QAST::Operations.add_core_pirop_mapping('findnotcclass', 'find_not_cclass', 'Iisii', :inlinable(1));
 
1915
QAST::Operations.add_core_op('sprintf', :inlinable(1), -> $qastcomp, $op {
 
1916
    my @operands := $op.list;
 
1917
    $qastcomp.as_post(
 
1918
        QAST::Op.new(
 
1919
            :op('call'),
 
1920
            :returns(str),
 
1921
            QAST::Op.new(
 
1922
                :op('gethllsym'),
 
1923
                QAST::SVal.new( :value('nqp') ),
 
1924
                QAST::SVal.new( :value('sprintf') )
 
1925
            ),
 
1926
            |@operands )
 
1927
    );
 
1928
});
 
1929
QAST::Operations.add_core_op('sprintfdirectives', :inlinable(1), -> $qastcomp, $op {
 
1930
    my @operands := $op.list;
 
1931
    $qastcomp.as_post(
 
1932
        QAST::Op.new(
 
1933
            :op('call'),
 
1934
            :returns(str),
 
1935
            QAST::Op.new(
 
1936
                :op('gethllsym'),
 
1937
                QAST::SVal.new( :value('nqp') ),
 
1938
                QAST::SVal.new( :value('sprintfdirectives') )
 
1939
            ),
 
1940
            |@operands )
 
1941
    );
 
1942
});
 
1943
QAST::Operations.add_core_op('sprintfaddargumenthandler', :inlinable(1), -> $qastcomp, $op {
 
1944
    my @operands := $op.list;
 
1945
    $qastcomp.as_post(
 
1946
        QAST::Op.new(
 
1947
            :op('call'),
 
1948
            :returns(str),
 
1949
            QAST::Op.new(
 
1950
                :op('gethllsym'),
 
1951
                QAST::SVal.new( :value('nqp') ),
 
1952
                QAST::SVal.new( :value('sprintfaddargumenthandler') )
 
1953
            ),
 
1954
            |@operands )
 
1955
    );
 
1956
});
 
1957
QAST::Operations.add_core_pirop_mapping('escape', 'escape', 'SS', :inlinable(1));
 
1958
QAST::Operations.add_core_pirop_mapping('replace', 'replace', 'Ssiis', :inlinable(1));
 
1959
 
 
1960
QAST::Operations.add_core_op('flip', :inlinable(1), -> $qastcomp, $op {
 
1961
    if +@($op) != 1 {
 
1962
        nqp::die('flip requires one operand');
 
1963
    }
 
1964
    $qastcomp.as_post(
 
1965
        QAST::VM.new( :pirop('set__SP'),
 
1966
                      QAST::Op.new( :op('callmethod'),
 
1967
                                    :name('reverse'),
 
1968
                                    QAST::VM.new( :pirop('box__PS'), $op[0] ) ) )
 
1969
                    );
 
1970
});
 
1971
 
 
1972
 
 
1973
# substr can take 2 or 3 args, so needs special handling.
 
1974
QAST::Operations.add_core_pirop_mapping('substr2', 'substr', 'Ssi', :inlinable(1));
 
1975
QAST::Operations.add_core_pirop_mapping('substr3', 'substr', 'Ssii', :inlinable(1));
 
1976
QAST::Operations.add_core_op('substr', :inlinable(1), -> $qastcomp, $op {
 
1977
    my @operands := $op.list;
 
1978
    $qastcomp.as_post(+@operands == 2
 
1979
        ?? QAST::Op.new( :op('substr2'), |@operands )
 
1980
        !! QAST::Op.new( :op('substr3'), |@operands ));
 
1981
});
 
1982
 
 
1983
# ord can be on a the first char in a string or at a particular char.
 
1984
QAST::Operations.add_core_pirop_mapping('ordfirst', 'ord', 'Is', :inlinable(1));
 
1985
QAST::Operations.add_core_pirop_mapping('ordat', 'ord', 'Isi', :inlinable(1));
 
1986
QAST::Operations.add_core_op('ord', :inlinable(1), -> $qastcomp, $op {
 
1987
    my @operands := $op.list;
 
1988
    $qastcomp.as_post(+@operands == 1
 
1989
        ?? QAST::Op.new( :op('ordfirst'), |@operands )
 
1990
        !! QAST::Op.new( :op('ordat'), |@operands ));
 
1991
});
 
1992
 
 
1993
# index may or may not take a starting position
 
1994
QAST::Operations.add_core_pirop_mapping('indexfrom', 'index', 'Issi', :inlinable(1));
 
1995
QAST::Operations.add_core_op('index', :inlinable(1), -> $qastcomp, $op {
 
1996
    my @operands := $op.list;
 
1997
    $qastcomp.as_post(+@operands == 2
 
1998
        ?? QAST::Op.new( :op('indexfrom'), |@operands, QAST::IVal.new( :value(0) ) )
 
1999
        !! QAST::Op.new( :op('indexfrom'), |@operands ));
 
2000
});
 
2001
QAST::Operations.add_core_pirop_mapping('rindexfrom', 'rindex', 'Issi', :inlinable(1));
 
2002
QAST::Operations.add_core_pirop_mapping('rindexfromend', 'rindex', 'Iss', :inlinable(1));
 
2003
QAST::Operations.add_core_op('rindex', :inlinable(1), -> $qastcomp, $op {
 
2004
    my @operands := $op.list;
 
2005
    $qastcomp.as_post(+@operands == 2
 
2006
        ?? QAST::Op.new( :op('rindexfromend'), |@operands )
 
2007
        !! QAST::Op.new( :op('rindexfrom'), |@operands ));
 
2008
});
 
2009
 
 
2010
QAST::Operations.add_core_op('codepointfromname', :inlinable(1), -> $qastcomp, $op {
 
2011
    my @operands := $op.list;
 
2012
    nqp::die("codepointfromname expects a single child") unless @operands == 1;
 
2013
    my $i_reg := $*REGALLOC.fresh_i();
 
2014
    my $s_reg := $*REGALLOC.fresh_s();
 
2015
    my $ops := PIRT::Ops.new();
 
2016
    my $name := $qastcomp.coerce($qastcomp.as_post($op[0]), 'S');
 
2017
    $ops.push($name);
 
2018
    $ops.push_pirop('find_encoding', $i_reg, "'utf8'");
 
2019
    $ops.push_pirop('trans_encoding', $s_reg, $name, $i_reg);
 
2020
    $ops.push_pirop('find_codepoint', $i_reg, $s_reg);
 
2021
    $ops.result($i_reg);
 
2022
    $ops
 
2023
});
 
2024
 
 
2025
QAST::Operations.add_core_pirop_mapping('encode', 'nqp_encode', 'PssP', :inlinable(1));
 
2026
QAST::Operations.add_core_pirop_mapping('decode', 'nqp_decode', 'SPs', :inlinable(1));
 
2027
 
 
2028
# relational opcodes
 
2029
QAST::Operations.add_core_pirop_mapping('cmp_i', 'cmp', 'Iii', :inlinable(1));
 
2030
QAST::Operations.add_core_pirop_mapping('iseq_i', 'iseq', 'Iii', :inlinable(1));
 
2031
QAST::Operations.add_core_pirop_mapping('isne_i', 'isne', 'Iii', :inlinable(1));
 
2032
QAST::Operations.add_core_pirop_mapping('islt_i', 'islt', 'Iii', :inlinable(1));
 
2033
QAST::Operations.add_core_pirop_mapping('isle_i', 'isle', 'Iii', :inlinable(1));
 
2034
QAST::Operations.add_core_pirop_mapping('isgt_i', 'isgt', 'Iii', :inlinable(1));
 
2035
QAST::Operations.add_core_pirop_mapping('isge_i', 'isge', 'Iii', :inlinable(1));
 
2036
 
 
2037
QAST::Operations.add_core_pirop_mapping('bool_I', 'nqp_bigint_bool', 'IP', :inlinable(1));
 
2038
QAST::Operations.add_core_pirop_mapping('cmp_I', 'nqp_bigint_cmp', 'IPP', :inlinable(1));
 
2039
QAST::Operations.add_core_pirop_mapping('iseq_I', 'nqp_bigint_eq', 'IPP', :inlinable(1));
 
2040
QAST::Operations.add_core_pirop_mapping('isne_I', 'nqp_bigint_ne', 'IPP', :inlinable(1));
 
2041
QAST::Operations.add_core_pirop_mapping('islt_I', 'nqp_bigint_lt', 'IPP', :inlinable(1));
 
2042
QAST::Operations.add_core_pirop_mapping('isle_I', 'nqp_bigint_le', 'IPP', :inlinable(1));
 
2043
QAST::Operations.add_core_pirop_mapping('isgt_I', 'nqp_bigint_gt', 'IPP', :inlinable(1));
 
2044
QAST::Operations.add_core_pirop_mapping('isge_I', 'nqp_bigint_ge', 'IPP', :inlinable(1));
 
2045
 
 
2046
QAST::Operations.add_core_pirop_mapping('cmp_n', 'cmp', 'Inn', :inlinable(1));
 
2047
QAST::Operations.add_core_pirop_mapping('iseq_n', 'iseq', 'Inn', :inlinable(1));
 
2048
QAST::Operations.add_core_pirop_mapping('isne_n', 'isne', 'Inn', :inlinable(1));
 
2049
QAST::Operations.add_core_pirop_mapping('islt_n', 'islt', 'Inn', :inlinable(1));
 
2050
QAST::Operations.add_core_pirop_mapping('isle_n', 'isle', 'Inn', :inlinable(1));
 
2051
QAST::Operations.add_core_pirop_mapping('isgt_n', 'isgt', 'Inn', :inlinable(1));
 
2052
QAST::Operations.add_core_pirop_mapping('isge_n', 'isge', 'Inn', :inlinable(1));
 
2053
 
 
2054
QAST::Operations.add_core_pirop_mapping('cmp_s', 'cmp', 'Iss', :inlinable(1));
 
2055
QAST::Operations.add_core_pirop_mapping('iseq_s', 'iseq', 'Iss', :inlinable(1));
 
2056
QAST::Operations.add_core_pirop_mapping('isne_s', 'isne', 'Iss', :inlinable(1));
 
2057
QAST::Operations.add_core_pirop_mapping('islt_s', 'islt', 'Iss', :inlinable(1));
 
2058
QAST::Operations.add_core_pirop_mapping('isle_s', 'isle', 'Iss', :inlinable(1));
 
2059
QAST::Operations.add_core_pirop_mapping('isgt_s', 'isgt', 'Iss', :inlinable(1));
 
2060
QAST::Operations.add_core_pirop_mapping('isge_s', 'isge', 'Iss', :inlinable(1));
 
2061
 
 
2062
# bigint ops
 
2063
QAST::Operations.add_core_pirop_mapping('fromstr_I', 'nqp_bigint_from_str', 'PsP', :inlinable(1));
 
2064
QAST::Operations.add_core_pirop_mapping('tostr_I', 'nqp_bigint_to_str', 'SP', :inlinable(1));
 
2065
QAST::Operations.add_core_pirop_mapping('base_I', 'nqp_bigint_to_str_base', 'SPI', :inlinable(1));
 
2066
QAST::Operations.add_core_pirop_mapping('isbig_I', 'nqp_bigint_is_big', 'IP', :inlinable(1));
 
2067
QAST::Operations.add_core_pirop_mapping('fromnum_I', 'nqp_bigint_from_num', 'PNP', :inlinable(1));
 
2068
QAST::Operations.add_core_pirop_mapping('tonum_I', 'nqp_bigint_to_num', 'NP', :inlinable(1));
 
2069
 
 
2070
# native call ops
 
2071
QAST::Operations.add_core_pirop_mapping('initnativecall', 'nqp_native_call_setup', 'v');
 
2072
QAST::Operations.add_core_pirop_mapping('buildnativecall', 'nqp_native_call_build', 'vPsssPP');
 
2073
QAST::Operations.add_core_pirop_mapping('nativecall', 'nqp_native_call', 'PPPP');
 
2074
QAST::Operations.add_core_pirop_mapping('nativecallrefresh', 'nqp_native_call_wb', 'vP');
 
2075
QAST::Operations.add_core_pirop_mapping('x_posixerrno', 'nqp_posixerrno', 'I');
 
2076
 
 
2077
# boolean opcodes
 
2078
QAST::Operations.add_core_pirop_mapping('not_i', 'not', 'Ii', :inlinable(1));
 
2079
 
 
2080
# aggregate opcodes, mapping to the Parrot v-table functions
 
2081
QAST::Operations.add_core_pirop_mapping('atkey', 'set', 'PQs', :inlinable(1));
 
2082
QAST::Operations.add_core_pirop_mapping('atkey_i', 'set', 'IQs', :inlinable(1));
 
2083
QAST::Operations.add_core_pirop_mapping('atkey_n', 'set', 'NQs', :inlinable(1));
 
2084
QAST::Operations.add_core_pirop_mapping('atkey_s', 'set', 'SQs', :inlinable(1));
 
2085
QAST::Operations.add_core_pirop_mapping('atpos', 'set', 'PQi', :inlinable(1));
 
2086
QAST::Operations.add_core_pirop_mapping('atpos_i', 'set', 'IQi', :inlinable(1));
 
2087
QAST::Operations.add_core_pirop_mapping('atpos_n', 'set', 'NQi', :inlinable(1));
 
2088
QAST::Operations.add_core_pirop_mapping('atpos_s', 'set', 'SQi', :inlinable(1));
 
2089
QAST::Operations.add_core_pirop_mapping('bindkey', 'set', '1QsP', :inlinable(1));
 
2090
QAST::Operations.add_core_pirop_mapping('bindkey_i', 'set', '1QsI', :inlinable(1));
 
2091
QAST::Operations.add_core_pirop_mapping('bindkey_n', 'set', '1QsN', :inlinable(1));
 
2092
QAST::Operations.add_core_pirop_mapping('bindkey_s', 'set', '1QsS', :inlinable(1));
 
2093
QAST::Operations.add_core_pirop_mapping('bindpos', 'set', '1QiP', :inlinable(1));
 
2094
QAST::Operations.add_core_pirop_mapping('bindpos_i', 'set', '1Qii', :inlinable(1));
 
2095
QAST::Operations.add_core_pirop_mapping('bindpos_n', 'set', '1Qin', :inlinable(1));
 
2096
QAST::Operations.add_core_pirop_mapping('bindpos_s', 'set', '1Qis', :inlinable(1));
 
2097
QAST::Operations.add_core_pirop_mapping('deletekey', 'delete', '0Qs', :inlinable(1));
 
2098
QAST::Operations.add_core_pirop_mapping('existskey', 'exists', 'IQs', :inlinable(1));
 
2099
QAST::Operations.add_core_pirop_mapping('existspos', 'exists', 'IQi', :inlinable(1));
 
2100
QAST::Operations.add_core_pirop_mapping('elems', 'elements', 'IP', :inlinable(1));
 
2101
QAST::Operations.add_core_pirop_mapping('setelems', 'assign', '0Pi', :inlinable(1));
 
2102
QAST::Operations.add_core_pirop_mapping('push', 'push', '0PP', :inlinable(1));
 
2103
QAST::Operations.add_core_pirop_mapping('push_s', 'push', '0Ps', :inlinable(1));
 
2104
QAST::Operations.add_core_pirop_mapping('push_i', 'push', '0Pi', :inlinable(1));
 
2105
QAST::Operations.add_core_pirop_mapping('push_n', 'push', '0Pn', :inlinable(1));
 
2106
QAST::Operations.add_core_pirop_mapping('pop', 'pop', 'PP', :inlinable(1));
 
2107
QAST::Operations.add_core_pirop_mapping('pop_s', 'pop', 'SP', :inlinable(1));
 
2108
QAST::Operations.add_core_pirop_mapping('pop_i', 'pop', 'IP', :inlinable(1));
 
2109
QAST::Operations.add_core_pirop_mapping('pop_n', 'pop', 'NP', :inlinable(1));
 
2110
QAST::Operations.add_core_pirop_mapping('shift', 'shift', 'PP', :inlinable(1));
 
2111
QAST::Operations.add_core_pirop_mapping('shift_s', 'shift', 'SP', :inlinable(1));
 
2112
QAST::Operations.add_core_pirop_mapping('shift_i', 'shift', 'IP', :inlinable(1));
 
2113
QAST::Operations.add_core_pirop_mapping('shift_n', 'shift', 'NP', :inlinable(1));
 
2114
QAST::Operations.add_core_pirop_mapping('unshift', 'unshift', '0PP', :inlinable(1));
 
2115
QAST::Operations.add_core_pirop_mapping('unshift_s', 'unshift', '0Ps', :inlinable(1));
 
2116
QAST::Operations.add_core_pirop_mapping('unshift_i', 'unshift', '0Pi', :inlinable(1));
 
2117
QAST::Operations.add_core_pirop_mapping('unshift_n', 'unshift', '0Pn', :inlinable(1));
 
2118
QAST::Operations.add_core_pirop_mapping('splice', 'splice', '0PPii', :inlinable(1));
 
2119
QAST::Operations.add_core_pirop_mapping('isint', 'nqp_isint', 'IP', :inlinable(1));
 
2120
QAST::Operations.add_core_pirop_mapping('isnum', 'nqp_isnum', 'IP', :inlinable(1));
 
2121
QAST::Operations.add_core_pirop_mapping('isstr', 'nqp_isstr', 'IP', :inlinable(1));
 
2122
QAST::Operations.add_core_pirop_mapping('islist', 'nqp_islist', 'IP', :inlinable(1));
 
2123
QAST::Operations.add_core_pirop_mapping('ishash', 'nqp_ishash', 'IP', :inlinable(1));
 
2124
QAST::Operations.add_core_pirop_mapping('isinvokable', 'is_invokable', 'IP', :inlinable(1));
 
2125
QAST::Operations.add_core_pirop_mapping('iterator', 'iter', 'PP', :inlinable(1));
 
2126
QAST::Operations.add_core_op('iterkey_s', -> $qastcomp, $op {
 
2127
    $qastcomp.as_post(QAST::Op.new( :op('callmethod'), :name('key'), $op[0] ))
 
2128
});
 
2129
QAST::Operations.add_core_op('iterval', -> $qastcomp, $op {
 
2130
    $qastcomp.as_post(QAST::Op.new( :op('callmethod'), :name('value'), $op[0] ))
 
2131
});
 
2132
 
 
2133
# repr-level aggregate operations
 
2134
QAST::Operations.add_core_pirop_mapping('r_atpos', 'repr_at_pos_obj', 'PPi', :inlinable(1));
 
2135
QAST::Operations.add_core_pirop_mapping('r_atpos_i', 'repr_at_pos_int', 'IPi', :inlinable(1));
 
2136
QAST::Operations.add_core_pirop_mapping('r_atpos_n', 'repr_at_pos_num', 'NPi', :inlinable(1));
 
2137
QAST::Operations.add_core_pirop_mapping('r_bindpos', 'repr_bind_pos_obj', '2PiP', :inlinable(1));
 
2138
QAST::Operations.add_core_pirop_mapping('r_bindpos_i', 'repr_bind_pos_int', '2Pii', :inlinable(1));
 
2139
QAST::Operations.add_core_pirop_mapping('r_bindpos_n', 'repr_bind_pos_num', '2Pin', :inlinable(1));
 
2140
QAST::Operations.add_core_pirop_mapping('r_elems', 'repr_elems', 'IP', :inlinable(1));
 
2141
 
 
2142
sub str_or_want($op) {
 
2143
    nqp::istype($op, QAST::SVal) || nqp::istype($op, QAST::Want) && +@($op)[1] eq 'Ss';
 
2144
}
 
2145
 
 
2146
sub val_from_str_or_want($op) {
 
2147
    nqp::istype($op, QAST::SVal)
 
2148
        ?? $op.value
 
2149
        !! $op[2].value
 
2150
}
 
2151
 
 
2152
# object opcodes
 
2153
QAST::Operations.add_core_pirop_mapping('bindattr', 'setattribute', '3PPsP', :inlinable(1));
 
2154
QAST::Operations.add_core_pirop_mapping('bindattr_i_nh', 'repr_bind_attr_int', '3PPsi', :inlinable(1));
 
2155
QAST::Operations.add_core_pirop_mapping('bindattr_i_h', 'repr_bind_attr_int', '3PPsii', :inlinable(1));
 
2156
QAST::Operations.add_core_op('bindattr_i', :inlinable(1), -> $qastcomp, $op {
 
2157
    if +@($op) != 4 {
 
2158
        nqp::die('bindattr_i requires four operands');
 
2159
    }
 
2160
    my $hint := -1;
 
2161
    if nqp::istype($op[1], QAST::WVal) && str_or_want($op[2]) {
 
2162
        $hint := pir::repr_hint_for__IPs($op[1].value, val_from_str_or_want($op[2]));
 
2163
    }
 
2164
    if $hint != -1 {
 
2165
        $qastcomp.as_post(QAST::Op.new(
 
2166
            :op('bindattr_i_h'),
 
2167
            $op[0],
 
2168
            $op[1],
 
2169
            $op[2],
 
2170
            QAST::IVal.new(:value($hint)),
 
2171
            $op[3]
 
2172
        ));
 
2173
    } else {
 
2174
        $qastcomp.as_post(QAST::Op.new(
 
2175
            :op('bindattr_i_nh'),
 
2176
            $op[0],
 
2177
            $op[1],
 
2178
            $op[2],
 
2179
            $op[3]
 
2180
        ));
 
2181
    }
 
2182
});
 
2183
QAST::Operations.add_core_pirop_mapping('bindattr_n', 'repr_bind_attr_num', '3PPsn', :inlinable(1));
 
2184
QAST::Operations.add_core_pirop_mapping('bindattr_s', 'repr_bind_attr_str', '3PPss', :inlinable(1));
 
2185
QAST::Operations.add_core_pirop_mapping('bindattr_s_nh', 'repr_bind_attr_str', '3PPss', :inlinable(1));
 
2186
QAST::Operations.add_core_pirop_mapping('bindattr_s_h', 'repr_bind_attr_str', '3PPsis', :inlinable(1));
 
2187
QAST::Operations.add_core_op('bindattr_s', :inlinable(1), -> $qastcomp, $op {
 
2188
    if +@($op) != 4 {
 
2189
        nqp::die('bindattr_s requires four operands');
 
2190
    }
 
2191
    my $hint := -1;
 
2192
    if nqp::istype($op[1], QAST::WVal) && str_or_want($op[2]) {
 
2193
        $hint := pir::repr_hint_for__IPs($op[1].value, val_from_str_or_want($op[2]));
 
2194
    }
 
2195
    if $hint != -1 {
 
2196
        $qastcomp.as_post(QAST::Op.new(
 
2197
            :op('bindattr_s_h'),
 
2198
            $op[0],
 
2199
            $op[1],
 
2200
            $op[2],
 
2201
            QAST::IVal.new(:value($hint)),
 
2202
            $op[3]
 
2203
        ));
 
2204
    } else {
 
2205
        $qastcomp.as_post(QAST::Op.new(
 
2206
            :op('bindattr_s_nh'),
 
2207
            $op[0],
 
2208
            $op[1],
 
2209
            $op[2],
 
2210
            $op[3]
 
2211
        ));
 
2212
    }
 
2213
});
 
2214
QAST::Operations.add_core_pirop_mapping('getattr', 'getattribute', 'PPPs', :inlinable(1));
 
2215
QAST::Operations.add_core_pirop_mapping('getattr_i_nh', 'repr_get_attr_int', 'IPPs', :inlinable(1));
 
2216
QAST::Operations.add_core_pirop_mapping('getattr_i_h', 'repr_get_attr_int', 'IPPsi', :inlinable(1));
 
2217
QAST::Operations.add_core_op('getattr_i', :inlinable(1), -> $qastcomp, $op {
 
2218
    if +@($op) != 3 {
 
2219
        nqp::die('getattr_i requires three operands');
 
2220
    }
 
2221
    my $hint := -1;
 
2222
    if nqp::istype($op[1], QAST::WVal) && str_or_want($op[2]) {
 
2223
        $hint := pir::repr_hint_for__IPs($op[1].value, val_from_str_or_want($op[2]));
 
2224
    }
 
2225
    if $hint != -1 {
 
2226
        $qastcomp.as_post(QAST::Op.new(
 
2227
            :op('getattr_i_h'),
 
2228
            $op[0],
 
2229
            $op[1],
 
2230
            $op[2],
 
2231
            QAST::IVal.new(:value($hint))
 
2232
        ));
 
2233
    } else {
 
2234
        $qastcomp.as_post(QAST::Op.new(
 
2235
            :op('getattr_i_nh'),
 
2236
            $op[0],
 
2237
            $op[1],
 
2238
            $op[2]
 
2239
        ));
 
2240
    }
 
2241
});
 
2242
QAST::Operations.add_core_pirop_mapping('getattr_n', 'repr_get_attr_num', 'NPPs', :inlinable(1));
 
2243
QAST::Operations.add_core_pirop_mapping('getattr_s_nh', 'repr_get_attr_str', 'SPPs', :inlinable(1));
 
2244
QAST::Operations.add_core_pirop_mapping('getattr_s_h', 'repr_get_attr_str', 'SPPsi', :inlinable(1));
 
2245
QAST::Operations.add_core_op('getattr_s', :inlinable(1), -> $qastcomp, $op {
 
2246
    if +@($op) != 3 {
 
2247
        nqp::die('getattr_s requires three operands');
 
2248
    }
 
2249
    my $hint := -1;
 
2250
    if nqp::istype($op[1], QAST::WVal) && str_or_want($op[2]) {
 
2251
        $hint := pir::repr_hint_for__IPs($op[1].value, val_from_str_or_want($op[2]));
 
2252
    }
 
2253
    if $hint != -1 {
 
2254
        $qastcomp.as_post(QAST::Op.new(
 
2255
            :op('getattr_s_h'),
 
2256
            $op[0],
 
2257
            $op[1],
 
2258
            $op[2],
 
2259
            QAST::IVal.new(:value($hint))
 
2260
        ));
 
2261
    } else {
 
2262
        $qastcomp.as_post(QAST::Op.new(
 
2263
            :op('getattr_s_nh'),
 
2264
            $op[0],
 
2265
            $op[1],
 
2266
            $op[2]
 
2267
        ));
 
2268
    }
 
2269
});
 
2270
QAST::Operations.add_core_pirop_mapping('attrinited', 'repr_is_attr_initialized', 'IPPs', :inlinable(1));
 
2271
QAST::Operations.add_core_pirop_mapping('create', 'repr_instance_of', 'PP', :inlinable(1));
 
2272
QAST::Operations.add_core_pirop_mapping('clone', 'repr_clone', 'PP', :inlinable(1));
 
2273
QAST::Operations.add_core_pirop_mapping('isconcrete', 'repr_defined', 'IP', :inlinable(1));
 
2274
QAST::Operations.add_core_pirop_mapping('isnull', 'isnull', 'IP', :inlinable(1));
 
2275
QAST::Operations.add_core_pirop_mapping('isnull_s', 'isnull', 'IS', :inlinable(1));
 
2276
QAST::Operations.add_core_pirop_mapping('istrue', 'istrue', 'IP', :inlinable(1));
 
2277
QAST::Operations.add_core_pirop_mapping('isfalse', 'isfalse', 'IP', :inlinable(1));
 
2278
QAST::Operations.add_core_pirop_mapping('istype', 'type_check', 'IPP', :inlinable(1));
 
2279
QAST::Operations.add_core_pirop_mapping('null', 'null', 'P', :inlinable(1));
 
2280
QAST::Operations.add_core_pirop_mapping('null_s', 'null', 'S', :inlinable(1));
 
2281
QAST::Operations.add_core_pirop_mapping('unbox_i', 'repr_unbox_int', 'IP', :inlinable(1));
 
2282
QAST::Operations.add_core_pirop_mapping('unbox_n', 'repr_unbox_num', 'NP', :inlinable(1));
 
2283
QAST::Operations.add_core_pirop_mapping('unbox_s', 'repr_unbox_str', 'SP', :inlinable(1));
 
2284
QAST::Operations.add_core_pirop_mapping('box_i', 'repr_box_int', 'PiP', :inlinable(1));
 
2285
QAST::Operations.add_core_pirop_mapping('box_n', 'repr_box_num', 'PnP', :inlinable(1));
 
2286
QAST::Operations.add_core_pirop_mapping('box_s', 'repr_box_str', 'PsP', :inlinable(1));
 
2287
QAST::Operations.add_core_pirop_mapping('what', 'get_what', 'PP', :inlinable(1));
 
2288
QAST::Operations.add_core_pirop_mapping('how', 'get_how', 'PP', :inlinable(1));
 
2289
QAST::Operations.add_core_pirop_mapping('who', 'get_who', 'PP', :inlinable(1));
 
2290
QAST::Operations.add_core_pirop_mapping('where', 'get_id', 'IP', :inlinable(1));
 
2291
QAST::Operations.add_core_pirop_mapping('findmethod', 'find_method', 'PPs', :inlinable(1));
 
2292
QAST::Operations.add_core_pirop_mapping('defined', 'defined', 'IP', :inlinable(1));
 
2293
QAST::Operations.add_core_pirop_mapping('can', 'can', 'IPs', :inlinable(1));
 
2294
QAST::Operations.add_core_pirop_mapping('reprname', 'repr_name', 'SP', :inlinable(1));
 
2295
QAST::Operations.add_core_pirop_mapping('newtype', 'repr_type_object_for', 'PPs', :inlinable(1));
 
2296
QAST::Operations.add_core_pirop_mapping('composetype', 'repr_compose', '0PP', :inlinable(1));
 
2297
QAST::Operations.add_core_pirop_mapping('setwho', 'set_who', '0PP', :inlinable(1));
 
2298
QAST::Operations.add_core_pirop_mapping('rebless', 'repr_change_type', '0PP', :inlinable(1));
 
2299
QAST::Operations.add_core_pirop_mapping('knowhow', 'get_knowhow', 'P', :inlinable(1));
 
2300
QAST::Operations.add_core_pirop_mapping('knowhowattr', 'get_knowhow_attribute', 'P', :inlinable(1));
 
2301
QAST::Operations.add_core_pirop_mapping('setboolspec', 'set_boolification_spec', '0PiP', :inlinable(1));
 
2302
QAST::Operations.add_core_pirop_mapping('setmethcache', 'publish_method_cache', '0PP', :inlinable(1));
 
2303
QAST::Operations.add_core_pirop_mapping('setmethcacheauth', 'set_method_cache_authoritativeness', '0Pi', :inlinable(1));
 
2304
QAST::Operations.add_core_pirop_mapping('settypecache', 'publish_type_check_cache', '0PP', :inlinable(1));
 
2305
QAST::Operations.add_core_pirop_mapping('settypecheckmode', 'stable_set_type_check_mode', '0Pi', :inlinable(1));
 
2306
QAST::Operations.add_core_pirop_mapping('objprimspec', 'repr_get_primitive_type_spec', 'IP', :inlinable(1));
 
2307
QAST::Operations.add_core_pirop_mapping('setinvokespec', 'set_invocation_spec', '0PPsP', :inlinable(1));
 
2308
 
 
2309
# container related
 
2310
QAST::Operations.add_core_pirop_mapping('setcontspec', 'set_container_spec', '0PsP', :inlinable(1));
 
2311
QAST::Operations.add_core_pirop_mapping('iscont', 'is_container', 'IP', :inlinable(1));
 
2312
QAST::Operations.add_core_pirop_mapping('decont', 'nqp_decontainerize', 'PP', :inlinable(1));
 
2313
QAST::Operations.add_core_pirop_mapping('assign', 'nqp_assign', '0PP', :inlinable(1));
 
2314
QAST::Operations.add_core_pirop_mapping('assignunchecked', 'nqp_assignunchecked', '0PP', :inlinable(1));
 
2315
QAST::Operations.add_core_op('eqaddr', -> $qastcomp, $op {
 
2316
    $qastcomp.as_post(QAST::Op.new(
 
2317
        :op('iseq_i'),
 
2318
        QAST::Op.new( :op('where'), $op[0] ),
 
2319
        QAST::Op.new( :op('where'), $op[1] )
 
2320
    ))
 
2321
});
 
2322
 
 
2323
# lexical related opcodes
 
2324
QAST::Operations.add_core_pirop_mapping('getlex', 'find_lex', 'Ps');
 
2325
QAST::Operations.add_core_pirop_mapping('getlex_i', 'find_lex', 'Is');
 
2326
QAST::Operations.add_core_pirop_mapping('getlex_n', 'find_lex', 'Ns');
 
2327
QAST::Operations.add_core_pirop_mapping('getlex_s', 'find_lex', 'Ss');
 
2328
QAST::Operations.add_core_pirop_mapping('bindlex', 'store_lex', '1sP');
 
2329
QAST::Operations.add_core_pirop_mapping('bindlex_i', 'store_lex', '1si');
 
2330
QAST::Operations.add_core_pirop_mapping('bindlex_n', 'store_lex', '1sn');
 
2331
QAST::Operations.add_core_pirop_mapping('bindlex_s', 'store_lex', '1ss');
 
2332
QAST::Operations.add_core_pirop_mapping('getlexdyn', 'find_dynamic_lex', 'Ps');
 
2333
QAST::Operations.add_core_pirop_mapping('bindlexdyn', 'store_dynamic_lex', '1sP');
 
2334
QAST::Operations.add_core_pirop_mapping('getlexcaller', 'find_caller_lex', 'Ps');
 
2335
QAST::Operations.add_core_pirop_mapping('getlexouter', 'nqp_getlexouter', 'Ps');
 
2336
QAST::Operations.add_core_pirop_mapping('getlexrel', 'nqp_getlexrel', 'PPs');
 
2337
QAST::Operations.add_core_pirop_mapping('getlexreldyn', 'nqp_getlexreldyn', 'PPs');
 
2338
QAST::Operations.add_core_pirop_mapping('getlexrelcaller', 'nqp_getlexrelcaller', 'PPs');
 
2339
QAST::Operations.add_core_op('locallifetime', :inlinable(1), -> $qastcomp, $op {
 
2340
    if +@($op) < 1 {
 
2341
        nqp::die('locallifetime requires at least one operand');
 
2342
    }
 
2343
 
 
2344
    $qastcomp.as_post( $op[0] );
 
2345
});
 
2346
 
 
2347
# code object related opcodes
 
2348
QAST::Operations.add_core_pirop_mapping('takeclosure', 'newclosure', 'PP');
 
2349
QAST::Operations.add_core_pirop_mapping('getcodeobj', 'get_sub_code_object', 'PP');
 
2350
QAST::Operations.add_core_pirop_mapping('setcodeobj', 'set_sub_code_object', '1PP');
 
2351
QAST::Operations.add_core_pirop_mapping('getcodename', 'set', 'SP');
 
2352
QAST::Operations.add_core_pirop_mapping('setcodename', 'assign', '1Ps');
 
2353
QAST::Operations.add_core_op('getcodecuid', -> $qastcomp, $op {
 
2354
    if +@($op) != 1 {
 
2355
        nqp::die('getcodecuid requires one operand');
 
2356
    }
 
2357
    $qastcomp.as_post(QAST::Op.new(
 
2358
        :op('callmethod'), :name('get_subid'),
 
2359
        $op[0]
 
2360
    ))
 
2361
});
 
2362
QAST::Operations.add_core_op('forceouterctx', -> $qastcomp, $op {
 
2363
    if +@($op) != 2 {
 
2364
        nqp::die('forceouterctx requires two operands');
 
2365
    }
 
2366
    $qastcomp.as_post(QAST::Op.new(
 
2367
        :op('callmethod'), :name('set_outer_ctx'),
 
2368
        $op[0], $op[1]
 
2369
    ))
 
2370
});
 
2371
QAST::Operations.add_core_pirop_mapping('freshcoderef', 'nqp_fresh_stub', 'PP');
 
2372
QAST::Operations.add_core_pirop_mapping('replacecoderef', 'assign', '0PP');
 
2373
QAST::Operations.add_core_op('markcodestatic', -> $qastcomp, $op {
 
2374
    if +@($op) != 1 {
 
2375
        nqp::die('markcodestatic requires one operand');
 
2376
    }
 
2377
    my $ops := PIRT::Ops.new();
 
2378
    my $code := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
2379
    $ops.push($code);
 
2380
    $ops.push_pirop('setprop', $code, "'STATIC_CODE_REF'", $code);
 
2381
    $ops.result($code);
 
2382
    $ops
 
2383
});
 
2384
QAST::Operations.add_core_op('markcodestub', -> $qastcomp, $op {
 
2385
    if +@($op) != 1 {
 
2386
        nqp::die('markcodestatic requires one operand');
 
2387
    }
 
2388
    my $ops := PIRT::Ops.new();
 
2389
    my $code := $qastcomp.coerce($qastcomp.as_post($op[0]), 'P');
 
2390
    $ops.push($code);
 
2391
    $ops.push_pirop('setprop', $code, "'COMPILER_STUB'", $code);
 
2392
    $ops.result($code);
 
2393
    $ops
 
2394
});
 
2395
QAST::Operations.add_core_op('getstaticcode', -> $qastcomp, $op {
 
2396
    if +@($op) != 1 {
 
2397
        nqp::die('getcodecuid requires one operand');
 
2398
    }
 
2399
    $qastcomp.as_post(QAST::Op.new(
 
2400
        :op('callmethod'), :name('get_static_code'),
 
2401
        QAST::Op.new(
 
2402
            :op('callmethod'), :name('get_lexinfo'),
 
2403
            $op[0]
 
2404
        )))
 
2405
});
 
2406
QAST::Operations.add_core_pirop_mapping('setdispatcher', 'nqp_setdispatcher', '0P');
 
2407
QAST::Operations.add_core_pirop_mapping('takedispatcher', 'nqp_takedispatcher', '0s');
 
2408
 
 
2409
# serialization context related opcodes
 
2410
QAST::Operations.add_core_pirop_mapping('sha1', 'nqp_sha1', 'Ss');
 
2411
QAST::Operations.add_core_pirop_mapping('createsc', 'nqp_create_sc', 'Ps');
 
2412
QAST::Operations.add_core_pirop_mapping('scsetobj', 'set', '1QiP');
 
2413
QAST::Operations.add_core_pirop_mapping('scsetcode', 'nqp_add_code_ref_to_sc', '2PiP');
 
2414
QAST::Operations.add_core_pirop_mapping('scgetobj', 'set', 'PQi');
 
2415
QAST::Operations.add_core_pirop_mapping('scgetcode', 'nqp_get_sc_code_ref', 'Psi');
 
2416
QAST::Operations.add_core_op('scgethandle', -> $qastcomp, $op {
 
2417
    $qastcomp.as_post(QAST::Op.new(
 
2418
        :op('callmethod'), :name('handle'), :returns(str),
 
2419
        $op[0]
 
2420
    ))
 
2421
});
 
2422
QAST::Operations.add_core_op('scgetdesc', -> $qastcomp, $op {
 
2423
    $qastcomp.as_post(QAST::Op.new(
 
2424
        :op('callmethod'), :name('description'), :returns(str),
 
2425
        $op[0]
 
2426
    ))
 
2427
});
 
2428
QAST::Operations.add_core_op('scgetobjidx', -> $qastcomp, $op {
 
2429
    $qastcomp.as_post(QAST::Op.new(
 
2430
        :op('callmethod'), :name('slot_index_for'), :returns(int),
 
2431
        $op[0], $op[1]
 
2432
    ))
 
2433
});
 
2434
QAST::Operations.add_core_op('scsetdesc', -> $qastcomp, $op {
 
2435
    $qastcomp.as_post(QAST::Op.new(
 
2436
        :op('callmethod'), :name('set_description'),
 
2437
        $op[0], $op[1]
 
2438
    ))
 
2439
});
 
2440
QAST::Operations.add_core_op('scobjcount', -> $qastcomp, $op {
 
2441
    $qastcomp.as_post(QAST::Op.new(
 
2442
        :op('callmethod'), :name('elems'),
 
2443
        $op[0]
 
2444
    ))
 
2445
});
 
2446
QAST::Operations.add_core_pirop_mapping('setobjsc', 'nqp_set_sc_for_object', '0PP');
 
2447
QAST::Operations.add_core_pirop_mapping('getobjsc', 'nqp_get_sc_for_object', 'PP');
 
2448
QAST::Operations.add_core_pirop_mapping('serialize', 'nqp_serialize_sc', 'SPP');
 
2449
QAST::Operations.add_core_pirop_mapping('deserialize', 'nqp_deserialize_sc', '0sPPPP');
 
2450
QAST::Operations.add_core_pirop_mapping('wval', 'nqp_get_sc_object', 'Psi');
 
2451
QAST::Operations.add_core_op('scwbdisable', -> $qastcomp, $op {
 
2452
    my $ops := PIRT::Ops.new();
 
2453
    $ops.push_pirop('nqp_disable_sc_write_barrier');
 
2454
    $ops.result('0');
 
2455
    $ops
 
2456
});
 
2457
QAST::Operations.add_core_op('scwbenable', -> $qastcomp, $op {
 
2458
    my $ops := PIRT::Ops.new();
 
2459
    $ops.push_pirop('nqp_enable_sc_write_barrier');
 
2460
    $ops.result('0');
 
2461
    $ops
 
2462
});
 
2463
QAST::Operations.add_core_pirop_mapping('pushcompsc', 'nqp_push_compiling_sc', '0P');
 
2464
QAST::Operations.add_core_op('popcompsc', -> $qastcomp, $op {
 
2465
    my $ops := PIRT::Ops.new();
 
2466
    $ops.push_pirop('nqp_pop_compiling_sc');
 
2467
    $ops.result('0');
 
2468
    $ops
 
2469
});
 
2470
 
 
2471
# hll related opcodes
 
2472
QAST::Operations.add_core_pirop_mapping('getcomp', 'compreg', 'Ps');
 
2473
QAST::Operations.add_core_pirop_mapping('bindcomp', 'compreg', '1sP');
 
2474
QAST::Operations.add_core_pirop_mapping('getcurhllsym', 'get_hll_global', 'Ps');
 
2475
QAST::Operations.add_core_pirop_mapping('bindcurhllsym', 'set_hll_global', '1sP');
 
2476
QAST::Operations.add_core_pirop_mapping('loadbytecode', 'load_bytecode', '0s');
 
2477
QAST::Operations.add_core_op('gethllsym', -> $qastcomp, $op {
 
2478
    if +@($op) != 2 {
 
2479
        nqp::die('gethllsym requires two operands');
 
2480
    }
 
2481
    $qastcomp.as_post(QAST::VM.new(
 
2482
        :pirop('get_root_global__PPs'),
 
2483
        QAST::Op.new( :op('list_s'), $op[0] ),
 
2484
        $op[1]
 
2485
    ))
 
2486
});
 
2487
QAST::Operations.add_core_op('bindhllsym', -> $qastcomp, $op {
 
2488
    if +@($op) != 3 {
 
2489
        nqp::die('bindhllsym requires three operands');
 
2490
    }
 
2491
    $qastcomp.as_post(QAST::VM.new(
 
2492
        :pirop('set_root_global__2PsP'),
 
2493
        QAST::Op.new( :op('list_s'), $op[0] ),
 
2494
        $op[1],
 
2495
        $op[2]
 
2496
    ))
 
2497
});
 
2498
QAST::Operations.add_core_pirop_mapping('sethllconfig', 'nqp_sethllconfig', 'PsP');
 
2499
QAST::Operations.add_core_pirop_mapping('settypehll', 'nqp_settypehll', '0Ps');
 
2500
QAST::Operations.add_core_pirop_mapping('settypehllrole', 'nqp_settypehllrole', '0Pi');
 
2501
QAST::Operations.add_core_pirop_mapping('hllize', 'nqp_hllize', 'PP');
 
2502
QAST::Operations.add_core_pirop_mapping('hllizefor', 'nqp_hllizefor', 'PPs');
 
2503
 
 
2504
# regex engine related opcodes
 
2505
QAST::Operations.add_core_pirop_mapping('nfafromstatelist', 'nqp_nfa_from_statelist', 'PPP');
 
2506
QAST::Operations.add_core_pirop_mapping('nfatostatelist', 'nqp_nfa_to_statelist', 'PP');
 
2507
QAST::Operations.add_core_pirop_mapping('nfarunproto', 'nqp_nfa_run_proto', 'PPsi');
 
2508
QAST::Operations.add_core_pirop_mapping('nfarunalt', 'nqp_nfa_run_alt', '0PsiPPP');
 
2509
 
 
2510
# process related opcodes
 
2511
QAST::Operations.add_core_pirop_mapping('exit', 'exit', '0i', :inlinable(1));
 
2512
QAST::Operations.add_core_pirop_mapping('sleep', 'sleep', '0n', :inlinable(1));
 
2513
QAST::Operations.add_core_pirop_mapping('shell', 'nqp_shell', 'IssP');
 
2514
QAST::Operations.add_core_pirop_mapping('getenvhash', 'nqp_getenvhash', 'P');
 
2515
 
 
2516
QAST::Operations.add_core_op('getpid', -> $qastcomp, $op {
 
2517
    if +@($op) != 0 {
 
2518
        nqp::die('getpid requires no operands');
 
2519
    }
 
2520
    $qastcomp.as_post(QAST::Op.new(
 
2521
        :op('callmethod'), :name('getpid'), :returns(int),
 
2522
        QAST::VM.new( :pirop('getinterp__P') )
 
2523
    ))
 
2524
});