apply のために vector を dynamic-extent なバッファに展開してようとしたけど、全然はやくなかった (Allegro CL)

applytest.lisp

#|
http://www.project-enigma.jp/2018-09-03-01.htm
|#

(in-package :cl-user)

(defun make-tuple (&rest args)
  (apply #'vector args))
(declaim (ftype (function (&rest t) simple-vector)
		make-tuple))

(defun apply-test-1 (fnc arr)
  (cl:apply fnc (coerce arr 'cl:list)))

(defun apply-test-2 (fnc arr)
  (let ((cnt (length arr)))
    (case cnt
      (2 (cl:funcall fnc (svref arr 0) (svref arr 1)))
      (3 (cl:funcall fnc (svref arr 0)
		     (svref arr 1) (svref arr 2)))
      (4 (cl:funcall fnc (svref arr 0) (svref arr 1)
		     (svref arr 2) (svref arr 3)))
      (t (cl:apply   fnc (coerce arr 'cl:list))))))

(defun apply-test-3 (fnc arr)
  (declare (optimize speed))
  (declare (type simple-vector arr))
  (let ((cnt (length arr)))
    (declare (type fixnum cnt))
    (case cnt
      (2 (cl:funcall fnc (svref arr 0) (svref arr 1)))
      (3 (cl:funcall fnc (svref arr 0)
		     (svref arr 1) (svref arr 2)))
      (4 (cl:funcall fnc (svref arr 0) (svref arr 1)
		     (svref arr 2) (svref arr 3)))
      (t (cl:apply fnc (coerce arr 'cl:list))))))

(defun apply-test-4 (fnc arr)
  (declare (optimize speed))
  (declare (type simple-vector arr))
  (let ((cnt (length arr)))
    (declare (type fixnum cnt))
    (case cnt
      (2 (locally (declare (type (simple-vector 2) arr))
	   (cl:funcall fnc (svref arr 0) (svref arr 1))))
      (3 (locally (declare (type (simple-vector 3) arr))
	   (cl:funcall fnc (svref arr 0)
		       (svref arr 1) (svref arr 2))))
      (4 (locally (declare (type (simple-vector 4) arr))
	   (cl:funcall fnc (svref arr 0) (svref arr 1)
		       (svref arr 2) (svref arr 3))))
      (t (cl:apply fnc (coerce arr 'cl:list))))))

(defconstant +apply-test-stack-allocation-limit+ 4)
(declaim (type fixnum +apply-test-stack-allocation-limit+))

(defun apply-test-dynamic-extent (fnc arr)
  (declare (optimize speed))
  (declare (type simple-vector arr))
  (let ((cnt (length arr)))
    (declare (type fixnum cnt))
    (if (<= cnt +apply-test-stack-allocation-limit+)
	(let ((tmp-args (make-list +apply-test-stack-allocation-limit+)))
	  (declare (type list tmp-args)
		   (dynamic-extent tmp-args))
	  (loop for i of-type fixnum from 0 below cnt
	     for c of-type cons on tmp-args
	     do (setf (car c) (svref arr i))
	     finally
	       (if (consp c)
		   (setf (cdr c) nil)))
	  (apply fnc tmp-args))
	(cl:apply fnc (coerce arr 'cl:list)))))

(defun test-func (a b c)
  (declare (optimize speed))
  (declare (type fixnum a b c))
  (the fixnum (+ a (the fixnum (+ b c)))))

(defun run ()
  (let ((tpl (make-tuple 111 222 333)))
    (dolist (apply-fnc (list #'apply-test-1
			     #'apply-test-2
			     #'apply-test-3
			     #'apply-test-4
			     #'apply-test-dynamic-extent))
      (pprint apply-fnc)
      (time (dotimes (i 1000000)
	      (funcall apply-fnc #'test-func tpl))))))

result_acl.txt

CL-USER> (run)

#<Function APPLY-TEST-1>
; cpu time (non-gc) 0.122817 sec user, 0.001942 sec system
; cpu time (gc)     0.010527 sec user, 0.000328 sec system
; cpu time (total)  0.133344 sec user, 0.002270 sec system
; cpu time (thread) 0.121317 sec user, 0.000739 sec system
; real time  0.133893 sec (101.3%)
; space allocation:
;  3,000,085 cons cells, 45,136 other bytes, 0 static bytes
; Page Faults: major: 0 (gc: 7), minor: 64 (gc: 7)

#<Function APPLY-TEST-2>
; cpu time (non-gc) 0.036421 sec user, 0.000090 sec system
; cpu time (gc)     0.000000 sec user, 0.000000 sec system
; cpu time (total)  0.036421 sec user, 0.000090 sec system
; cpu time (thread) 0.036421 sec user, 0.000091 sec system
; real time  0.036625 sec (99.69%)
; space allocation:
;  0 cons cells, 0 other bytes, 0 static bytes
; Page Faults: major: 0 (gc: 0), minor: 0 (gc: 0)

#<Function APPLY-TEST-3>
; cpu time (non-gc) 0.013385 sec user, 0.000013 sec system
; cpu time (gc)     0.000000 sec user, 0.000000 sec system
; cpu time (total)  0.013385 sec user, 0.000013 sec system
; cpu time (thread) 0.013384 sec user, 0.000012 sec system
; real time  0.013404 sec (99.96%)
; space allocation:
;  0 cons cells, 0 other bytes, 0 static bytes
; Page Faults: major: 0 (gc: 0), minor: 0 (gc: 0)

#<Function APPLY-TEST-4>
; cpu time (non-gc) 0.013391 sec user, 0.000012 sec system
; cpu time (gc)     0.000000 sec user, 0.000000 sec system
; cpu time (total)  0.013391 sec user, 0.000012 sec system
; cpu time (thread) 0.013391 sec user, 0.000014 sec system
; real time  0.013407 sec (99.97%)
; space allocation:
;  0 cons cells, 0 other bytes, 0 static bytes
; Page Faults: major: 0 (gc: 0), minor: 0 (gc: 0)

#<Function APPLY-TEST-DYNAMIC-EXTENT>
; cpu time (non-gc) 0.040420 sec user, 0.000154 sec system
; cpu time (gc)     0.000000 sec user, 0.000000 sec system
; cpu time (total)  0.040420 sec user, 0.000154 sec system
; cpu time (thread) 0.040063 sec user, 0.000076 sec system
; real time  0.040248 sec (100.8%)
; space allocation:
;  80 cons cells, 23,824 other bytes, 0 static bytes
; Page Faults: major: 0 (gc: 0), minor: 0 (gc: 0)
NIL
CL-USER>