loop-merge-sort.scm

(define (position-of-highest-bit-32 n)
  (let ((m n) (v 0))
    (set! m (ash n -16))
    (if (not (= m 0))
      (begin (set! v (+ v 16))
             (set! n m)))
    (set! m (ash n -8))
    (if (not (= m 0))
      (begin (set! v (+ v 8))
             (set! n m)))
    (set! m (ash n -4))
    (if (not (= m 0))
      (begin (set! v (+ v 4))
             (set! n m)))
    (set! m (ash n -2))
    (if (not (= m 0))
      (begin (set! v (+ v 2))
             (set! n m)))
    (set! m (ash n -1))
    (if (not (= m 0))
      (begin (set! v (+ v 1))
             (set! n m)))
    (+ v n)))

(define (loop-merge-sort zs cmpfn)
  (let* ((len (length zs))
         (xs-len (quotient len 2))
         (ys-len (- len xs-len))
         (xs-pair (adjust-copy zs xs-len #t (= xs-len ys-len) cmpfn))
         (xs (car xs-pair))
         (ys (car (adjust-copy (cdr xs-pair) ys-len #f (= xs-len ys-len) cmpfn)))
         (dest (make-list len))
         (result-pair (loop-merge-sort-run! xs ys xs-len ys-len cmpfn)))
    (merge! dest (car result-pair) xs-len (cdr result-pair) ys-len cmpfn)
    dest))

(define (loop-merge-sort-run! xs ys xs-len ys-len cmpfn)
  (let* ((new-xs (make-list xs-len))
         (new-ys (make-list ys-len))
         (is-even (= xs-len ys-len))
         (init-chunk-num-bits (- (position-of-highest-bit-32 ys-len) 1))
         (init-chunk-num (ash 1 init-chunk-num-bits)))
    (loop-merge-sort-do! xs ys new-xs new-ys init-chunk-num init-chunk-num-bits 1 (- ys-len init-chunk-num) is-even cmpfn)))

(define (loop-merge-sort-do! xs ys new-xs new-ys chunk-num chunk-num-bits chunk-base-len mod-len is-even cmpfn)
  (if (> chunk-num 1)
    (begin
      (let inner-loop ((xs xs) (ys ys)
                       (new-xs new-xs) (new-ys new-ys)
                       (cnt 0))
        (if (< cnt chunk-num)
          (let* ((xs-pri (xs-priority cnt chunk-num-bits))
                 (ys-pri (ys-priority-from-xs xs-pri chunk-num-bits))
                 (xs-chunk-len (+ chunk-base-len (if (< xs-pri mod-len) 1 0) (if (and (= cnt 0) (not is-even)) -1 0)))
                 (ys-chunk-len (+ chunk-base-len (if (< ys-pri mod-len) 1 0))))
            (if (< cnt (ash chunk-num -1))
              (let ((merged (merge! new-xs xs xs-chunk-len ys ys-chunk-len cmpfn)))
                (inner-loop (cadr merged) (caddr merged) (car merged) new-ys (+ cnt 1)))
              (let ((merged (merge! new-ys xs xs-chunk-len ys ys-chunk-len cmpfn)))
                (inner-loop (cadr merged) (caddr merged) new-xs (car merged) (+ cnt 1)))))))
      (let* ((new-chunk-num (ash chunk-num -1))
             (new-chunk-num-bits (- chunk-num-bits 1))
             (is-mod-flowed (<= new-chunk-num mod-len))
             (new-chunk-base-len (+ (ash chunk-base-len 1) (if is-mod-flowed 1 0)))
             (new-mod-len (if is-mod-flowed (- mod-len new-chunk-num) mod-len)))
        (loop-merge-sort-do! new-xs new-ys xs ys new-chunk-num new-chunk-num-bits new-chunk-base-len new-mod-len is-even cmpfn)))
    (cons xs ys)))

(define (adjust-copy zs len is-to-xs is-even cmpfn)
  (let* ((dest (make-list len))
         (base-len (if (and is-to-xs (not is-even)) (+ len 1) len))
         (chunk-num-bits (- (position-of-highest-bit-32 base-len) 1))
         (chunk-num (ash 1 chunk-num-bits))
         (mod-len (- base-len chunk-num)))
    (cons dest
          (let loop ((dest dest) (zs zs) (cnt 0))
            (if (< cnt chunk-num)
              (let ((pri (if is-to-xs
                           (xs-priority cnt chunk-num-bits)
                           (ys-priority-from-xs (xs-priority cnt chunk-num-bits) chunk-num-bits))))
                (cond ((and (< pri mod-len) (not (and is-to-xs (not is-even) (= cnt 0))))
                        (if (cmpfn (cadr zs) (car zs))
                          (begin (set! (car dest) (cadr zs))
                                 (set! (cadr dest) (car zs))
                                 (loop (cddr dest) (cddr zs) (+ cnt 1)))
                          (begin (set! (car dest) (car zs))
                                 (set! (cadr dest) (cadr zs))
                                 (loop (cddr dest) (cddr zs) (+ cnt 1)))))
                      ((or (< pri mod-len) (not (and is-to-xs (not is-even) (= cnt 0))))
                        (begin (set! (car dest) (car zs))
                               (loop (cdr dest) (cdr zs) (+ cnt 1))))
                      (else (loop dest zs (+ cnt 1)))))
              zs)))))

(define (xs-priority n bits)
  (logxor n (ash n -1)))

(define (ys-priority-from-xs pri bits)
  (logxor pri (ash 1 (- bits 1))))

(define (merge! dest xs xs-len ys ys-len cmpfn)
  (let loop ((dest dest)
             (xs xs) (x-idx 0)
             (ys ys) (y-idx 0))
    (if (or (< x-idx xs-len) (< y-idx ys-len))
      (let ((is-y-precede
              (if (and (< x-idx xs-len) (< y-idx ys-len))
                (cmpfn (car ys) (car xs))
                (= x-idx xs-len))))
        (if is-y-precede
          (begin (set-car! dest (car ys))
                 (loop (cdr dest) xs x-idx (cdr ys) (+ y-idx 1)))
          (begin (set-car! dest (car xs))
                 (loop (cdr dest) (cdr xs) (+ x-idx 1) ys y-idx))))
      (list dest xs ys))))

(display (loop-merge-sort '(8457 894375 9347 983 9834 1 59 6789 87 98790 8979 89 53297 3984 9384  9324 10000 54783 9834 105) <))

1つ目のがやや無駄なことをしている版、
3つ目のが簡略された改良版
2つ目はミス