Wrap subs in a NQPRoutine code object when NQPRoutine is in scope.

We need capturelex to get that to work properly.
I's a port of p6capturelex that takes the code objects type as an argument rather than assuming it's a Rakudo Code.
We also add a test that ensures subs are wrapped in codeobjects.

src/NQP/Actions.nqp

@@ -790,6 +790,35 @@ class NQP::Actions is HLL::Actions {
     method routine_declarator:sym<sub>($/) { make $<routine_def>.ast; }
     method routine_declarator:sym<method>($/) { make $<method_def>.ast; }
 
+    # returns a QAST node to create the code object or 0 if not possible
+    method wrap_sub_in_code_object($block,$name) {
+        my $BLOCK := $*W.cur_lexpad();
+
+        my $code_type_name := 'NQPRoutine';
+        my $have_code_type;
+        my $code_type;
+        try {
+            $code_type := $*W.find_sym([$code_type_name]);
+            $have_code_type := $*PACKAGE.HOW.name($*PACKAGE) ne $code_type_name;
+        }
+
+        if $have_code_type {
+            my $code_object := $*W.create_code($block, $name, 0);
+
+            my $node := QAST::Op.new(:op('capturelex'),
+                QAST::Op.new(
+                    :op('callmethod'), :name('clone'),
+                    QAST::WVal.new( :value($code_object))),
+                QAST::WVal.new( :value($code_type)));
+
+            $node<block_past> := $block;
+            $node<code_object> := $code_object; # so that we can avoid a clone if don't need it
+            $node;
+        } else {
+            0;
+        }
+    }
+
     method routine_def($/) {
         # If it's just got * as a body, make a multi-dispatch enterer.
         # Otherwise, need to build a sub.
@@ -806,6 +835,8 @@ class NQP::Actions is HLL::Actions {
         }
         my $block := $past;
 
+        my $lexpast := nqp::null();
+
         if $<deflongname> {
             my $name := ~$<sigil>[0] ~ $<deflongname>[0].ast;
             $past.name($name);
@@ -883,12 +914,25 @@ class NQP::Actions is HLL::Actions {
                 }
                 else {
                     my $BLOCK := $*W.cur_lexpad();
-					$BLOCK[0].push(QAST::Op.new(
-                        :op('bind'),
-                        QAST::Var.new( :name('&' ~ $name), :scope('lexical'), :decl('var') ),
-                        $past
-                    ));
+
+                    if self.wrap_sub_in_code_object($past,$name) -> $node {
+                        $BLOCK[0].push(QAST::Op.new(
+                            :op('bind'),
+                            QAST::Var.new( :name('&' ~ $name), :scope('lexical'), :decl('var') ),
+                            QAST::WVal.new( :value($node<code_object>) )
+                        ));
+                        $BLOCK[0].push($past);
+                        $lexpast := $node;
+                    } else {
+                        $BLOCK[0].push(QAST::Op.new(
+                            :op('bind'),
+                            QAST::Var.new( :name('&' ~ $name), :scope('lexical'), :decl('var') ),
+                            $past
+                        ));
+                    }
+
                     $BLOCK.symbol('&' ~ $name, :scope('lexical'));
+
                     if $*SCOPE eq 'our' {
                         # Need to install it at loadinit time but also re-bind
                         # it per invocation.
@@ -916,14 +960,20 @@ class NQP::Actions is HLL::Actions {
             }
         }
         else {            
-            if $*W.is_precompilation_mode() {
+            if self.wrap_sub_in_code_object($past,'<anon>') -> $node {
+                my $BLOCK := $*W.cur_lexpad();
+                $BLOCK[0].push($past);
+                $lexpast := $node;
+            } elsif $*W.is_precompilation_mode() {
                 $*W.create_code($past, '<anon>', 0)
             }
         }
 
-        my $lexpast := QAST::Op.new( :op('takeclosure'), $past );
-        $lexpast<sink> := $past;
-        $lexpast<block_past> := $block;
+        if nqp::isnull($lexpast) {
+            $lexpast := QAST::Op.new( :op('takeclosure'), $past );
+            $lexpast<sink> := $past;
+            $lexpast<block_past> := $block;
+        }
         make $lexpast;
 
         # Apply traits.        

src/NQP/World.nqp

@@ -270,7 +270,13 @@ class NQP::World is HLL::World {
         }
         else {
             # Create a fresh stub code, and set its name.
-            $dummy := nqp::freshcoderef($stub_code);
+
+            if nqp::istype($stub_code,NQPRoutine) {
+                $dummy := $stub_code.freshcoderef();
+            } else { # old nqp versions
+                $dummy := nqp::freshcoderef($stub_code);
+            }
+
             nqp::setcodename($dummy, $name);
 
             # Tag it as a static code ref and add it to the root code refs set.

src/core/NQPRoutine.nqp

@@ -350,6 +350,11 @@ my knowhow NQPRoutine {
     }
 
     method signature() { $!signature }
+
+    method freshcoderef() {
+        nqp::freshcoderef($!do);
+    }
+
 }
 nqp::setinvokespec(NQPRoutine, NQPRoutine, '$!do', nqp::null);
 nqp::setboolspec(NQPRoutine, 5, nqp::null());

src/vm/jvm/QAST/Compiler.nqp

@@ -2209,6 +2209,7 @@ QAST::OperationsJAST.map_classlib_core_op('objprimspec', $TYPE_OPS, 'objprimspec
 QAST::OperationsJAST.map_classlib_core_op('isinvokable', $TYPE_OPS, 'isinvokable', [$RT_OBJ], $RT_INT, :tc);
 QAST::OperationsJAST.map_classlib_core_op('setinvokespec', $TYPE_OPS, 'setinvokespec', [$RT_OBJ, $RT_OBJ, $RT_STR, $RT_OBJ], $RT_OBJ, :tc);
 })();
+QAST::OperationsJAST.map_classlib_core_op('capturelex', $TYPE_OPS, 'capturelex', [$RT_OBJ,$RT_OBJ], $RT_OBJ, :tc);
 
 # defined - overridden by HLL, but by default same as .DEFINITE.
 QAST::OperationsJAST.map_classlib_core_op('defined', $TYPE_OPS, 'isconcrete', [$RT_OBJ], $RT_INT, :tc);

src/vm/jvm/runtime/org/perl6/nqp/runtime/Ops.java

@@ -4617,6 +4617,15 @@ public static long usecompilerhllconfig(ThreadContext tc) {
         return 1;
     }
 
+
+    public static SixModelObject capturelex(SixModelObject codeObj,SixModelObject classHandle, ThreadContext tc) {
+        CodeRef closure = (CodeRef)codeObj.get_attribute_boxed(tc,
+                classHandle, "$!do", STable.NO_HINT);
+        closure.outer = tc.curFrame;
+        return codeObj;
+    }
+
+
     private static MethodHandle reset_reenter;
     static {
         try {

src/vm/parrot/QAST/Operations.nqp

@@ -2125,6 +2125,7 @@ QAST::Operations.add_core_op('locallifetime', :inlinable(1), -> $qastcomp, $op {
 
 # code object related opcodes
 QAST::Operations.add_core_pirop_mapping('takeclosure', 'newclosure', 'PP');
+QAST::Operations.add_core_pirop_mapping('capturelex', 'nqp_capturelex', '0PP');
 QAST::Operations.add_core_pirop_mapping('getcodeobj', 'get_sub_code_object', 'PP');
 QAST::Operations.add_core_pirop_mapping('setcodeobj', 'set_sub_code_object', '1PP');
 QAST::Operations.add_core_pirop_mapping('getcodename', 'set', 'SP');
@@ -2307,3 +2308,4 @@ QAST::Operations.add_core_op('getpid', -> $qastcomp, $op {
         QAST::VM.new( :pirop('getinterp__P') )
     ))
 });
+

src/vm/parrot/ops/nqp.ops

@@ -3354,3 +3354,19 @@ inline op nqp_getlexrelcaller(out PMC, in PMC, in STR) :base_core {
     }
     $1 = result;
 }
+
+inline op nqp_capturelex(in PMC,in PMC) {
+    if ($1->vtable->base_type == smo_id) {
+        STRING  *attr_name = Parrot_str_new_constant(interp, "$!do");
+        PMC* code = REPR($1)->attr_funcs->get_attribute_boxed(interp, STABLE($1), OBJECT_BODY($1), $2, attr_name, NO_HINT);
+        if (PMC_IS_NULL(code)) {
+            Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+                "$!do is null");
+        }
+        Parrot_sub_capture_lex(interp, code);
+    }
+    else {
+        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
+            "Can only use perl6_capture_lex with a SixModelObject");
+    }
+}

t/nqp/68-subs-are-codeobjs.t

@@ -0,0 +1,11 @@
+plan(5);
+ok(nqp::istype(&say,NQPRoutine),"checking builtins, &say is a NQPRoutine");
+ok(nqp::istype(&ok,NQPRoutine),"checking builtins, &ok is a NQPRoutine");
+sub foo() {
+}
+ok(nqp::istype(&foo,NQPRoutine),"named sub is NQPRoutine");
+ok(nqp::istype(sub() {},NQPRoutine),"anoymous sub is NQPRoutine");
+my $foo := sub bar() {
+};
+ok(nqp::istype($foo,NQPRoutine),"binding a named sub to a value results in a NQPRoutine");
+

t/serialization/03-closures.t

@@ -45,12 +45,14 @@ sub add_to_sc($sc, $idx, $obj) {
 {
     my $sc := nqp::createsc('TEST_SC_2_IN');
     my $sh := nqp::list_s();
-    
-    my $raw_sub := nqp::getstaticcode(sub make_meth_with($x) {
+
+    my $sub := sub make_meth_with($x) {
         my $m := method () { $x };
         $m;
-    });
-
+    };
+
+    my $raw_sub := nqp::getstaticcode(nqp::getattr($sub, NQPRoutine, '$!do'));
+
     my $m1 := $raw_sub('dolphin');
     my $m2 := $raw_sub('whale');