Merge pull request #6 from thecabinet/master

cleanup of nqp::sha1; implement nqp::exit and nqp::sleep
jnthn · Jan 14, 2013 · e2419b4 · e2419b4
2 parents 901b289 + fa69397
commit e2419b4
Show file tree

Hide file tree

Showing 6 changed files with 156 additions and 24 deletions.
diff --git a/docs/LHF.md b/docs/LHF.md
@@ -32,10 +32,6 @@ Just add ops; they need to take the ThreadContext (use :tc in QASTCompilerJAST)
 and use the lexical name info as in the contextuals task (this may actually be
 a bit easier).
 
-## Process related opcodes
-Implement nqp::exit (takes integer exit code) and nqp::sleep (takes double
-number of seconds).
-
 ## Work out build stuff
 At the moment, there's nothing really set up for building the Java bit of
 the system. If you've got some ideas on how to sort something out here, go

diff --git a/lib/QAST/JASTCompiler.nqp b/lib/QAST/JASTCompiler.nqp
@@ -1068,6 +1068,8 @@ QAST::OperationsJAST.map_classlib_core_op('lc', $TYPE_OPS, 'lc', [$RT_STR], $RT_
 QAST::OperationsJAST.map_classlib_core_op('x', $TYPE_OPS, 'x', [$RT_STR, $RT_INT], $RT_STR);
 QAST::OperationsJAST.map_classlib_core_op('concat', $TYPE_OPS, 'concat', [$RT_STR, $RT_STR], $RT_STR);
 QAST::OperationsJAST.map_classlib_core_op('chr', $TYPE_OPS, 'chr', [$RT_INT], $RT_STR);
+
+# serialization context opcodes
 QAST::OperationsJAST.map_classlib_core_op('sha1', $TYPE_OPS, 'sha1', [$RT_STR], $RT_STR);
 
 #bitwise opcodes
@@ -1146,6 +1148,10 @@ QAST::OperationsJAST.map_classlib_core_op('takeclosure', $TYPE_OPS, 'takeclosure
 # language/compiler ops
 QAST::OperationsJAST.map_classlib_core_op('sethllconfig', $TYPE_OPS, 'sethllconfig', [$RT_STR, $RT_OBJ], $RT_OBJ, :tc);
 
+# process related opcodes
+QAST::OperationsJAST.map_classlib_core_op('exit', $TYPE_OPS, 'exit', [$RT_INT], $RT_INT);
+QAST::OperationsJAST.map_classlib_core_op('sleep', $TYPE_OPS, 'sleep', [$RT_NUM], $RT_NUM);
+
 class QAST::CompilerJAST {
     # Responsible for handling issues around code references, building the
     # switch statement dispatcher, etc.

diff --git a/src/org/perl6/nqp/runtime/Ops.java b/src/org/perl6/nqp/runtime/Ops.java
@@ -954,6 +954,7 @@ public static String chr(long val) {
         return (new StringBuffer()).append((char) val).toString();
     }
 
+    /* serialization context related opcodes */
     public static String sha1(String str) throws NoSuchAlgorithmException, UnsupportedEncodingException {
         MessageDigest md = MessageDigest.getInstance("SHA1");
 
@@ -1003,7 +1004,36 @@ public static SixModelObject takeclosure(SixModelObject code, ThreadContext tc)
             throw new RuntimeException("takeclosure can only be used with a CodeRef");
         }
     }
+
+    /* process related opcodes */
+    public static long exit(final long status) {
+        System.exit((int) status);
+        return status;
+    }
 
+    public static double sleep(final double seconds) {
+        // Is this really the right behavior, i.e., swallowing all
+        // InterruptedExceptions?  As far as I can tell the original
+        // nqp::sleep could not be interrupted, so that behavior is
+        // duplicated here, but that doesn't mean it's the right thing
+        // to do on the JVM...
+
+        long now = System.currentTimeMillis();
+
+        final long awake = now + (long) (seconds * 1000);
+
+        while ((now = System.currentTimeMillis()) < awake) {
+            long millis = awake - now;
+            try {
+                Thread.sleep(millis);
+            } catch(InterruptedException e) {
+                // swallow
+            }
+        }
+
+        return seconds;
+    }
+
     /* HLL configuration and compiler related options. */
     public static SixModelObject sethllconfig(String language, SixModelObject configHash, ThreadContext tc) {
         HLLConfig config = tc.gc.getHLLConfigFor(language);

diff --git a/t/qast_process.t b/t/qast_process.t
@@ -0,0 +1,97 @@
+use helper;
+
+plan(2);
+
+{
+    my $expected-exit := 123;
+
+    my $block := QAST::Block.new(
+        QAST::Op.new(
+            :op('exit'),
+            QAST::IVal.new( :value($expected-exit) )
+            ));
+    my $jast := QAST::CompilerJAST.jast(
+        QAST::CompUnit.new(
+            $block,
+            :main(QAST::Op.new(
+                :op('call'),
+                QAST::BVal.new( :value($block) )
+            )))
+        );
+    my $dump := $jast.dump();
+    spurt('QAST2JASTOutput.dump', $dump);
+    my $cps := is_windows() ?? ";" !! ":";
+    run('java',
+        '-cp bin' ~ $cps ~ '3rdparty/bcel/bcel-5.2.jar',
+        'org/perl6/nqp/jast2bc/JASTToJVMBytecode',
+        'QAST2JASTOutput.dump', 'QAST2JASTOutput.class');
+    run('java',
+        '-cp .' ~ $cps ~ 'bin' ~ $cps ~ '3rdparty/bcel/bcel-5.2.jar',
+        'QAST2JASTOutput');
+    my $output := pir::spawnw__Is('java -cp .' ~ $cps ~ 'bin' ~ $cps ~ '3rdparty/bcel/bcel-5.2.jar QAST2JASTOutput');
+    my $exit   := pir::shr__Iii($output, 8);
+
+    if $exit == $expected-exit {
+        ok(1, 'exit');
+    }
+    else {
+        ok(0, 'exit');
+        say("# got: exit $exit");
+        say("# expected: exit $expected-exit");
+    }
+    #unlink('QAST2JASTOutput.dump');
+    #unlink('QAST2JASTOutput.class');
+}
+
+{
+    sub timed_qast_test($sleep) {
+        my $block := QAST::Block.new(
+            QAST::Op.new(
+                :op('say'),
+                QAST::Op.new(
+                    :op('sleep'),
+                    QAST::NVal.new( :value($sleep) )
+                )));
+        my $jast := QAST::CompilerJAST.jast(
+            QAST::CompUnit.new(
+                $block,
+                :main(QAST::Op.new(
+                    :op('call'),
+                    QAST::BVal.new( :value($block) )
+                )))
+            );
+        my $dump := $jast.dump();
+        spurt('QAST2JASTOutput.dump', $dump);
+        my $cps := is_windows() ?? ";" !! ":";
+        run('java',
+            '-cp bin' ~ $cps ~ '3rdparty/bcel/bcel-5.2.jar',
+            'org/perl6/nqp/jast2bc/JASTToJVMBytecode',
+            'QAST2JASTOutput.dump', 'QAST2JASTOutput.class');
+        my $before := pir::time__N;
+        run('java',
+            '-cp .' ~ $cps ~ 'bin' ~ $cps ~ '3rdparty/bcel/bcel-5.2.jar',
+            'QAST2JASTOutput');
+        my $after := pir::time__N;
+        my $slept := $after - $before;
+
+        #unlink('QAST2JASTOutput.dump');
+        #unlink('QAST2JASTOutput.class');
+
+        return $slept;
+    }
+
+    my $quick := timed_qast_test(0.0);
+
+    my $sleep := 1.0 + $quick;
+    my $slow := timed_qast_test($sleep);
+
+    if ($slow >= $sleep) {
+        ok(1, 'sleep');
+    }
+    else {
+        ok(0, 'sleep');
+        say("# got: $slow");
+        say("# expected: $sleep");
+    }
+}
+
diff --git a/t/qast_serialization.t b/t/qast_serialization.t
@@ -0,0 +1,22 @@
+use helper;
+
+plan(1);
+
+qast_test(
+    -> {
+        my $block := QAST::Block.new(
+            QAST::Op.new(
+                :op('say'),
+                QAST::Op.new(
+                    :op('sha1'),
+                    QAST::SVal.new( :value("larva") )
+                )));
+        QAST::CompUnit.new(
+            $block,
+            :main(QAST::Op.new(
+                :op('call'),
+                QAST::BVal.new( :value($block) )
+            )))
+    },
+    "2DE6BA12D336DD56ABE5B163DDF836B951A2CA7C\n",
+    "sha1");
diff --git a/t/qast_string.t b/t/qast_string.t
@@ -1,6 +1,6 @@
 use helper;
 
-plan(7);
+plan(6);
 
 qast_test(
     -> {
@@ -117,22 +117,3 @@ qast_test(
     },
     "B\n",
     "chr");
-
-qast_test(
-    -> {
-        my $block := QAST::Block.new(
-            QAST::Op.new(
-                :op('say'),
-                QAST::Op.new(
-                    :op('sha1'),
-                    QAST::SVal.new( :value("larva") )
-                )));
-        QAST::CompUnit.new(
-            $block,
-            :main(QAST::Op.new(
-                :op('call'),
-                QAST::BVal.new( :value($block) )
-            )))
-    },
-    "2DE6BA12D336DD56ABE5B163DDF836B951A2CA7C\n",
-    "sha1");