From 7642fe3badebf78b93bc0872a8724e9332c8deaf Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 3 Jun 2021 16:28:51 +0100
Subject: [PATCH 1/1] Initial commit.

---
 .gitignore   |   7 +++
 Makefile     |  25 +++++++++++
 bench.asd    |  57 ++++++++++++++++++++++++
 bench.lisp   | 139 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 benchspt.c   | 109 ++++++++++++++++++++++++++++++++++++++++++++++
 collect.lisp | 125 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 collect.tex  |  21 +++++++++
 plot.gp      |  20 +++++++++
 8 files changed, 503 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 Makefile
 create mode 100644 bench.asd
 create mode 100644 bench.lisp
 create mode 100644 benchspt.c
 create mode 100644 collect.lisp
 create mode 100644 collect.tex
 create mode 100644 plot.gp

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"
-- 
2.11.0