Several people have kindly ported my ray tracer from this page:

  http://www.ffconsultancy.com/free/ray_tracer/languages.html

to Lisp. Some of them are reporting competitive performance. However, when I
try to run their programs with either CMUCL or SBCL they are two orders of
magnitude slower. Given the number of people claiming similarly good
performance, I'd like to know what the possible cause of the relative
slowdown on my computer is?

My system is an unladen 900MHz Athlon T-bird with 768Mb RAM running Debian
testing with SBCL 0.8.16 and CMUCL "19b-release-20050628-3 + minimal debian
patches". Other people have both slower and faster CPUs and more and less
RAM but all are consistently much faster than mine.

I believe SBCL always compiles to native code and I am asking CMUCL to
compile to native code with:

(compile-file "ray4.lisp")
(load "ray4.x86f")
(time (main 6.0 "image.pgm" 256.0 4.0))

Any ideas?

Also, I just tried running the ackermann and harmonic tests from the
shootout and they run at the same (fast) speed on my machine as on the
shootout's machine. So it seems the problem is specific to raytracing-like
code.

I'm completely stumped.

Have a look over in c.l.scheme for the uproar around this topic /
poster

(declaim (optimize (speed 3) (space 0) (debug 0) (safety 0)))

(defconstant infinity most-positive-single-float)
(defconstant delta (the single-float (sqrt single-float-epsilon)))

(declaim (inline vec v* v+ v- dot unitise ray vec make-ray make-sphere x y z
ray_trace))

(defstruct (vec (:conc-name nil) (:constructor vec (x y z)))
  (x 0.0 :type single-float)
  (y 0.0 :type single-float)
  (z 0.0 :type single-float))

(defun v* (s r)
  (declare (single-float s))
    (the vec (vec (* s (x r)) (* s (y r)) (* s (z r)))))

(defmacro defvfun (name op)
  `(defun ,name (a b)
    (vec (,op (x a) (x b))
         (,op (y a) (y b))
         (,op (z a) (z b)))))

(defvfun v+ +)
(defvfun v- -)

(defun dot (a b)
  (+ (* (x a) (x b)) (* (y a) (y b)) (* (z a) (z b))))

(defun unitise (r)
  (the vec (v* (/ 1 (the single-float (sqrt (dot r r)))) r)))

(defstruct (ray (:conc-name nil))
  (orig (vec 0.0 0.0 0.0) :type vec)
  (dir (vec 0.0 0.0 0.0) :type vec))

(defun ray (orig dir) (make-ray :orig orig :dir dir))

(defstruct (sphere (:conc-name nil))
  (center (vec 0.0 0.0 0.0) :type vec)
  (radius 0.0 :type single-float))

(shadow 'group)
(defstruct (group (:conc-name nil) (:include sphere))
  (children () :type list))

(defun ray_sphere (ray sphere)
  (let* ((v    (v- (center sphere) (orig ray)))
         (b    (dot v (dir ray)))
         (disc (+ (- (* b b) (dot v v)) (* (radius sphere) (radius
sphere)))))
    (if (< disc 0.0) infinity
        (let ((disc (sqrt disc)))
          (let ((t2 (+ b disc))
                (t1 (- b disc)))
            (cond ((< t2 0.0) infinity)
                  ((> t1 0.0) t1)
                  (t t2)))))))

(defun intersect (ray scene)
  (labels ((aux (hit scene)
             (destructuring-bind (lam . _) hit
               (declare (ignore _) (single-float lam))
               (etypecase scene
                 (group
                   (if (>= (ray_sphere ray scene) lam)
                       hit
                       (reduce #'aux (children scene) :initial-value hit)))
                 (sphere
                  (let ((lamt (ray_sphere ray scene)))
                    (if (>= lamt lam) hit
                        (cons lamt (unitise (v- (v+ (orig ray) (v* lamt (dir
ray))) (center scene)))))))))))
    (aux `(,infinity . (vec 0.0 0.0 0.0)) scene)))

