/mobile Handheld Friendly website

 performance measurements

Each table row shows performance measurements for this Lisp SBCL program with a particular command-line input value N.

 N  CPU secs Elapsed secs Memory KB Code B ≈ CPU Load
100.320.14?1607  43% 92% 47% 46%
113.670.9925,0361607  99% 91% 91% 91%
1253.0113.3527,0881607  99% 99% 99% 100%

Read the ↓ make, command line, and program output logs to see how this program was run.

Read fannkuch-redux benchmark to see what this program should do.


This is SBCL 1.1.13, an implementation of ANSI Common Lisp.

 fannkuch-redux Lisp SBCL program source code

;; The Computer Language Benchmarks Game
;;   http://benchmarksgame.alioth.debian.org/
;;   contributed by Alexey Voznyuk

(defpackage #:fannkuch-redux
  (:use :cl))

(in-package :fannkuch-redux)

(defun make-facts-vector (seq-length)
  (make-array (1+ seq-length)
              :initial-contents (cons 1 (loop :with r = 1 :for i from 1 to seq-length
                                           :collect (setf r (* r i))))))

(defmacro with-vars-bound ((vars bind-vars) &body body)
  `(let (,@(loop :for var :in vars :for bind-var :in bind-vars :collect `(,var ,bind-var)))
     (declare (type fixnum ,@vars) (ignorable ,@vars))

