From 6d035504af97901d0460e32b76c2b6fe407124fb Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Fri, 10 Feb 2012 13:27:26 -0500
Subject: [PATCH] trying to fix benchmark for list-length, which is failing
 badly

---
 compiler/compiler.rkt                     | 15 ++++++++-------
 examples/list-length.rkt                  | 11 +++++++++++
 js-assembler/assemble-helpers.rkt         | 10 +++++++++-
 js-assembler/assemble.rkt                 |  7 +++++++
 js-assembler/runtime-src/baselib-lists.js | 10 ++++++++--
 js-assembler/runtime-src/runtime.js       | 14 ++++++++++----
 version.rkt                               |  2 +-
 7 files changed, 54 insertions(+), 15 deletions(-)
 create mode 100644 examples/list-length.rkt

diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt
index 8cc49cef..e861aff6 100644
--- a/compiler/compiler.rkt
+++ b/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)]
-         [after-if : Symbol (make-label 'afterIf)])
+  (let: ([f-branch: : Symbol (make-label 'falseBranch)]
+         [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
-         a-code
-         after-if)))))
+         f-branch: a-code
+         (if (NextLinkage? linkage)
+             after-if:
+             empty-instruction-sequence))))))
 
 
 (: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))
diff --git a/examples/list-length.rkt b/examples/list-length.rkt
new file mode 100644
index 00000000..81e70443
--- /dev/null
+++ b/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"
\ No newline at end of file
diff --git a/js-assembler/assemble-helpers.rkt b/js-assembler/assemble-helpers.rkt
index b99db972..80b1244a 100644
--- a/js-assembler/assemble-helpers.rkt
+++ b/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)
+
+
+
 
 
 
diff --git a/js-assembler/assemble.rkt b/js-assembler/assemble.rkt
index 6f208fb3..20967281 100644
--- a/js-assembler/assemble.rkt
+++ b/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)]))
 
diff --git a/js-assembler/runtime-src/baselib-lists.js b/js-assembler/runtime-src/baselib-lists.js
index 1987b191..b003bf66 100644
--- a/js-assembler/runtime-src/baselib-lists.js
+++ b/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; }
diff --git a/js-assembler/runtime-src/runtime.js b/js-assembler/runtime-src/runtime.js
index 8da5eaaf..655255ac 100644
--- a/js-assembler/runtime-src/runtime.js
+++ b/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;
+    };
 
 
 
diff --git a/version.rkt b/version.rkt
index c4da15ef..6011f472 100644
--- a/version.rkt
+++ b/version.rkt
@@ -7,4 +7,4 @@
 (provide version)
 (: version String)
 
-(define version "1.113")
+(define version "1.114")