Some thoughts about Emacs performance

[Robert Boyer <robertstephenboyer@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 1115 bytes --]

Emacs 27.1 has a 'sort' function that takes longer than stable-sort of
SBCL. Maybe
by a factor of 2. See also my attached file 'ms.lisp'.

There may be a lot that can be improved in Emacs'
handling of cl-loop, setf, elt, or cl-random.

;; First some Emacs, with times on my $100 Chromebook.

(setq n 6)
(defun make-random-array (n)
  (let ((a (make-vector n 0)))
    (cl-loop for i below n do
             (setf (elt a i) (cl-random 1000000)))
    a))
(byte-compile 'make-random-array)
(benchmark '(setq foo (make-random-array (expt 10 n))) 1) -- 2.3 seconds
(benchmark '(sort foo '<) 1) -- 1 second

;; Second some Common Lisp, with times for SBCL on my $100 Chromebook.

(defparameter n 6)
(defun make-random-array (n)
  (declare (fixnum n))
  (let ((a (make-array n)))
    (declare (type array a))
    (loop for i fixnum below n do
          (setf (aref a i) (random most-positive-fixnum)))
    a))
(time (defparameter foo (make-random-array (expt 10 n))))  -- .041 seconds
(time (progn (stable-sort foo '<) nil)) -- .45 seconds

Thanks so much for Emacs, which is so great that I cannot put it
into words.

Bob

[-- Attachment #1.2: Type: text/html, Size: 1735 bytes --]

[-- Attachment #2: ms.lisp --]
[-- Type: application/octet-stream, Size: 13979 bytes --]

; -*- coding: utf-8 -*-

;;; ms.lisp was coded by Robert S. Boyer, roberstephenboyer@gmail.com, in
;;; 2024. ms.lisp is public domain. It runs in SBCL.  The main function
;;; in ms.lisp is msa, which is simply good old merge sort.

;;; ms.lisp is
;;; https://drive.google.com/file/d/1OEYqc7wmGjUtj7Hhy_3QmOS23yJ4Izaf/view?usp=sharing

;;; Consider sorting an array of 10 million random rationals and floats.

;;; msa         takes 37.082  real seconds.
;;; stable-sort takes 69.321  real seconds.
;;; sort        takes 110.047 real seconds.

;;; The above three times were obtained using SBCL on my $100 Lenovo Chromebook.

;;; The following three times were obtained on an M3 machine by Grant Passmore.

;;; msa         takes 5.73    seconds.
;;; stable-sort takes 7.241   seconds.
;;; sort        takes 15.811  seconds.

;;; After (load "ms.lisp") one may run this form to confirm my timing results.

#|
(let* ((a (make-random-array-mixed (expt 10 7))) 
       (ac1 (copy-seq a))
       (ac2 (copy-seq a)))
  (gc :full t) 
  (format t "~%Timing msa.") 
  (time (msa a))
  (gc :full t)
  (format t "~%Timing stable-sort.") 
  (time (stable-sort ac1 '<))
  (gc :full t)
  (format t "~%Timing sort.") 
  (time (sort ac2 '<))
  (cond ((or (not (equalp a ac1)) (not (equalp a ac2)))
         (error "failed")))
  t)
|#

;;; I use --dynamic-space-size 32000 in my SBCL startup file.
;;; you can simply invoke
;;;   sbcl --dynamic-space-size 32000
;;; to start sbcl.

;;; (long-test-msa) will run tests of msa vs. stable-sort and sort on mixed,
;;; fixnum, and float random arrays of sizes starting at one million and
;;; going up by a million. I cannot get past 19 million on my Chromebook due
;;; to space problems.

;;; On arrays of mixed rationals and floats, msa does seem generally a good
;;; bit faster. On arrays that are all fixnums, msa is roughly as good as
;;; stable-sort. On arrays that are all floats, msa is about 25% worse than
;;; stable-sort, and I have no idea why.

(in-package "COMMON-LISP-USER")

(declaim (optimize (safety 0) (speed 3) (debug 0)))

(defun print-date-and-time ()
  (multiple-value-bind
   (second minute hour day month year day-of-week dst-p tz)
   (get-decoded-time)
   (declare (ignore dst-p tz))
   (format *standard-output*
           "~2,'0d:~2,'0d:~2,'0d, ~a, ~d/~2,'0d/~d~%"
           hour minute second
           (nth day-of-week '("Monday" "Tuesday" "Wednesday" "Thursday"
                              "Friday" "Saturday" "Sunday"))
           month day year)))

;;; We turn on reporting of garbage collection. The header asks Emacs to
;;; enter auto-revert-tail mode.

(let ((stream (open "gc-logfile.txt" :direction :output
                    :if-exists :supersede
                    :if-does-not-exist :create)))
  ;; (setf (gc-logfile) nil) turns gc reporting off.
  (format stream "-*- Mode: auto-revert-tail -*-~%")
  (let ((*standard-output* stream))
    (terpri)
    (print-date-and-time)
    (terpri))
  (close stream)
  (setf (gc-logfile) "gc-logfile.txt")
  (gc :full t))

(defparameter msa-input (make-array 1))

(defparameter msa-scratch (make-array 1))

(declaim (type simple-vector msa-input msa-scratch))

(deftype rational-or-float () '(or rational float))

(defmacro my-< (x y)
  (let ((gx (gensym)) (gy (gensym)))
    `(let ((,gx ,x) (,gy ,y))
       (cond ((and (typep ,gx 'fixnum) (typep ,gy 'fixnum))
              (< (the fixnum ,gx) (the fixnum ,gy)))
             ((and (typep ,gx 'float) (typep ,gy 'float))
              (< (the float ,gx) (the float ,gy)))
             (t (< ,gx ,gy))))))

(defun msa-1 (start end)
  (declare (fixnum start end))
  (let ((start+1 (the fixnum (1+ start)))
        (end-start (the fixnum (- end start))))
    (declare (fixnum start+1 end-start))
    (cond ((or (= start end) (= start+1 end)))
          ((= end-start 2)
           (let ((as-start (svref msa-input start))
                 (as-start+1 (svref msa-input start+1)))
             (declare (rational-or-float as-start as-start+1))
             (cond ((my-< as-start+1 as-start)
                    (setf (svref msa-input start) as-start+1)
                    (setf (svref msa-input start+1) as-start)))))
          (t (let ((mid (the fixnum (+ start (the fixnum (floor end-start 2))))))
               (declare (fixnum mid))
               (cond ((= start+1 mid))
                     (t (msa-1 start mid)))
               (msa-1 mid end)
               (let ((i0 start) (i1 mid) (end0 mid) (end1 end))
                 (declare (fixnum i0 i1 end0 end1))
                 (loop for si fixnum below end-start do
                       (cond ((= i0 end0)
                              (setf (svref msa-scratch si) (svref msa-input i1))
                              (incf i1))
                             ((= i1 end1)
                              (setf (svref msa-scratch si) (svref msa-input i0))
                              (incf i0))
                             ((my-< (the rational-or-float (svref msa-input i0))
                                    (the rational-or-float (svref msa-input i1)))
                              (setf (svref msa-scratch si) (svref msa-input i0))
                              (incf i0))
                             (t (setf (svref msa-scratch si) (svref msa-input i1))
                                (incf i1)))))
               (loop for i fixnum below end-start as j fixnum from start do
                     (setf (svref msa-input j) (svref msa-scratch i))))))
    nil))

(defun msa-1-fixnum (start end)
  (declare (fixnum start end))
  (let ((start+1 (the fixnum (1+ start)))
        (end-start (the fixnum (- end start))))
    (declare (fixnum start+1 end-start))
    (cond ((or (= start end) (= start+1 end)))
          ((= end-start 2)
           (let ((as-start (svref msa-input start))
                 (as-start+1 (svref msa-input start+1)))
             (declare (fixnum as-start as-start+1))
             (cond ((< as-start+1 as-start)
                    (setf (svref msa-input start) as-start+1)
                    (setf (svref msa-input start+1) as-start)))))
          (t (let ((mid (the fixnum (+ start (the fixnum (floor end-start 2))))))
               (declare (fixnum mid))
               (cond ((= start+1 mid))
                     (t (msa-1-fixnum start mid)))
               (msa-1-fixnum mid end)
               (let ((i0 start) (i1 mid) (end0 mid) (end1 end))
                 (declare (fixnum i0 i1 end0 end1))
                 (loop for si fixnum below end-start do
                       (cond ((= i0 end0)
                              (setf (svref msa-scratch si) (svref msa-input i1))
                              (incf i1))
                             ((= i1 end1)
                              (setf (svref msa-scratch si) (svref msa-input i0))
                              (incf i0))
                             ((< (the fixnum (svref msa-input i0))
                                 (the fixnum (svref msa-input i1)))
                              (setf (svref msa-scratch si) (svref msa-input i0))
                              (incf i0))
                             (t (setf (svref msa-scratch si) (svref msa-input i1))
                                (incf i1)))))
               (loop for i fixnum below end-start as j fixnum from start do
                     (setf (svref msa-input j) (svref msa-scratch i))))))
    nil))

(defun msa-1-float (start end)
  (declare (fixnum start end))
  (let ((start+1 (the fixnum (1+ start)))
        (end-start (the fixnum (- end start))))
    (declare (fixnum start+1 end-start))
    (cond ((or (= start end) (= start+1 end)))
          ((= end-start 2)
           (let ((as-start (svref msa-input start))
                 (as-start+1 (svref msa-input start+1)))
             (declare (float as-start as-start+1))
             (cond ((< as-start+1 as-start)
                    (setf (svref msa-input start) as-start+1)
                    (setf (svref msa-input start+1) as-start)))))
          (t (let ((mid (the fixnum (+ start (the fixnum (floor end-start 2))))))
               (declare (fixnum mid))
               (cond ((= start+1 mid))
                     (t (msa-1-float start mid)))
               (msa-1-float mid end)
               (let ((i0 start) (i1 mid) (end0 mid) (end1 end))
                 (declare (fixnum i0 i1 end0 end1))
                 (loop for si fixnum below end-start do
                       (cond ((= i0 end0)
                              (setf (svref msa-scratch si) (svref msa-input i1))
                              (incf i1))
                             ((= i1 end1)
                              (setf (svref msa-scratch si) (svref msa-input i0))
                              (incf i0))
                             ((< (the float (svref msa-input i0))
                                 (the float (svref msa-input i1)))
                              (setf (svref msa-scratch si) (svref msa-input i0))
                              (incf i0))
                             (t (setf (svref msa-scratch si) (svref msa-input i1))
                                (incf i1)))))
               (loop for i fixnum below end-start as j fixnum from start do
                     (setf (svref msa-input j) (svref msa-scratch i))))))
    nil))

(defun msa (ar)
  "(msa ar) takes a one dimensional array ar of rationals or floats,
   sorts ar by <, and returns ar. msa creates a scratch array the length of
   ar. If ar is not a simple-vector, then ar also creates another array the
   length of ar."
  (cond ((not (typep ar '(array t (*))))
         (error "msa input not an array of one dimension")))
  (let ((len (length ar)) (ar ar) (all-fixnum t) (all-float t))
    (declare (fixnum len) (type simple-vector ar))
    (loop for i fixnum below len do
          (let ((x (aref ar i)))
            (cond ((not (typep x 'rational-or-float))
                   (error "ar takes an array of rationals or floats."))
                  ((not (typep x 'fixnum)) (setq all-fixnum nil))
                  ((not (typep x 'float)) (setq all-float nil)))))
    (cond ((typep ar 'simple-vector)
           (setq msa-input ar))
          (t (setq msa-input (copy-seq msa-input))))
    (setq msa-scratch (make-array len))
    (cond (all-fixnum
           ;; (format t "~%msa-1-fixnum.")
           (msa-1-fixnum 0 len))
          (all-float
           ;; (format t "~%msa-1-float.")
           (msa-1-float 0 len))
          (t (msa-1 0 len)))
    (cond ((typep ar 'simple-vector))
          (t (loop for i below len do
                   (setf (aref ar i) (svref msa-input i)))))
    (setq msa-input (make-array 1))
    (setq msa-scratch (make-array 1))
    ;; (gc :full t)
    ar))

;;; The remainder of this file concerns testing.

(defparameter test-msa-ar1 (make-array 1))

(defparameter test-msa-ar2 (make-array 1))

(defun make-random-array-fixed (n)
  (declare (fixnum n))
  (let ((a (make-array n)))
    (declare (type (array t (*)) a))
    (loop for i fixnum below n do
          (setf (aref a i) (random most-positive-fixnum)))
    a))

(defun make-random-array-float (n)
  (declare (fixnum n))
  (let ((a (make-array n)))
    (declare (type (array t (*)) a))
    (loop for i fixnum below n do
          (setf (aref a i) (float (random most-positive-fixnum))))
    a))

(defun random-mixed ()
  (let* ((c (random 3))
         (x (* 2 most-positive-fixnum))
         (n (random x))
         (d (random x)))
    (cond ((= d 0) (setq d 1)))
    (cond ((= c 0) n)
          ((= c 1) (/ n d))
          ((= c 2) (float (/ n d))))))

(defun make-random-array-mixed (n)
  (declare (fixnum n))
  (let ((a (make-array n)))
    (declare (type (array t (*)) a))
    (loop for i fixnum below n do
          (setf (aref a i) (random-mixed)))
    a))

(defun test-msa-mixed (n)
  "(test-msa n) creates an array ar1 of n random rationals and floats,
   creates a copy ar2 of ar1, calls (msa ar1), calls (stable-sort ar2 '<),
   and returns (equalp ar1 ar2)."
  (declare (fixnum n))
  (format t "~%running (test-msa-mixed ~:d)." n)
  (setq test-msa-ar1 (make-random-array-mixed n))
  (setq test-msa-ar2 (copy-seq test-msa-ar1))
  (gc :full t)
  (format t "~%Timing of (msa test-msa-ar1).")
  (time (msa test-msa-ar1))
  (gc :full t)
  (format t "~%Timing of (stable-sort test-msa-ar2 '<).")
  (time (stable-sort test-msa-ar2 '<))
  (equalp test-msa-ar1 test-msa-ar2))

(defun test-msa-fixed (n)
  "(test-msa n) creates an array ar1 of n random fixnums,
   creates a copy ar2 of ar1, calls (msa ar1), calls (stable-sort ar2 '<),
   and returns (equalp ar1 ar2)."
  (declare (fixnum n))
  (format t "~%running (test-msa-fixed ~:d)." n)
  (setq test-msa-ar1 (make-random-array-fixed n))
  (setq test-msa-ar2 (copy-seq test-msa-ar1))
  (gc :full t)
  (format t "~%Timing of (msa test-msa-ar1).")
  (time (msa test-msa-ar1))
  (gc :full t)
  (format t "~%Timing of (stable-sort test-msa-ar2 '<).")
  (time (stable-sort test-msa-ar2 '<))
  (equalp test-msa-ar1 test-msa-ar2))

(defun test-msa-float (n)
  "(test-msa n) creates an array ar1 of n random floats, creates a copy ar2
   of ar1, calls (msa ar1), calls (stable-sort ar2 '<), and returns (equalp
   ar1 ar2)."
  (declare (fixnum n))
  (format t "~%running (test-msa-float ~:d)." n)
  (setq test-msa-ar1 (make-random-array-float n))
  (setq test-msa-ar2 (copy-seq test-msa-ar1))
  (gc :full t)
  (format t "~%Timing of (msa test-msa-ar1).")
  (time (msa test-msa-ar1))
  (gc :full t)
  (format t "~%Timing of (stable-sort test-msa-ar2 '<).")
  (time (stable-sort test-msa-ar2 '<))
  (equalp test-msa-ar1 test-msa-ar2))

(defun long-test-msa ()
  (loop for i from 1 do 
        (let ((n (* i (expt 10 6))))
          (cond ((not (test-msa-mixed n))
                 (error "long-test failed mixed at ~:d." n)))
          (cond ((not (test-msa-fixed n))
                 (error "long-test failed fixed at ~:d." n)))
          (cond ((not (test-msa-float n))
                 (error "long-test failed float at ~:d." n))))))