| 1 | (cl:defpackage #:collect |
| 2 | (:use #:common-lisp)) |
| 3 | (cl:in-package #:collect) |
| 4 | |
| 5 | (declaim (inline make-forward-collector |
| 6 | forward-collect |
| 7 | forward-collection)) |
| 8 | (defun make-forward-collector () |
| 9 | (let ((c (cons nil nil))) |
| 10 | (setf (car c) c) |
| 11 | c)) |
| 12 | (defun forward-collect (c x) |
| 13 | (declare (type cons c)) |
| 14 | (let ((new (cons x nil))) |
| 15 | (setf (cdr (car c)) new |
| 16 | (car c) new))) |
| 17 | (defun forward-collection (c) |
| 18 | (declare (type cons c)) |
| 19 | (cdr c)) |
| 20 | |
| 21 | (defmacro with-macro-collector ((collect collection) &body body) |
| 22 | (let ((head (gensym "HEAD-")) |
| 23 | (tail (gensym "TAIL-")) |
| 24 | (item (gensym "ITEM-")) |
| 25 | (new (gensym "NEW-"))) |
| 26 | `(let* ((,head (cons nil nil)) (,tail ,head)) |
| 27 | (declare (type cons ,head ,tail)) |
| 28 | (flet ((,collect (,item) |
| 29 | (let ((,new (cons ,item nil))) |
| 30 | (setf (cdr ,tail) ,new |
| 31 | ,tail ,new))) |
| 32 | (,collection () |
| 33 | (cdr ,head))) |
| 34 | (declare (inline ,collect ,collection)) |
| 35 | ,@body)))) |
| 36 | |
| 37 | (declaim (inline make-reverse-collector |
| 38 | reverse-collect |
| 39 | reverse-collection-nondestructively |
| 40 | reverse-collection)) |
| 41 | (defun make-reverse-collector () |
| 42 | (cons nil nil)) |
| 43 | (defun reverse-collect (c x) |
| 44 | (declare (type cons c)) |
| 45 | (push x (cdr c))) |
| 46 | (defun reverse-collection-nondestructively (c) |
| 47 | (declare (type cons c)) |
| 48 | (reverse (cdr c))) |
| 49 | (defun reverse-collection (c) |
| 50 | (declare (type cons c)) |
| 51 | (nreverse (cdr c))) |
| 52 | |
| 53 | (defun measure-strategy (name test-func bench-func) |
| 54 | (declare (type (function (fixnum) t) bench-func) |
| 55 | (type (function (fixnum) list) test-func)) |
| 56 | (let* ((n 1234) |
| 57 | (ref (loop for i below n collect i)) |
| 58 | (out (funcall test-func n))) |
| 59 | (unless (equal out ref) |
| 60 | (error "Generator ~A failed" name))) |
| 61 | (format t "#> ~A~%" name) |
| 62 | (let ((max #x100000)) |
| 63 | (do ((n 0 (if (zerop n) 1 (* 16 n)))) |
| 64 | ((> n max)) |
| 65 | (declare (type fixnum n)) |
| 66 | (multiple-value-bind (cy clk) (funcall bench-func n) |
| 67 | (format t "~8D ~12,4,,,,,'eG ~12,4,,,,,'eG~%" n cy clk))))) |
| 68 | |
| 69 | (export 'time-it) |
| 70 | (defun time-it () |
| 71 | (let ((firstp t)) |
| 72 | (macrolet ((bench (name (n) form) |
| 73 | `(progn |
| 74 | (cond (firstp (setf firstp nil)) |
| 75 | (t (terpri) (terpri))) |
| 76 | (measure-strategy ,(etypecase name |
| 77 | (string name) |
| 78 | (symbol (string-downcase name))) |
| 79 | (lambda (,n) |
| 80 | (declare (type fixnum ,n)) |
| 81 | ,form) |
| 82 | (lambda (,n) |
| 83 | (declare (type fixnum ,n)) |
| 84 | (bench:measure ,form |
| 85 | :per-rep (max ,n 1))))))) |
| 86 | |
| 87 | (bench baseline (n) |
| 88 | (do ((i (1- n) (1- i)) |
| 89 | (list nil (cons i list))) |
| 90 | ((minusp i) list) |
| 91 | (declare (type fixnum i)))) |
| 92 | |
| 93 | (bench forward (n) |
| 94 | (let ((c (make-forward-collector))) |
| 95 | (dotimes (i n) |
| 96 | (declare (type fixnum i)) |
| 97 | (forward-collect c i)) |
| 98 | (forward-collection c))) |
| 99 | |
| 100 | (bench macro (n) |
| 101 | (with-macro-collector (collect collection) |
| 102 | (dotimes (i n) |
| 103 | (declare (type fixnum i)) |
| 104 | (collect i)) |
| 105 | (collection))) |
| 106 | |
| 107 | (bench nreverse (n) |
| 108 | (let ((c (make-reverse-collector))) |
| 109 | (dotimes (i n) |
| 110 | (declare (type fixnum i)) |
| 111 | (reverse-collect c i)) |
| 112 | (reverse-collection c))) |
| 113 | |
| 114 | (bench reverse (n) |
| 115 | (let ((c (make-reverse-collector))) |
| 116 | (dotimes (i n) |
| 117 | (declare (type fixnum i)) |
| 118 | (reverse-collect c i)) |
| 119 | (reverse-collection-nondestructively c))) |
| 120 | |
| 121 | (bench loop (n) |
| 122 | (loop for i below n collect i))))) |
| 123 | |
| 124 | #+(or cl-launch runlisp-script) |
| 125 | (time-it) |