Implement setdispatcher/takedispatcher on JVM.

Raku · Apr 27, 2013 · 9d9a2af · 9d9a2af
1 parent e610165
commit 9d9a2af
Show file tree

Hide file tree

Showing 3 changed files with 45 additions and 0 deletions.
diff --git a/src/vm/jvm/QAST/Compiler.nqp b/src/vm/jvm/QAST/Compiler.nqp
@@ -301,6 +301,12 @@ class QAST::OperationsJAST {
     method unbox($qastcomp, $hll, $type) {
         (%hll_unbox{$hll} // %hll_unbox{''}){$type}($qastcomp)
     }
+
+    # Builds a result; helper method for extensions to the ops from outside
+    # of this file.
+    method result($jast, int $type) {
+        result($jast, $type)
+    }
 }
 
 # Set of sequential statements
@@ -1916,6 +1922,35 @@ QAST::OperationsJAST.map_classlib_core_op('freshcoderef', $TYPE_OPS, 'freshcoder
 QAST::OperationsJAST.map_classlib_core_op('markcodestatic', $TYPE_OPS, 'markcodestatic', [$RT_OBJ], $RT_OBJ, :tc);
 QAST::OperationsJAST.map_classlib_core_op('markcodestub', $TYPE_OPS, 'markcodestub', [$RT_OBJ], $RT_OBJ, :tc);
 QAST::OperationsJAST.map_classlib_core_op('getstaticcode', $TYPE_OPS, 'getstaticcode', [$RT_OBJ], $RT_OBJ, :tc);
+QAST::OperationsJAST.add_core_op('setdispatcher', -> $qastcomp, $op {
+    if +@($op) != 1 {
+        nqp::die('setdispatcher requires one operand');
+    }
+    my $il := JAST::InstructionList.new();
+    my $dispres := $qastcomp.as_jast($op[0], :want($RT_OBJ));
+    $il.append($dispres.jast);
+    $*STACK.obtain($il, $dispres);
+    $il.append(JAST::Instruction.new( :op('dup') ));
+    $il.append(JAST::Instruction.new( :op('aload_1') ));
+    $il.append(JAST::Instruction.new( :op('swap') ));
+    $il.append(JAST::Instruction.new( :op('putfield'), $TYPE_TC, 'currentDispatcher', $TYPE_SMO ));
+    result($il, $RT_OBJ);
+});
+QAST::OperationsJAST.add_core_op('takedispatcher', -> $qastcomp, $op {
+    if +@($op) != 1 || !nqp::istype($op[0], QAST::SVal) {
+        nqp::die('takedispatcher requires one string literal operand');
+    }
+    my $idx := $*BLOCK.lexical_type($op[0].value);
+    unless nqp::defined($idx) {
+        nqp::die('takedispatcher used with non-existing lexical');
+    }
+    my $il := JAST::InstructionList.new();
+    $il.append(JAST::PushIndex.new( :value($idx) ));
+    $il.append(JAST::Instruction.new( :op('aload_1') ));
+    $il.append(JAST::Instruction.new( :op('invokestatic'),
+        $TYPE_OPS, 'takedispatcher', 'V', 'I', $TYPE_TC ));
+    result($il, $RT_VOID);
+});
 
 # language/compiler ops
 QAST::OperationsJAST.map_classlib_core_op('getcomp', $TYPE_OPS, 'getcomp', [$RT_STR], $RT_OBJ, :tc);

diff --git a/src/vm/jvm/runtime/org/perl6/nqp/runtime/Ops.java b/src/vm/jvm/runtime/org/perl6/nqp/runtime/Ops.java
@@ -2710,6 +2710,10 @@ public static SixModelObject getstaticcode(SixModelObject code, ThreadContext tc
         else
             throw ExceptionHandling.dieInternal(tc, "getstaticcode can only be used with a CodeRef");
     }
+    public static void takedispatcher(int lexIdx, ThreadContext tc) {
+        tc.curFrame.oLex[lexIdx] = tc.currentDispatcher;
+        tc.currentDispatcher = null;
+    }
 
     /* process related opcodes */
     public static long exit(final long status) {

diff --git a/src/vm/jvm/runtime/org/perl6/nqp/runtime/ThreadContext.java b/src/vm/jvm/runtime/org/perl6/nqp/runtime/ThreadContext.java
@@ -4,6 +4,7 @@
 
 import org.perl6.nqp.sixmodel.reprs.CallCaptureInstance;
 import org.perl6.nqp.sixmodel.reprs.SCRefInstance;
+import org.perl6.nqp.sixmodel.SixModelObject;
 
 /**
  * State of a currently running thread.
@@ -70,6 +71,11 @@ public class ThreadContext {
      */
     public CallCaptureInstance savedCC;
 
+    /**
+     * The currently set dispatcher, for the next interested call to take.
+     */
+    public SixModelObject currentDispatcher;
+
     /**
      * Serialization context write barrier disabled depth (anything non-zero
      * means disabled).