Initial commit.

[collect-bench] / collect.lisp

(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)