trying to fix benchmark for list-length, which is failing badly

compiler/compiler.rkt

@@ -525,13 +525,13 @@
 (: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
 ;; Compiles a conditional branch.
 (define (compile-branch exp cenv target linkage)
-  (let: ([f-branch : Symbol (make-label 'falseBranch)]
+  (let: ([f-branch: : Symbol (make-label 'falseBranch)]
-         [after-if : Symbol (make-label 'afterIf)])
+         [after-if: : Symbol (make-label 'afterIf)])
     (let ([consequent-linkage
            (cond
              [(NextLinkage? linkage)
               (let ([context (NextLinkage-context linkage)])
-                (make-LabelLinkage after-if context))]
+                (make-LabelLinkage after-if: context))]
              [(ReturnLinkage? linkage)
               linkage]
              [(LabelLinkage? linkage)
@@ -542,11 +542,12 @@
         (append-instruction-sequences 
          p-code
          (make-TestAndJumpStatement (make-TestFalse (make-Reg 'val))
-                                    f-branch)
+                                    f-branch:)
          c-code
-         f-branch
+         f-branch: a-code
-         a-code
+         (if (NextLinkage? linkage)
-         after-if)))))
+             after-if:
+             empty-instruction-sequence))))))
 
 
 (: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))

examples/list-length.rkt

@@ -0,0 +1,11 @@
+#lang planet dyoo/whalesong
+
+(define (mylen x)
+  (cond
+    [(empty? x)
+     0]
+    [else
+     (add1 (mylen (rest x)))]))
+"computing length"
+(mylen (build-list 100000 (lambda (i) i)))
+"done computing length"

js-assembler/assemble-helpers.rkt

@@ -30,7 +30,8 @@
 	 assemble-location
          assemble-numeric-constant
 
-         block-looks-like-context-expected-values?)
+         block-looks-like-context-expected-values?
+         block-looks-like-pop-multiple-values-and-continue?)
 
 (require/typed typed/racket/base
                [regexp-split (Regexp String -> (Listof String))])
@@ -429,6 +430,13 @@
      #f]))
 
 
+(: block-looks-like-pop-multiple-values-and-continue? (BasicBlock -> (U False)))
+(define (block-looks-like-pop-multiple-values-and-continue? a-block)
+  ;; FIXME!
+  #f)
+
+
+
 
 
 

js-assembler/assemble.rkt

@@ -208,6 +208,13 @@ EOF
                  (munge-label-name (make-Label (BasicBlock-name a-basic-block)))
                  expected)
         'ok]))]
+
+   [(block-looks-like-pop-multiple-values-and-continue? a-basic-block)
+    =>
+    (lambda (target)
+      (fprintf op "~a=RT.si_pop_multiple-values-and-continue(~a);"
+               (munge-label-name (make-Label (BasicBlock-name a-basic-block)))
+               target))]
    [else
     (default-assemble-basic-block a-basic-block blockht entry-points function-entry-and-exit-names op)]))
 

js-assembler/runtime-src/baselib-lists.js

@@ -263,10 +263,16 @@
     var isList = function (x) {
         var tortoise, hare;
         tortoise = hare = x;
-        if (hare === EMPTY) { return true; }
+        if (hare === EMPTY) { 
+            tortoise._isList = true;
+            return true; 
+        }
         while (true) {
             if (!(hare instanceof Cons)) { return false; }
-            if (tortoise instanceof Cons) { tortoise = tortoise.rest; }
+            if (tortoise instanceof Cons) { 
+                if (tortoise._isList === true) { return true; }
+                tortoise = tortoise.rest; 
+            }
             hare = hare.rest;
             if (hare instanceof Cons) { hare = hare.rest; }
             if (hare === EMPTY) { return true; }

js-assembler/runtime-src/runtime.js

@@ -790,10 +790,16 @@
     };
     var si_context_expected_1 = function(M) { raiseContextExpectedValuesError(M, 1); }
 
-
+    // A block that omits the multiple values returned on the stack and
-
+    // continues on with the target function f.
-
+    var si_pop_multiple_values_and_continue = function(target) {
-
+        var f = function(M) {
+            if(--M.cbt<0) { throw f; }
+            M.e.length -= (M.a-1);
+            return target(M);
+        };
+        return f;
+    };
 
 
 

version.rkt

@@ -7,4 +7,4 @@
 (provide version)
 (: version String)
 
-(define version "1.113")
+(define version "1.114")