--- /dev/null
+*.aux
+*.fasl
+*.log
+*.out
+*.pdf
+/plot-*.tex
+/report.*
--- /dev/null
+### -*-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 $<
--- /dev/null
+;;; -*-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"))))
--- /dev/null
+;;; -*-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)))))
--- /dev/null
+#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); }
--- /dev/null
+(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)
--- /dev/null
+\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}
--- /dev/null
+### -*-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"
~mdw / collect-bench / commitdiff