binary-trees Lisp SBCL #3 program

;;   The Computer Language Benchmarks Game
;;   https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
;;;
;;; contributed by Roman Kashitsyn
;;;

(deftype uint () '(unsigned-byte 62))

(defconstant min-depth 4 "Minimal depth of the binary tree.")
(defparameter num-workers 4 "Number of concurrent workers.")

(defun build-tree (depth)
    "Build a binary tree of the specified DEPTH. Leaves are represented by NIL,
branches are represented by a cons cell."
  (declare (ftype (function (uint) list) build-tree)
           (uint depth)
           (optimize (speed 3) (safety 0)))
  (if (zerop depth) (cons nil nil)
      (cons (build-tree (1- depth))
            (build-tree (1- depth)))))

(defun check-node (node)
  (declare (ftype (function (list) uint) check-node)
           (optimize (speed 3) (safety 0)))
  (if (null (car node))
      1
      (the uint (+ 1 (check-node (car node)) (check-node (cdr node))))))

(defun check-trees-of-depth (depth max-depth)
  (declare (uint depth max-depth)
           (optimize (speed 3) (safety 0)))
  (loop with iterations of-type uint = (ash 1 (+ max-depth min-depth (- depth)))
        for i of-type uint from 1 upto iterations
        sum (check-node (build-tree depth))
        into result of-type uint
        finally (return (format nil "~d~c trees of depth ~d~c check: ~d~%"
                                iterations #\Tab depth #\Tab result))))

(defun loop-depths-async (max-depth)
  (declare (fixnum max-depth))
  (let* ((tasks (sb-concurrency:make-queue
                 :initial-contents
                 (loop for depth from min-depth by 2 upto max-depth
                       collect depth)))
         (outputs (sb-concurrency:make-queue))
         (threads
           (loop for i of-type fixnum from 1 to num-workers
                 collect (sb-thread:make-thread
                          #'(lambda ()
                              (loop as task = (sb-concurrency:dequeue tasks)
                                    while task
                                    do (sb-concurrency:enqueue
                                        (cons task
                                              (check-trees-of-depth task max-depth))
                                        outputs)))))))
    (mapc #'sb-thread:join-thread threads)
    (let ((results (sort (sb-concurrency:list-queue-contents outputs)
                         #'< :key #'car)))
      (loop for (k . v) in results
            do (format t "~a" v)))))

(defun binary-trees-upto-size (n)
  (declare (type (integer 0 255) n))
  (format t "stretch tree of depth ~d~c check: ~d~%" (1+ n) #\Tab
          (check-node (build-tree (1+ n))))
  (let ((long-lived-tree (build-tree n)))
    (loop-depths-async n)
    (format t "long lived tree of depth ~d~c check: ~d~%" n #\Tab
            (check-node long-lived-tree))))

(defun main (&optional (n (parse-integer (or (car (last sb-ext:*posix-argv*))
                                             "1"))))
  (binary-trees-upto-size n))
    

NOTES:
64-bit Ubuntu quad core
SBCL 2.0.4


Thu, 21 May 2020 23:05:13 GMT

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

; compiling file "/home/dunham/8000-benchmarksgame/bench/binarytrees/binarytrees.sbcl-3.sbcl" (written 01 JAN 2020 03:08:42 PM):
; compiling (DEFTYPE UINT ...)
; compiling (DEFCONSTANT MIN-DEPTH ...)
; compiling (DEFPARAMETER NUM-WORKERS ...)
; compiling (DEFUN BUILD-TREE ...)
; compiling (DEFUN CHECK-NODE ...)
; compiling (DEFUN CHECK-TREES-OF-DEPTH ...)
; compiling (DEFUN LOOP-DEPTHS-ASYNC ...)
; compiling (DEFUN BINARY-TREES-UPTO-SIZE ...)
; compiling (DEFUN MAIN ...)

; wrote /home/dunham/benchmarksgame_quadcore/binarytrees/tmp/binarytrees.sbcl-3.fasl
; compilation finished in 0:00:00.204
### START binarytrees.sbcl-3.sbcl_run
(main) (quit)
### END binarytrees.sbcl-3.sbcl_run


4.63s to complete and log all make actions

COMMAND LINE:
/usr/local/bin/sbcl  --noinform --core sbcl.core --userinit /dev/null --load binarytrees.sbcl-3.sbcl_run 21

PROGRAM OUTPUT:
stretch tree of depth 22	 check: 8388607
2097152	 trees of depth 4	 check: 65011712
524288	 trees of depth 6	 check: 66584576
131072	 trees of depth 8	 check: 66977792
32768	 trees of depth 10	 check: 67076096
8192	 trees of depth 12	 check: 67100672
2048	 trees of depth 14	 check: 67106816
512	 trees of depth 16	 check: 67108352
128	 trees of depth 18	 check: 67108736
32	 trees of depth 20	 check: 67108832
long lived tree of depth 21	 check: 4194303