gistfile1.lisp

(defparameter *p1* 2d0)

(defparameter *p2* 3d0)

(defparameter *p3* 4)

(declaim (fixnum *p3*)
         (double-float *p1* *p2*))

(defun main ()
  (let ((w (make-array 16 :element-type 'fixnum :initial-contents
                       '(1000 850 750 600 400 320 280 200 120 80 45 25 15 10 8 2)))
        (k (make-array 16 :element-type 'single-float :initial-contents
                       '(0.001 0.001 0.001 0.002 0.0035 0.00441 0.001 0.0001 0.015
                         0.016 0.0001 0.001 0.001 0.001 0.0015 0.0014)))
        (r (make-array 3 :element-type 'double-float)))
    (time
     (dotimes (i (expt 10 6))
       (other w k r)))))

(defmacro my-fmod (a b)
  (let ((as (gensym)) (bs (gensym)) (rs (gensym)))
    `(let* ((,as ,a)
            (,bs ,b)
            (,rs (sb-alien:alien-funcall (sb-alien:extern-alien "fmod" (sb-alien:function sb-alien:double sb-alien:double sb-alien:double))
                                         ,as
                                         ,bs)))
       (declare (type double-float ,as ,bs ,rs))
       ,rs)))

(defun other (w k r)
  (declare (optimize (speed 3) (safety 0) (debug 0) (space 0))
           ((simple-array fixnum) w)
           ((simple-array single-float) k)
           ((simple-array double-float (3)) r))
  (let* ((w[0] (aref w 0))
         (k[0] (aref k 0))
         (mw-pre (random w[0]))
         (sw-pre (mod mw-pre *p3*))
         (mw (coerce mw-pre 'double-float))
         (sw (coerce sw-pre 'double-float)))
    (declare (fixnum mw-pre sw-pre w[0])
             (single-float k[0])
             (double-float mw sw))
    (dotimes (i (length w))
      (let ((w[i] (aref w i))
            (k[i] (coerce (aref k i) 'double-float)))
        (declare (fixnum w[i])
                 (double-float k[i]))
        (setf mw (+ mw (* w[i] k[i])))
        (setf sw (+ 1 (/ w[i] k[i])))))
    (setf mw (- (my-fmod mw *p1*) (* 4.013d0 k[0])))
    (let ((r0 mw)
          (r1 (my-fmod (- mw (random w[0])) *p2*))
          (r2 (my-fmod sw *p2*)))
      (declare (double-float r0 r1 r2))
      (setf (aref r 0) r0)
      (setf (aref r 1) r1)
      (setf (aref r 2) r2)))
  nil)