(defmacro with-permutations (((&rest seq-vars) perm-index-start perm-count) &body body)
  (let* ((seq-length (length seq-vars))
         (facts (make-facts-vector seq-length))
         (outer-tag (gensym))
         (count (gensym)))
    (labels ((build-loop (depth upper-seq-vars)
               (if (>= depth seq-length)
                   `(with-vars-bound (,seq-vars ,upper-seq-vars)
                      (when (zerop ,count)
                        (return-from ,outer-tag))
                      (decf ,count)
                   (let* ((my-seq-vars (loop :repeat (- seq-length depth) :collect (gensym)))
                          (shift-body `(let ((first ,(car my-seq-vars)))
                                         (setf ,@(loop :for src :in my-seq-vars and dst = src
                                                    :when dst :collect dst and :collect src)
                                               ,(car (last my-seq-vars)) first)))
                          (repeat-body (if (= depth (1- seq-length))
                                           (build-loop (1+ depth) upper-seq-vars)
                                           `(prog1 (if (>= ,perm-index-start ,(elt facts (- seq-length depth 1)))
                                                       (decf ,perm-index-start ,(elt facts (- seq-length depth 1)))
                                                       ,(build-loop (1+ depth)
                                                                    (append my-seq-vars (subseq upper-seq-vars
                                                                                                (length my-seq-vars)))))
                     (if (> (- seq-length depth) 1)
                         `(with-vars-bound (,my-seq-vars ,upper-seq-vars)
                            (loop :repeat ,(- seq-length depth) :do ,repeat-body))
      `(let ((,count ,perm-count))
         (declare (type (integer 0 ,(elt facts seq-length)) ,count))
         (block ,outer-tag
           ,(build-loop 0 (loop :for i :from 0 :below seq-length :collect i)))))))

(defmacro with-flips-count (((&rest seq-vars) flips-count) &body body)
  (let ((head (car seq-vars)))
    `(let ((,flips-count 0))
       (declare (type fixnum ,flips-count))
       (unless (zerop ,head)
            (incf ,flips-count)
              ,@(loop :for value :from 1 :below (length seq-vars)
                   :collect `((= ,head ,value)
                              (when (zerop ,(elt seq-vars value))
                              ,@(loop :for l :from 0 :for r :downfrom value :while (< l r)
                                   :collect `(rotatef ,(elt seq-vars l) ,(elt seq-vars r))))))))

(defstruct atomic
  (counter 0 :type (unsigned-byte #+x86-64 64 #+x86 32)))

(defmacro deffannkuch (seq-length &key (workers 1) worker-chunk-size)
  (let* ((facts (make-facts-vector seq-length))
         (chunk-size (or worker-chunk-size (min (elt facts seq-length) 400)))
         (seq-vars (loop :for i :from 0 :below seq-length :collect (gensym))))
    `(lambda ()
       (declare (optimize (speed 3) (safety 0) (debug 0)))
       (let ((wrk-max-flips (make-array ,workers :element-type 'fixnum))
             (wrk-checksums (make-array ,workers :element-type 'fixnum))
             (current-idx (make-atomic)))
         (flet ((make-worker (wrk-index)
                  (declare (type (integer 0 ,(1- workers)) wrk-index))
                  (lambda ()
                       :with checksum :of-type fixnum = 0
                       :with max-flips :of-type fixnum = 0
                       :for perm-index :of-type fixnum = (sb-ext:atomic-incf (atomic-counter current-idx)
                       :while (< perm-index ,(elt facts seq-length))
                       :for sign :of-type boolean = (evenp perm-index)
                       :do (with-permutations ((,@seq-vars) perm-index ,chunk-size)
                             (with-flips-count ((,@seq-vars) flips-count)
                               (when (> flips-count max-flips)
                                 (setf max-flips flips-count))
                               (incf checksum (if sign flips-count (- flips-count)))
                               (setf sign (not sign))))
                       :finally (setf (elt wrk-max-flips wrk-index) max-flips
                                      (elt wrk-checksums wrk-index) checksum)))))
           (mapc #'sb-thread:join-thread
                 (list ,@(loop :for wrk-index :from 0 :below workers
                            :collect `(sb-thread:make-thread (make-worker ,wrk-index))))))
         (loop :for i :from 0 :below ,workers
            :summing (elt wrk-checksums i) :into checksum :of-type fixnum
            :maximizing (elt wrk-max-flips i) :into max-flips
            :finally (return (values checksum max-flips)))))))

(defun main (&optional force-n)
  (let* ((args (cdr sb-ext:*posix-argv*))
         (n (or force-n (if args (parse-integer (car args)) 12))))
    (multiple-value-bind (checksum max-flips-count)
        (funcall (the function (eval `(deffannkuch ,n :workers 4 :worker-chunk-size 12000))))
      (format t "~a~%Pfannkuchen(~a) = ~a~%" checksum n max-flips-count))))

(in-package :cl-user)

(defun main ()

 make, command-line, and program output logs

Thu, 28 Nov 2013 17:48:51 GMT

cp: ‘fannkuchredux.sbcl’ and ‘./fannkuchredux.sbcl’ are the same file
SBCL built with: /usr/local/bin/sbcl --userinit /dev/null --batch --eval '(load "fannkuchredux.sbcl_compile")'
### START fannkuchredux.sbcl_compile
(handler-bind ((sb-ext:defconstant-uneql      (lambda (c) (abort c))))      (load (compile-file "fannkuchredux.sbcl" ))) (save-lisp-and-die "sbcl.core" :purify t)
### END fannkuchredux.sbcl_compile

; compiling file "/home/dunham/benchmarksgame/bench/fannkuchredux/fannkuchredux.sbcl" (written 23 JAN 2013 08:17:09 PM):
; compiling (DEFUN MAKE-FACTS-VECTOR ...)
; compiling (DEFMACRO WITH-VARS-BOUND ...)
; compiling (DEFSTRUCT ATOMIC ...)
; compiling (DEFMACRO DEFFANNKUCH ...)
; compiling (DEFUN MAIN ...)
; compiling (IN-PACKAGE :CL-USER)
; compiling (DEFUN MAIN ...)

; /home/dunham/benchmarksgame_quadcore/fannkuchredux/tmp/fannkuchredux.fasl written
; compilation finished in 0:00:00.142
[undoing binding stack and other enclosing state... done]
[saving current Lisp image into sbcl.core:
writing 5856 bytes from the read-only space at 0x0x20000000
writing 4032 bytes from the static space at 0x0x20100000
writing 44761088 bytes from the dynamic space at 0x0x1000000000
### START fannkuchredux.sbcl_run
(main) (quit)
### END fannkuchredux.sbcl_run

0.50s to complete and log all make actions

/usr/local/bin/sbcl  --noinform --core sbcl.core --userinit /dev/null --load fannkuchredux.sbcl_run 12

Pfannkuchen(12) = 65

Revised BSD license

  Home   Conclusions   License   Play