Give PIRT::Sub support for loadlibs, name, subid and pirflags; also e…

…mit calls.
Raku · Jul 28, 2012 · e74e38c · e74e38c
1 parent 544a992
commit e74e38c
Show file tree

Hide file tree

Showing 2 changed files with 128 additions and 5 deletions.
diff --git a/src/QAST/PIRT.nqp b/src/QAST/PIRT.nqp
@@ -3,10 +3,27 @@
 # in QAST::Compiler. Since the mapping is pretty close, the nodes themselves
 # know how to become PIR.
 
+class PIRT::CallResult {
+    has str $!result;
+
+    method new(:$result!) {
+        my $obj := nqp::create(self);
+        nqp::bindattr_s($obj, PIRT::CallResult, '$!result',
+            $result ~~ PIRT::Node ?? $result.result !! $result);
+        $obj
+    }
+
+    method result() {
+        $!result
+    }
+}
+
 class PIRT::Node {
     my %op_compilers := nqp::hash(
         'call', sub (@args) {
-            nqp::die("NYI");
+            "    " ~
+                ($*HAS_RESULT ?? @args.shift() ~ " = " !! '') ~
+                @args.shift() ~ "(" ~ nqp::join(", ", @args) ~ ")"
         },
         'callmethod', sub (@args) {
             nqp::die("NYI");
@@ -33,16 +50,25 @@ class PIRT::Node {
                 my $i := 1;
                 my $c := nqp::elems($_);
                 my $arg;
+                my $*HAS_RESULT := 0;
+                my $result;
                 while $i < $c {
                     $arg := $_[$i];
                     if $arg ~~ PIRT::Node {
                         nqp::push(@op_args, $arg.result);
                     }
+                    elsif $arg ~~ PIRT::CallResult {
+                        $result := $arg.result;
+                        $*HAS_RESULT := 1;
+                    }
                     else {
                         nqp::push(@op_args, $arg);
                     }
                     $i := $i + 1;
                 }
+                if $*HAS_RESULT {
+                    nqp::unshift(@op_args, $result);
+                }
                 if nqp::existskey(%op_compilers, $op_name) {
                     nqp::push(@parts, %op_compilers{$op_name}(@op_args));
                 }
@@ -67,9 +93,23 @@ class PIRT::Node {
 
 class PIRT::Sub is PIRT::Node {
     has @!children;
+    has str $!subid;
+    has str $!pirflags;
+    has str $!name;
+    has @!loadlibs;
+
     has @!nested_blocks;
     has str $!cached_pir;
 
+    method escape($str) {
+        my $esc := pir::escape__Ss($str);
+        nqp::index($esc, '\x', 0) >= 0 ??
+            'utf8:"' ~ $esc ~ '"' !!
+                (nqp::index($esc, '\u', 0) >= 0 ??
+                 'unicode:"' ~ $esc ~ '"' !!
+                 '"' ~ $esc ~ '"')
+    }
+
     method new() {
         my $obj := nqp::create(self);
         nqp::bindattr($obj, PIRT::Sub, '@!children', nqp::list());
@@ -80,10 +120,29 @@ class PIRT::Sub is PIRT::Node {
         nqp::push(@!children, $node);
     }
 
-    method push_pirop(*@opbits) {
+    method push_pirop(*@opbits, :$result) {
+        if $result {
+            nqp::push(@opbits, PIRT::CallResult.new($result));
+        }
         nqp::push(@!children, @opbits)
     }
 
+    method subid(*@value) {
+        @value ?? ($!subid := @value[0]) !! $!subid
+    }
+
+    method pirflags(*@value) {
+        @value ?? ($!pirflags := @value[0]) !! $!pirflags
+    }
+
+    method name(*@value) {
+        @value ?? ($!name := @value[0]) !! $!name
+    }
+
+    method loadlibs(@libs?) {
+        @libs ?? (@!loadlibs := @libs) !! @!loadlibs
+    }
+
     method result() {
         nqp::die("Cannot use a PIRT::Sub in a context expecting a result");
     }
@@ -92,7 +151,17 @@ class PIRT::Sub is PIRT::Node {
         my @parts;
 
         # Sub prelude.
-        nqp::push(@parts, ".sub ''");
+        for @!loadlibs {
+            nqp::push(@parts, ".loadlib " ~ self.escape($_));
+        }
+        my $sub_decl := ".sub " ~ self.escape($!name || '');
+        if $!subid {
+            $sub_decl := $sub_decl ~ " :subid(" ~ self.escape($!subid) ~ ")";
+        }
+        if $!pirflags {
+            $sub_decl := $sub_decl ~ ' ' ~ $!pirflags
+        }
+        nqp::push(@parts, $sub_decl);
 
         # Compile sub contents, collecting any nested blocks.
         my @*PIRT_BLOCKS;
@@ -138,7 +207,10 @@ class PIRT::Ops is PIRT::Node {
         nqp::push(@!children, $node)
     }
 
-    method push_pirop(*@opbits) {
+    method push_pirop(*@opbits, :$result) {
+        if $result {
+            nqp::push(@opbits, PIRT::CallResult.new($result));
+        }
         nqp::push(@!children, @opbits)
     }
 

diff --git a/t/qast/pirt.t b/t/qast/pirt.t
@@ -1,6 +1,6 @@
 use QAST;
 
-plan(3);
+plan(5);
 
 sub is_pirt_result($producer, $expected, $desc) {
     my $pirt := $producer();
@@ -54,3 +54,54 @@ is_pirt_result({
     },
     "c'est l'awesome",
     "Basic use of labels");
+
+is_pirt_result({
+        # Create a nested sub.
+        my $n_ops := PIRT::Ops.new();
+        $n_ops.push_pirop('return', '"nested sub"');
+        my $n_sub := PIRT::Sub.new();
+        $n_sub.push($n_ops);
+        $n_sub.subid('n_sub');
+
+        # Create the outer sub that looks it up and calls it.
+        my $ops := PIRT::Ops.new();
+        $ops.push($n_sub);
+        $ops.push_pirop(".const 'Sub' \$P0 = 'n_sub'");
+        $ops.push_pirop('call', '$P0', :result('$S0'));
+        $ops.push_pirop('concat', '$S1', '$S0', '" outer sub"');
+        $ops.push_pirop('return', '$S1');
+        my $sub := PIRT::Sub.new();
+        $sub.push($ops);
+
+        $sub
+    },
+    "nested sub outer sub",
+    "Calling subs");
+
+is_pirt_result({
+        # Create a nested sub that looks up a lexical.
+        my $n_ops := PIRT::Ops.new();
+        $n_ops.push_pirop('find_lex', '$P0', '"$foo"');
+        $n_ops.push_pirop('return', '$P0');
+        my $n_sub := PIRT::Sub.new();
+        $n_sub.push($n_ops);
+        $n_sub.subid('n_sub');
+        $n_sub.pirflags(':outer("o_sub")');
+
+        # Create the outer sub that looks it up and calls it.
+        my $ops := PIRT::Ops.new();
+        $ops.push($n_sub);
+        $ops.push_pirop('box', '$P1', '"lexicals work!"');
+        $ops.push_pirop('.lex', '"$foo"', '$P1');
+        $ops.push_pirop(".const 'Sub' \$P0 = 'n_sub'");
+        $ops.push_pirop('capture_lex', '$P0');
+        $ops.push_pirop('call', '$P0', :result('$S0'));
+        $ops.push_pirop('return', '$S0');
+        my $sub := PIRT::Sub.new();
+        $sub.push($ops);
+        $sub.subid('o_sub');
+
+        $sub
+    },
+    'lexicals work!',
+    "pirflags emitted correctly");