From c68eeb97caa14db099024d133b484df9c35aaaf0 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 23 Nov 2009 18:48:06 +0000
Subject: [PATCH] Further optimizations to `merge'.

svn: r17003
---
 collects/scheme/private/sort.ss | 35 ++++++++++++++++++---------------
 1 file changed, 19 insertions(+), 16 deletions(-)

diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss
index 3f02404817..ef6efc0f6a 100644
--- a/collects/scheme/private/sort.ss
+++ b/collects/scheme/private/sort.ss
@@ -33,7 +33,7 @@ doing these checks.
      (define-syntax foo (syntax-rules () [(_ . pattern) template]))]))
 
 (define-syntax-rule (sort-internal-body v *<? n has-getkey? getkey)
-  (begin
+  (let ([n/2 (ceiling (/ n 2))])
     (define-syntax-rule (<? x y)
       (if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y)))
     (define-syntax-rule (ref n) (vector-ref v n))
@@ -42,16 +42,22 @@ doing these checks.
     (define-syntax-rule (merge lo? A1 A2 B1 B2 C1 C2)
       (let ([b2 B2])
         (let loop ([a1 A1] [b1 B1] [c1 C1])
-          (if (<= b2 b1)
-            (let loop ([a1 a1] [c1 c1])
-              (when (< c1 b1) (set! c1 (ref a1)) (loop (add1 a1) (add1 c1))))
-            (when (< c1 b1)
-              (let ([x (ref a1)] [y (ref b1)])
-                (if (if lo? (not (<? y x)) (<? x y))
-                  (begin (set! c1 x) (loop (add1 a1) b1 (add1 c1)))
-                  (begin (set! c1 y) (loop a1 (add1 b1) (add1 c1))))))))))
+          (let ([x (ref a1)] [y (ref b1)])
+            (if (if lo? (not (<? y x)) (<? x y))
+              (begin (set! c1 x)
+                     (let ([a1 (add1 a1)] [c1 (add1 c1)])
+                       (when (< c1 b1) (loop a1 b1 c1))))
+              (begin (set! c1 y)
+                     (let ([b1 (add1 b1)] [c1 (add1 c1)])
+                       (if (<= b2 b1)
+                         (let loop ([a1 a1] [c1 c1])
+                           (when (< c1 b1)
+                             (set! c1 (ref a1))
+                             (loop (add1 a1) (add1 c1))))
+                         (loop a1 b1 c1)))))))))
 
     (define (copying-mergesort Alo Ahi Blo Bhi)
+      (unless (= (- Ahi Alo) (- Bhi Blo)) (error "poof!!!"))
       (cond [(< Alo (sub1 Ahi))
              (let ([Amid (/ (+ Alo Ahi) 2)] [Bmid (/ (+ Blo Bhi) 2)])
                (copying-mergesort Amid Ahi Bmid Bhi)
@@ -60,13 +66,10 @@ doing these checks.
             [(= Alo (sub1 Ahi))
              (set! Blo (ref Alo))]))
 
-    (define-syntax-rule (mergesort Alo Ahi B1lo B1hi)
-      (let ([Amid (/ (+ Alo Ahi) 2)])
-        (copying-mergesort Amid Ahi B1lo B1hi)
-        (copying-mergesort Alo Amid Amid Ahi)
-        (merge #f B1lo B1hi Amid Ahi Alo Ahi)))
-
-    (mergesort 0 n n (+ n (/ n 2)))))
+    (let ([Alo 0] [Amid n/2] [Ahi n] [B1lo n] [B1hi (+ n n/2)])
+      (copying-mergesort Amid Ahi B1lo B1hi)
+      (copying-mergesort Alo Amid Amid Ahi)
+      (merge #f B1lo B1hi Amid Ahi Alo Ahi))))
 
 (define sort-internals (make-hasheq))
 (define _