(defun ray_trace (light ray scene)
  (destructuring-bind (lam . normal) (intersect ray scene)
    (declare (single-float lam))
    (if (= lam infinity) 0.0
      (let ((g (dot normal light)))
        (if (>= g 0.0) 0.0
          (let ((p (v+ (v+ (orig ray) (v* lam (dir ray))) (v* delta
normal))))
            (destructuring-bind (lam . _)
                (intersect (ray p (v* -1.0 light)) scene)
              (declare (ignore _) (single-float lam))
              (if (< lam infinity) 0.0 (- g)))))))))

(defun create (n c r)
  (declare (single-float r)
           (fixnum n))
  (let ((obj (make-sphere :center c :radius r)))
    (if (= n 1)
        obj
        (let ((rt (* 3.0 (/ r (sqrt 12.0)))))
          (labels ((aux (x z) (create (1- n) (v+ c (vec x rt z)) (/ r
2.0))))
            (make-group :center c
                        :radius (* 3.0 r)
                        :children (list* obj (mapcar #'aux
                                                     (list (- rt) rt (- rt)
rt)
                                                     (list (- rt) (- rt) rt
rt)))))))))

(defun main (level file-name n ss)
  (declare (fixnum level n ss))
  (let ((scene (create level (vec 0.0 -1.0 0.0) 1.0))
        (light (unitise (vec -1.0 -3.0 2.0)))
        (-n/2 (- (/ (float n) 2.0)))
        (1-n/2 (1- (/ (float n) 2.0))))
    (with-open-file (s
file-name :if-exists :supersede :if-does-not-exist :create :direction :output)
      (format s "P5~%~A ~A~%255~%" n n))
    (with-open-file (s file-name :element-type '(unsigned-byte
8) :if-exists :append :direction :output)
      (loop for y of-type single-float from 1-n/2 downto -n/2
            ;;do (sb-ext:gc-off)
            do (print y)
            do (loop for x of-type single-float from -n/2 to 1-n/2
            do (let ((g 0.0))
                 (declare (single-float g))
                 (loop for dx of-type single-float from x below (1+ x) by (/
1.0 ss)
                       do (loop for dy of-type single-float from y below (1+
y) by (/ 1.0 ss)
                                do (let ((d (unitise (vec dx dy (float
n)))))
                                     (incf g (ray_trace light (ray (vec 0.0
0.0 -4.0) d) scene)))))
                 (let ((g (+ 0.5 (* 255.0 (/ g (* (float ss) (float
ss)))))))
                   (write-byte (floor g) s))))))))

#+sbcl (setf (sb-ext:BYTES-CONSED-BETWEEN-GCS) 100000000)

(time (main 6 "image.pgm" 160 4))
(quit)

; cpu time (non-gc) 60,202 msec (00:01:00.202) user, 421 msec system
; cpu time (gc)     33,623 msec user, 10 msec system
; cpu time (total)  93,825 msec (00:01:33.825) user, 431 msec system
; real time  105,632 msec (00:01:45.632)
; space allocation:
;  967,240 cons cells, 3,719,472,272 other bytes, 4,472 static bytes

But converting all "single-float"  to double-float:

; cpu time (non-gc) 4,446 msec user, 120 msec system
; cpu time (gc)     2,524 msec user, 0 msec system
; cpu time (total)  6,970 msec user, 120 msec system
; real time  7,961 msec
; space allocation:
;  418,422 cons cells, 292,782,544 other bytes, 0 static bytes
The compiler complained about the "shadow" statement
warning: compile-file found "SHADOW" at the top-level --  see the
          documentation for
          comp:*cltl1-compile-file-toplevel-compatibility-p*

My guess is that much of the verbosity for the sbcl version could be struck
out of the allegro cl version without any loss in speed, and that careful attention
to other potential optimizations/ declarations could squeeze out better performance.

It could be that this single/double issue relates to your AMD64 timings.
Most of it may be converting single to double and back.

It is interesting that single vs double precision has such bizarre and (for
me) unexpected performance implications...

Another possible pitfall on older SBCLs (<0.8.21) is that they don't
honor the compiler policy for code entered on the repl, but compile it
with low speed, high debug/safety. If you've been pasting the code
into the repl instead of LOADing it, performance would indeed be
horrible.

| Right. Is Allegro CL free?

It has a free trial version.  <http://www.franz.com/>.

Thanks for the help. I'll repost when I get results with the new compiler.