From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 3 Jun 2021 15:28:51 +0000 (+0100)
Subject: Initial commit.
X-Git-Url: https://git.distorted.org.uk/~mdw/collect-bench/commitdiff_plain

Initial commit.
---

7642fe3badebf78b93bc0872a8724e9332c8deaf
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..385de91
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,7 @@
+*.aux
+*.fasl
+*.log
+*.out
+*.pdf
+/plot-*.tex
+/report.*
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..e5b5b3c
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,25 @@
+### -*-makefile-*-
+
+all::
+clean::
+.PHONY: all clean
+
+PWD			:= $(shell pwd)
+LISPS			 = sbcl ccl ecl clisp cmucl abcl
+
+RUNLISP			 = $(HOME)/src/runlisp/build/runlisp
+
+REPORTS			 = $(addprefix report., $(LISPS))
+clean::; rm -f $(REPORTS)
+$(REPORTS): report.%: collect.lisp bench.asd bench.lisp benchspt.c
+	cl-launch -X -S $(PWD): -s bench -l $* -- $< >$@.new && mv $@.new $@
+
+PLOTS			 = $(patsubst %,plot-%.tex, $(LISPS))
+clean:: rm -f $(PLOTS)
+$(PLOTS): plot-%.tex: report.% plot.gp
+	gnuplot -e "file = '$<'" plot.gp >$@.new && mv $@.new $@
+
+all:: collect.pdf
+clean::; rm -f collect.pdf
+collect.pdf: collect.tex $(PLOTS)
+	pdflatex $<
diff --git a/bench.asd b/bench.asd
new file mode 100644
index 0000000..c92ad71
--- /dev/null
+++ b/bench.asd
@@ -0,0 +1,57 @@
+;;; -*-lisp-*-
+
+(cl:defpackage #:bench-defsystem
+  (:use #:common-lisp))
+(cl:in-package #:bench-defsystem)
+
+(defclass c-source-file (asdf:source-file)
+  ((type :initform "c")))
+
+(defmethod asdf:output-files ((o asdf:compile-op) (c c-source-file))
+  (mapcar (lambda (f)
+	    (make-pathname :type "O" :case :common :defaults f))
+	  (asdf:input-files o c)))
+
+(defmethod asdf:perform ((o asdf:load-op) (c c-source-file))
+  #| nothing to do |#)
+
+(defmethod asdf:perform ((o asdf:compile-op) (c c-source-file))
+  (mapc (lambda (in out)
+	  (uiop:run-program (list "gcc" "-c" "-O2" "-g" "-Wall" "-fPIC"
+				  #+cmu "-m32"
+				  "-o" (uiop:native-namestring out)
+				  (uiop:native-namestring in))))
+	(asdf:input-files o c)
+	(asdf:output-files o c)))
+
+(defclass c-shared-lib (asdf:module)
+  ((soname :initarg :soname :initform nil)))
+
+(defmethod asdf:output-files ((o asdf:compile-op) (c c-shared-lib))
+  (list (make-pathname :name (or (slot-value c 'soname)
+				 (asdf:component-name c))
+		       :type "so")))
+
+(defmethod asdf:perform ((o asdf:compile-op) (c c-shared-lib))
+  (let ((out (asdf:output-files o c)))
+    (assert (and out (null (cdr out))))
+    (uiop:run-program (list* "gcc"
+			     #+cmu "-m32"
+			     "-o" (uiop:native-namestring (car out))
+			     "-shared"
+			     (mapcan (lambda (kid)
+				       (mapcar #'uiop:native-namestring
+					       (asdf:output-files o kid)))
+				     (asdf:component-children c))))))
+
+(asdf:defsystem "bench"
+  :version "0.1.0"
+  :pathname "/home/mdw/src/bench/"
+  :depends-on ("cffi")
+  :components
+    ((c-shared-lib "benchspt"
+       :soname "libbenchspt"
+       :pathname ""
+       :components
+	 ((c-source-file "benchspt")))
+     (:file "bench" :depends-on ("benchspt"))))
diff --git a/bench.lisp b/bench.lisp
new file mode 100644
index 0000000..855cc8c
--- /dev/null
+++ b/bench.lisp
@@ -0,0 +1,139 @@
+;;; -*-lisp-*-
+
+(defpackage #:bench
+  (:use #:common-lisp))
+(in-package #:bench)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (cffi:define-foreign-library benchspt
+    (t (:default "libbenchspt")))
+  (let ((cffi:*foreign-library-directories*
+	 (append (mapcar (lambda (p)
+			   (make-pathname :name nil :type nil :version nil
+					  :defaults p))
+			 (asdf:output-files 'asdf:compile-op
+					    (asdf:find-component "bench"
+								 "benchspt")))
+		 cffi:*foreign-library-directories*)))
+    ;; sorry about that
+    (cffi:use-foreign-library benchspt)))
+
+(export '(get-errno strerror))
+(cffi:defcfun ("get_errno" :library benchspt) :int)
+(cffi:defcfun ("strerror" :library benchspt) :string (err :int))
+
+(export '(system-error
+	  system-error-message system-error-errno system-error-string))
+(define-condition system-error (error)
+  ((message :type string
+	    :initarg :message
+	    :reader system-error-message)
+   (errno :type fixnum
+	  :initarg :errno
+	  :initform (get-errno)
+	  :reader system-error-errno)))
+(defgeneric system-error-string (error)
+  (:method ((error system-error)) (strerror (system-error-errno error))))
+(defun system-error (message &optional (errno (get-errno)))
+  (error 'system-error :message message :errno errno))
+(defmethod print-object ((error system-error) stream)
+  (format stream "~A: ~A~%"
+	  (system-error-message error)
+	  (system-error-string error)))
+
+(export '(open-cycle-counter close-cycle-counter))
+(cffi:defcfun (%open-cycle-counter "open_cycle_counter" :library benchspt)
+    :pointer)
+(defun open-cycle-counter (&key fail-softly)
+  (let ((counter (%open-cycle-counter)))
+    (cond ((not (cffi:null-pointer-p counter)) counter)
+	  ((not fail-softly) (system-error "Failed to open cycle counter"))
+	  (t nil))))
+(cffi:defcfun (close-cycle-counter "close_cycle_counter" :library benchspt)
+    :void
+  (cy :pointer))
+
+(export '(with-cycle-counter* with-cycle-counter))
+(defun with-cycle-counter* (thunk &key fail-softly)
+  (let ((counter (open-cycle-counter :fail-softly fail-softly)))
+    (unwind-protect (funcall thunk counter)
+      (close-cycle-counter counter))))
+(defmacro with-cycle-counter
+    ((counter &rest keys &key fail-softly) &body body)
+  (declare (ignore fail-softly))
+  `(with-cycle-counter* (lambda (,counter) ,@body) ,@keys))
+
+(export 'cycles)
+(cffi:defcfun (%cycles "cycles" :library benchspt) :int
+  (cy :pointer) (count (:pointer :uint64)))
+(defun cycles (counter)
+  (cffi:with-foreign-object (count :uint64)
+    (unless (zerop (%cycles counter count))
+      (system-error "Failed to read cycle counter"))
+    (cffi:mem-ref count :uint64)))
+
+(export 'cycles-)
+(defun cycles- (a b)
+  (mod (- a b) #.(ash 1 64)))
+
+(export '(thread-clock thread-clock-as-float))
+(cffi:defcstruct (clock :class clock-struct)
+  (sec :int64)
+  (nsec :uint32))
+(defmethod cffi:translate-from-foreign (clock (type clock-struct))
+  (cffi:with-foreign-slots ((sec nsec) clock (:struct clock))
+    (+ (* 1000000000 sec) nsec)))
+(cffi:defcfun (%thread-clock "thread_clock" :library benchspt) :int
+  (clk (:pointer (:struct clock))))
+(defun thread-clock ()
+  (cffi:with-foreign-object (clk '(:struct clock))
+    (unless (zerop (%thread-clock clk))
+      (error "Failed to read thread clock: ~A" (strerror (get-errno))))
+    (cffi:mem-ref clk '(:struct clock))))
+(defun thread-clock-as-float (&optional (clock (thread-clock)))
+  (* clock 1.0d-9))
+
+(export '(measure* measure))
+(declaim (inline measure*))
+(defun measure* (func &key reps (per-rep 1))
+  (with-cycle-counter (cc :fail-softly t)
+    (flet ((run (reps)
+	     #+sbcl (sb-ext:gc :full t)
+	     #+ccl (ccl:gc)
+	     #+(or clisp ecl) (ext:gc t)
+	     #+cmu (ext:gc :full t :verbose nil)
+	     ;;#+abcl (ext:gc) -- very slow!
+	     (let ((t0 (thread-clock))
+		   (c0 (and cc (cycles cc))))
+	       (funcall func reps)
+	       (let ((c1 (and cc (cycles cc)))
+		     (t1 (thread-clock)))
+		 (values (and cc (cycles- c1 c0))
+			 (thread-clock-as-float (- t1 t0)))))))
+      (multiple-value-bind (cy clk)
+	  (cond (reps
+		 (run reps))
+		(t
+		 (setf reps 1)
+		 (loop (multiple-value-bind (cy clk) (run reps)
+			 (when (> clk 0.71d0) (return (values cy clk)))
+			 (setf reps (floor reps clk))))))
+	(let ((all (float (* reps per-rep) 1.0d0)))
+	  (values (and cc (/ cy all)) (/ clk all)))))))
+
+(defmacro measure
+    (form
+     &key (reps nil repsp) (per-rep nil per-rep-p)
+	  (optimize '((speed 3) (space 0) (debug 0) (safety 0))))
+  (let ((i (gensym "I"))
+	(n (gensym "N"))
+	(hunoz (gensym "HUNOZ-")))
+    `(measure* (lambda (,n)
+		 (declare (type (unsigned-byte 32) ,n)
+			  ,@(and optimize `((optimize ,@optimize)))
+			  #+sbcl (sb-ext:muffle-conditions style-warning))
+		 (dotimes (,i ,n)
+		   (let ((,hunoz ,form))
+		     (declare (ignore ,hunoz)))))
+	       ,@(and repsp `(:reps ,reps))
+	       ,@(and per-rep-p `(:per-rep ,per-rep)))))
diff --git a/benchspt.c b/benchspt.c
new file mode 100644
index 0000000..866085e
--- /dev/null
+++ b/benchspt.c
@@ -0,0 +1,109 @@
+#include <errno.h>
+#include <stdlib.h>
+#include <time.h>
+
+#if defined(__GNUC__) && (defined(__i386__) || defined (__x86_64__))
+
+struct cycle_counter {
+  char dummy;
+};
+
+static int init_counter(struct cycle_counter *cy) { return (0); }
+static void teardown_counter(struct cycle_counter *cy) { ; }
+
+int cycles(struct cycle_counter *cy, unsigned long long *t_out)
+{
+  unsigned lo, hi;
+
+  __asm__("rdtsc" : "=a"(lo), "=d"(hi));
+  *t_out = lo | ((unsigned long long)hi << 32);
+  return (0);
+}
+
+#elif defined(__linux__)
+
+#include <unistd.h>
+#include <linux/perf_event.h>
+#include <asm/unistd.h>
+
+struct cycle_counter {
+  int fd;
+};
+
+static int init_counter(struct cycle_counter *cy)
+{
+  struct perf_event_attr attr = { 0 };
+
+  attr.type = PERF_TYPE_HARDWARE;
+  attr.size = sizeof(attr);
+  attr.config = PERF_COUNT_HW_CPU_CYCLES;
+  attr.disabled = 0;
+  attr.exclude_kernel = 1;
+  attr.exclude_hv = 1;
+
+  cy->fd = syscall(__NR_perf_event_open, &attr, 0, -1, -1, 0);
+  if (cy->fd < 0) return (-1);
+  return (0);
+}
+
+static void teardown_counter(struct cycle_counter *cy)
+  { if (cy->fd >= 0) close(cy->fd); }
+
+int cycles(struct cycle_counter *cy, unsigned long long *t_out)
+{
+  ssize_t n;
+
+  if (cy->fd < 0) { errno = EBADF; return (-1); }
+  n = read(cy->fd, t_out, sizeof(*t_out));
+  if (n < sizeof(*t_out)) {
+    if (n >= 0) errno = ENODATA;
+    close(cy->fd); cy->fd = -1;
+    return (-1);
+  }
+  return (0);
+}
+
+#else
+
+struct cycle_counter {
+  char dummy;
+};
+
+static int init_counter(struct cycle_counter *cy)
+  { errno = ENOSYS; return (-1); }
+static void teardown_counter(struct cycle_counter *cy) { ; }
+int cycles(struct cycle_counter *cy, unsigned long long *t_out)
+  { return (-1); }
+
+#endif
+
+struct cycle_counter *open_cycle_counter(void)
+{
+  struct cycle_counter *cy = 0, *cy_ret = 0;
+
+  cy = malloc(sizeof(*cy)); if (!cy) goto end;
+  if (init_counter(cy)) goto end;
+  cy_ret = cy; cy = 0;
+end:
+  free(cy);
+  return (cy_ret);
+}
+
+void close_cycle_counter(struct cycle_counter *cy)
+  { teardown_counter(cy); free(cy); }
+
+struct clock {
+  long long sec;
+  unsigned nsec;
+};
+
+int thread_clock(struct clock *clk_out)
+{
+  struct timespec tv;
+
+  if (clock_gettime(CLOCK_THREAD_CPUTIME_ID, &tv)) return (-1);
+  clk_out->sec = tv.tv_sec; clk_out->nsec = tv.tv_nsec;
+  return (0);
+}
+
+int get_errno(void) { return (errno); }
diff --git a/collect.lisp b/collect.lisp
new file mode 100644
index 0000000..760f66d
--- /dev/null
+++ b/collect.lisp
@@ -0,0 +1,125 @@
+(cl:defpackage #:collect
+  (:use #:common-lisp))
+(cl:in-package #:collect)
+
+(declaim (inline make-forward-collector
+		 forward-collect
+		 forward-collection))
+(defun make-forward-collector ()
+  (let ((c (cons nil nil)))
+    (setf (car c) c)
+    c))
+(defun forward-collect (c x)
+  (declare (type cons c))
+  (let ((new (cons x nil)))
+    (setf (cdr (car c)) new
+	  (car c) new)))
+(defun forward-collection (c)
+  (declare (type cons c))
+  (cdr c))
+
+(defmacro with-macro-collector ((collect collection) &body body)
+  (let ((head (gensym "HEAD-"))
+	(tail (gensym "TAIL-"))
+	(item (gensym "ITEM-"))
+	(new (gensym "NEW-")))
+    `(let* ((,head (cons nil nil)) (,tail ,head))
+       (declare (type cons ,head ,tail))
+       (flet ((,collect (,item)
+		(let ((,new (cons ,item nil)))
+		  (setf (cdr ,tail) ,new
+			,tail ,new)))
+	      (,collection ()
+		(cdr ,head)))
+	 (declare (inline ,collect ,collection))
+	 ,@body))))
+
+(declaim (inline make-reverse-collector
+		 reverse-collect
+		 reverse-collection-nondestructively
+		 reverse-collection))
+(defun make-reverse-collector ()
+  (cons nil nil))
+(defun reverse-collect (c x)
+  (declare (type cons c))
+  (push x (cdr c)))
+(defun reverse-collection-nondestructively (c)
+  (declare (type cons c))
+  (reverse (cdr c)))
+(defun reverse-collection (c)
+  (declare (type cons c))
+  (nreverse (cdr c)))
+
+(defun measure-strategy (name test-func bench-func)
+  (declare (type (function (fixnum) t) bench-func)
+	   (type (function (fixnum) list) test-func))
+  (let* ((n 1234)
+	 (ref (loop for i below n collect i))
+	 (out (funcall test-func n)))
+    (unless (equal out ref)
+      (error "Generator ~A failed" name)))
+  (format t "#> ~A~%" name)
+  (let ((max #x100000))
+    (do ((n 0 (if (zerop n) 1 (* 16 n))))
+	((> n max))
+      (declare (type fixnum n))
+      (multiple-value-bind (cy clk) (funcall bench-func n)
+	(format t "~8D ~12,4,,,,,'eG ~12,4,,,,,'eG~%" n cy clk)))))
+
+(export 'time-it)
+(defun time-it ()
+  (let ((firstp t))
+    (macrolet ((bench (name (n) form)
+		 `(progn
+		    (cond (firstp (setf firstp nil))
+			  (t (terpri) (terpri)))
+		    (measure-strategy ,(etypecase name
+					 (string name)
+					 (symbol (string-downcase name)))
+				      (lambda (,n)
+					(declare (type fixnum ,n))
+					,form)
+				      (lambda (,n)
+					(declare (type fixnum ,n))
+					(bench:measure ,form
+						       :per-rep (max ,n 1)))))))
+
+      (bench baseline (n)
+	(do ((i (1- n) (1- i))
+	     (list nil (cons i list)))
+	    ((minusp i) list)
+	  (declare (type fixnum i))))
+
+      (bench forward (n)
+	(let ((c (make-forward-collector)))
+	  (dotimes (i n)
+	    (declare (type fixnum i))
+	    (forward-collect c i))
+	  (forward-collection c)))
+
+      (bench macro (n)
+	(with-macro-collector (collect collection)
+	  (dotimes (i n)
+	    (declare (type fixnum i))
+	    (collect i))
+	  (collection)))
+
+      (bench nreverse (n)
+	(let ((c (make-reverse-collector)))
+	  (dotimes (i n)
+	    (declare (type fixnum i))
+	    (reverse-collect c i))
+	  (reverse-collection c)))
+
+      (bench reverse (n)
+	(let ((c (make-reverse-collector)))
+	  (dotimes (i n)
+	    (declare (type fixnum i))
+	    (reverse-collect c i))
+	  (reverse-collection-nondestructively c)))
+
+      (bench loop (n)
+	(loop for i below n collect i)))))
+
+#+(or cl-launch runlisp-script)
+(time-it)
diff --git a/collect.tex b/collect.tex
new file mode 100644
index 0000000..47bb71f
--- /dev/null
+++ b/collect.tex
@@ -0,0 +1,21 @@
+\documentclass[article]{strayman}
+\usepackage[T1]{fontenc}
+\usepackage[palatino, helvetica, courier, maths=cmr]{mdwfonts}
+\usepackage{tikz}
+\usepackage{gnuplot-lua-tikz}
+
+\def\showplot#1#2{
+  \begin{figure}
+    \input{plot-#1}
+    \caption{Performance on #2} \label{fig:plot-#1}
+  \end{figure}
+}
+
+\begin{document}
+\showplot{sbcl}{Steel Bank Common Lisp}
+\showplot{ccl}{Clozure Common Lisp}
+\showplot{ecl}{Embeddable Common Lisp}
+\showplot{clisp}{GNU CLisp}
+\showplot{cmucl}{Carnegie--Mellon University Common Lisp}
+\showplot{abcl}{Armed Bear Common Lisp}
+\end{document}
diff --git a/plot.gp b/plot.gp
new file mode 100644
index 0000000..04ef04e
--- /dev/null
+++ b/plot.gp
@@ -0,0 +1,20 @@
+### -*-gnuplot-*-
+
+set terminal tikz
+set logscale xy 2
+set style data linespoints
+set key center top font '\footnotesize\itshape' box
+set border 3
+set tics nomirror
+set xtics 16
+
+set xlabel "List length"
+set xtics (1, 16, 256, 4096, '$65\,536$' 65536, '$2^{20}$' 2**20)
+set ylabel "Cycles per element"
+
+plot file index "> baseline" using 1:2 title "baseline", \
+     "" index "> forward" using 1:2 title "forward", \
+     "" index "> macro" using 1:2 title "macro", \
+     "" index "> nreverse" using 1:2 title "nreverse", \
+     "" index "> reverse" using 1:2 title "reverse", \
+     "" index "> loop" using 1:2 title "loop"