;;;The traditional merge algorithm can be implemented thus:

(define (merge! l1 l2 predicate)
  (define (merge-loop l1 l2 last)
    (cond ((null? l1) (set-cdr! last l2))
          ((null? l2) (set-cdr! last l1))
          ((predicate (car l1) (car l2)) (set-cdr! last l1)
           (merge-loop (cdr l1) l2 l1))
          (else (set-cdr! last l2)
                (merge-loop l1 (cdr l2) l2))))
  (cond ((null? l1) l2) ;we do not need NULL tests for sorting
        ((null? l2) l1)
        ((predicate (car l1) (car l2))
         (merge-loop (cdr l1) l2 l1) l1)
        (else (merge-loop l1 (cdr l2) l2) l2)))

(define merge1!
  (let ((result (list '())))
    (lambda (l1 l2 predicate)
      (let loop ((l1 l1) (l2 l2) (last result))
        (cond ((null? l1) (set-cdr! last l2) (cdr result))
              ((null? l2) (set-cdr! last l1) (cdr result))
              ((predicate (car l1) (car l2)) (set-cdr! last l1)
               (loop (cdr l1) l2 l1))
              (else (set-cdr! last l2) (loop l1 (cdr l2) l2)))))))

;;; It can be seen that one of NULL? tests in MERGE-LOOP is unneeded.
;;; Only the list which was advanced during previous iteration can be
;;; empty. And we can keep this information around by putting the one
;;; which advanced as a first argument to the tail-recursive process
;;; which does the merging. That immediately allows us to reduce the
;;; number of pointer manipulations by a factor of two, since we need
;;; to do SET-CDR! only when the previous winner loses. All that
;;; allows us to come up with:

(define (unstable-merge! l1 l2 predicate)
  (define (merge-loop i j)
    (let ((k (cdr i)))
      (cond ((null? k) (set-cdr! i j))
            ((predicate (car k) (car j)) (merge-loop k j))
            (else (set-cdr! i j) (merge-loop j k)))))
  (cond ((null? l1) l2)
        ((null? l2) l1)
        ((predicate (car l1) (car l2))
         (merge-loop l1 l2) l1)
        (else (merge-loop l2 l1) l2)))


(define (make-mergesort! merge!)
  (lambda (l predicate)
    (parallel-reduce!
      (lambda (x y) (merge! x y predicate))
      (map! list l))))

(define mergesort! (make-mergesort! merge!))

(define new! (make-mergesort! merge1!))

;;; and unstable-merge! makes it about 10% faster

(define unstable-mergesort! (make-mergesort! unstable-merge!))


;;;; hand-optimization of unstable-mergesort! gives us

(define (merge-sort! x predicate)
  (define (merge i j)
    (let ((k (cdr i)))
      (cond ((null? k) (set-cdr! i j))
            ((predicate (car k) (car j)) (merge k j))
            (else (set-cdr! i j) (merge j k)))))
  (do ((l x (cdr l)))
      ((null? l))
      (set-car! l (list (car l))))
  (do ()
      ((null? (cdr x)) (car x))
      (do ((l x (cdr l)))
          ((null? (cdr l)))
          (let ((i (car l))
                (j (cadr l)))
            (cond ((predicate (car i) (car j)) (merge i j))
                  (else (set-car! l j) (merge j i))))
          (set-cdr! l (cddr l)))))

(define adder-merge-sort!
  (lambda (l predicate)
    (define function (lambda (x y) (merge! y x predicate)))
    (define register (list '()))
    (for-each-cons!
      (lambda (x)
        (set-cdr! x '())
        (put-in-adder! x register function '()))
      l)
    (reduce function register)))

(define v-adder-merge-sort!
  (let ((register (make-vector 32)))
    (lambda (l predicate)
      (define function (lambda (x y) (merge! y x predicate)))
      (vector-fill! register '())
      (for-each-cons!
        (lambda (x)
          (set-cdr! x '())
          (v-put-in-adder! x register function '()))
        l)
      (v-reduce function register))))