From 93dcc8c2c76c7a5e546c8f2176f24c4e941892b5 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Wed, 19 Feb 1992 18:08:52 +0000 Subject: [PATCH] ;;; 11/9/90: ;;; Added some additional type declarations for maximum speed under certain ;;; Common Lisp compilers. --- benchmarks/cascor1.lisp | 184 ++++++++++++++++++---------------------- 1 file changed, 83 insertions(+), 101 deletions(-) diff --git a/benchmarks/cascor1.lisp b/benchmarks/cascor1.lisp index b7cc049b9..95acb52ce 100644 --- a/benchmarks/cascor1.lisp +++ b/benchmarks/cascor1.lisp @@ -46,8 +46,12 @@ ;;; Added CHANGED-TRAINING-SET, which should be called when the training set ;;; is changed but you don't want to reinitialize the net. This rebuilds ;;; the caches. +;;; +;;; 11/9/90: +;;; Added some additional type declarations for maximum speed under certain +;;; Common Lisp compilers. ;;; *************************************************************************** -;;; + ;;; This proclamation buys a certain amount of overall speed at the expense ;;; of runtime checking. Comment it out when debugging new, bug-infested code. (proclaim '(optimize (speed 3) (space 0) (safety 0))) @@ -55,15 +59,9 @@ ;;; Style note: Because some of these runs take a long time, this code is ;;; extensively hacked for good performance under a couple of Common Lisp ;;; systems, some of which have poor performance on multi-dimensional -;;; arrays and some of which have weak type-inference int he compiler. +;;; arrays and some of which have weak type-inference in the compiler. ;;; Elegance and clarity have in some cases been sacrificed for speed. -;;; The EXTENSIONS:*IGNORE-FLOATING-POINT-UNDERFLOW* switch, if non-null, -;;; says that floating point underflows should quietly return zero rather -;;; than signalling an error. If your Lisp does not have such a switch, -;;; you will either have to define an error handler for floating underflows -;;; or check for tiny values at various critical points of the code. - ;;; In some problems, floating point underflow errors may occur as a result ;;; of weight-decay and other operations. Most Common Lisp implementations ;;; have an option to turn floating underflows into zero values without @@ -76,10 +74,11 @@ ;;; Compensate for the clumsy Common Lisp declaration system and weak -;;; type-inference in some primitive Common Lisp compilers. INCF-SF, *SF, -;;; etc. are like INCF, *, etc., but they declare their operands and -;;; results to be short-floats. The code gets unreadable quickly if you -;;; insert all these declarations by hand. +;;; type-inference in some Common Lisp compilers. + +;;; INCF-SF, *SF, etc. are like INCF, *, etc., but they declare their +;;; operands and results to be short-floats. The code gets unreadable +;;; quickly if you insert all these declarations by hand. (defmacro incf-sf (place &optional (increment 1.0)) `(the short-float (incf (the short-float ,place) @@ -105,6 +104,12 @@ `(the short-float (/ ,@(mapcar #'(lambda (x) (list 'the 'short-float x)) args)))) +;;; DOTIMES1 is like DOTIMES, only with the loop counter declared as a +;;; fixnum. This is for compilers with weak type inference. + +(defmacro dotimes1 (form1 &body body) + `(dotimes ,form1 (declare (fixnum ,(car form1))) . ,body)) + ;;; Create vector-access forms similar to SVREF, but for vectors of ;;; element-type SHORT-FLOAT and FIXNUM. @@ -296,9 +301,9 @@ "Turned briefly to T in order to continue after a pause.") ;;; The sets of training inputs and outputs are stored in parallel vectors. -;;; Each element is a SIMPLE-VECTOR of short-float values, one for each -;;; input or output. Note: the elements are not specialized vectors of -;;; type SHORT-FLOAT. +;;; Each element is a SIMPLE-VECTOR holding short-float values, one for +;;; each input or output. Note: this is a simple vector, not a specialized +;;; vector of element-type short-float. (defvar *training-inputs* (make-array 0) "Vector of input patterns for training the net.") @@ -334,9 +339,11 @@ (defvar *test-inputs* nil "Vector of input patterns for testing the net.") +(proclaim '(simple-vector *test-inputs*)) (defvar *test-outputs* nil "Vector of output patterns for testing the net.") +(proclaim '(simple-vector *test-outputs*)) ;;;; Fundamental data structures. @@ -550,7 +557,7 @@ *cand-prev-slopes* (make-array *ncandidates* :initial-element nil)) ;; Only create the caches if *USE-CACHE* is on -- may not always have room. (when *use-cache* - (dotimes (i *max-cases*) + (dotimes1 (i *max-cases*) (setf (svref *values-cache* i) (make-array *max-units* :element-type 'short-float @@ -560,7 +567,7 @@ :element-type 'short-float :initial-element 0.0)))) ;; For each output, create the vectors holding per-weight information. - (dotimes (i *noutputs*) + (dotimes1 (i *noutputs*) (setf (svref *output-weights* i) (make-array *max-units* :element-type 'short-float @@ -579,7 +586,7 @@ :initial-element 0.0))) ;; For each candidate unit, create the vectors holding the correlations, ;; incoming weights, and other stats. - (dotimes (i *ncandidates*) + (dotimes1 (i *ncandidates*) (setf (svref *cand-cor* i) (make-array *noutputs* :element-type 'short-float @@ -617,47 +624,39 @@ ;; Set up the *ALL-CONNECTIONS* vector. (setq *all-connections* (make-array *max-units* :element-type 'fixnum)) - (dotimes (i *max-units*) - (declare (fixnum i)) + (dotimes1 (i *max-units*) (setf (ivref *all-connections* i) i)) ;; Initialize the active unit data structures. - (dotimes (i *max-units*) - (declare (fixnum i)) + (dotimes1 (i *max-units*) (setf (fvref *extra-values* i) 0.0) (setf (ivref *nconnections* i) 0) (setf (svref *connections* i) nil) (setf (svref *weights* i) nil) (setf (svref *output-weights-record* i) nil)) ;; Initialize the per-output data structures. - (dotimes (i *noutputs*) - (declare (fixnum i)) + (dotimes1 (i *noutputs*) (setf (fvref *outputs* i) 0.0) (setf (fvref *extra-errors* i) 0.0) (let ((ow (svref *output-weights* i)) (od (svref *output-deltas* i)) (os (svref *output-slopes* i)) (op (svref *output-prev-slopes* i))) - (dotimes (j *max-units*) - (declare (fixnum j)) + (dotimes1 (j *max-units*) (setf (fvref ow j) 0.0) (setf (fvref od j) 0.0) (setf (fvref os j) 0.0) (setf (fvref op j) 0.0)) ;; Set up initial random weights for the input-to-output connections. - (dotimes (j (1+ *ninputs*)) - (declare (fixnum j)) + (dotimes1 (j (1+ *ninputs*)) (setf (fvref ow j) (random-weight))))) ;; Initialize the caches if they are in use. (when *use-cache* - (dotimes (j *max-cases*) - (declare (fixnum j)) + (dotimes1 (j *max-cases*) (let ((v (svref *values-cache* j)) (e (svref *errors-cache* j))) - (dotimes (i *max-units*) - (declare (fixnum i)) + (dotimes1 (i *max-units*) (setf (fvref v i) 0.0)) - (dotimes (i *noutputs*) - (declare (fixnum i)) + (dotimes1 (i *noutputs*) (setf (fvref e i) 0.0))))) ;; Candidate units get initialized in a separate routine. (init-candidates) @@ -684,8 +683,7 @@ *errors-cache* (make-array *max-cases* :initial-element nil)) ;; Only create the caches if *USE-CACHE* is on -- may not always have room. (when *use-cache* - (dotimes (i *max-cases*) - (declare (fixnum i)) + (dotimes1 (i *max-cases*) (setf (svref *errors-cache* i) (make-array *noutputs* :element-type 'short-float @@ -718,7 +716,7 @@ ;; Asymmetric sigmoid in range 0.0 to 1.0. (cond ((< sum -15.0) 0.0) ((> sum 15.0) 1.0) - (t (/sf (+sf 1.0 (exp (-sf sum))))))) + (t (/sf 1.0 (+sf 1.0 (exp (-sf sum))))))) (:gaussian ;; Gaussian activation function in range 0.0 to 1.0. (let ((x (*sf -0.5 sum sum))) @@ -750,7 +748,7 @@ (ecase *output-type* (:sigmoid (cond ((< sum -15.0) -0.5) ((> sum 15.0) +0.5) - (t (-sf (/sf (+sf 1.0 (exp (-sf sum)))) 0.5)))) + (t (-sf (/sf 1.0 (+sf 1.0 (exp (-sf sum)))) 0.5)))) (:linear sum))) (defun output-prime (output) @@ -811,7 +809,8 @@ (setf (fvref deltas i) next-step) (setf (fvref weights i) (+sf w next-step)) (setf (fvref prevs i) s) - (setf (fvref slopes i) 0.0))) + (setf (fvref slopes i) 0.0) + nil)) ;;;; Machinery for training output weights. @@ -821,20 +820,18 @@ in the values vector." (declare (simple-vector input)) (setf (fvref *values* 0) 1.0) - (dotimes (i *ninputs*) - (declare (fixnum i)) + (dotimes1 (i *ninputs*) (setf (fvref *values* (1+ i)) (the short-float (svref input i))))) (defun output-forward-pass () "Assume the *VALUES* vector has been set up. Just compute the network's outputs." - (dotimes (j *noutputs*) - (declare (fixnum j)) + (dotimes1 (j *noutputs*) (let ((ow (svref *output-weights* j)) (sum 0.0)) (declare (short-float sum)) - (dotimes (i *nunits*) + (dotimes1 (i *nunits*) (incf-sf sum (*sf (fvref *values* i) (fvref ow i)))) (setf (fvref *outputs* j) (output-function sum))))) @@ -847,11 +844,11 @@ (w (svref *weights* j)) (sum 0.0)) (declare (short-float sum)) - (dotimes (i (ivref *nconnections* j)) - (declare (fixnum i)) + (dotimes1 (i (ivref *nconnections* j)) (incf-sf sum (*sf (fvref *values* (ivref c i)) (fvref w i)))) - (setf (fvref *values* j) (activation sum)))) + (setf (fvref *values* j) (activation sum)) + nil)) (defun full-forward-pass (input) "Set up the inputs from the INPUT vector, then propagate activation values @@ -878,8 +875,7 @@ OUTPUT-SLOPES-P is T, then use errors to compute slopes for output weights. If STATS-P is T, accumulate error statistics." (declare (simple-vector goal)) - (dotimes (j *noutputs*) - (declare (fixnum j)) + (dotimes1 (j *noutputs*) (let* ((out (fvref *outputs* j)) (dif (-sf out (svref goal j))) (err-prime (*sf dif (output-prime out))) @@ -898,8 +894,7 @@ (incf-sf *sum-error* err-prime) (incf-sf *sum-sq-error* (*sf err-prime err-prime)))) (when output-slopes-p - (dotimes (i *nunits*) - (declare (fixnum i)) + (dotimes1 (i *nunits*) (incf-sf (fvref os i) (*sf err-prime (fvref *values* i)))))))) ;;; Note: Scaling *OUTPUT-EPSILON* by the number of cases seems to keep the @@ -911,14 +906,12 @@ "Update the output weights, using the pre-computed slopes, prev-slopes, and delta values. Uses the quickprop update function." (let ((eps (/ *output-epsilon* *ncases*))) - (dotimes (j *noutputs*) - (declare (fixnum j)) + (dotimes1 (j *noutputs*) (let ((ow (svref *output-weights* j)) (od (svref *output-deltas* j)) (os (svref *output-slopes* j)) (op (svref *output-prev-slopes* j))) - (dotimes (i *nunits*) - (declare (fixnum i)) + (dotimes1 (i *nunits*) (quickprop-update i ow od os op eps *output-decay* *output-mu* *output-shrink-factor*)))))) @@ -959,13 +952,11 @@ "Store the output weights developed after each output-training phase in the *ouput-weights-record* vector." (let ((record (make-array *noutputs* :initial-element nil))) - (dotimes (o *noutputs*) - (declare (fixnum o)) + (dotimes1 (o *noutputs*) (let ((original (svref *output-weights* o)) (copy (make-array *nunits* :element-type 'short-float :initial-element 0.0))) - (dotimes (u *nunits*) - (declare (fixnum u)) + (dotimes1 (u *nunits*) (setf (fvref copy u) (fvref original u))) (setf (svref record o) copy))) (setf (svref *output-weights-record* (1- *nunits*)) record))) @@ -983,10 +974,9 @@ (first-time t)) (declare (fixnum quit-epoch) (short-float last-error)) - (dotimes (i max-epochs (progn + (dotimes1 (i max-epochs (progn (record-output-weights) :timeout)) - (declare (fixnum i)) ;; Maybe run a test epoch to see how we're doing. (when (and *test* (not (= 0 *test-interval*)) @@ -1014,8 +1004,7 @@ (defun init-candidates () "Give new random weights to all of the candidate units. Zero the other candidate-unit statistics." - (dotimes (i *ncandidates*) - (declare (fixnum i)) + (dotimes1 (i *ncandidates*) (setf (fvref *cand-sum-values* i) 0.0) (let ((cw (svref *cand-weights* i)) (cd (svref *cand-deltas* i)) @@ -1023,14 +1012,12 @@ (cp (svref *cand-prev-slopes* i)) (cc (svref *cand-cor* i)) (cpc (svref *cand-prev-cor* i))) - (dotimes (j *nunits*) - (declare (fixnum j)) + (dotimes1 (j *nunits*) (setf (fvref cw j) (random-weight)) (setf (fvref cd j) 0.0) (setf (fvref cs j) 0.0) (setf (fvref cp j) 0.0)) - (dotimes (o *noutputs*) - (declare (fixnum o)) + (dotimes1 (o *noutputs*) (setf (fvref cc o) 0.0) (setf (fvref cpc o) 0.0))))) @@ -1045,7 +1032,7 @@ ;; Copy the weight vector for the new unit. (let ((w (make-array *nunits* :element-type 'short-float)) (cw (svref *cand-weights* *best-candidate*))) - (dotimes (i *nunits*) + (dotimes1 (i *nunits*) (setf (fvref w i) (fvref cw i))) (setf (svref *weights* *nunits*) w) ;; Tell user about the new unit. @@ -1054,13 +1041,13 @@ ;; Fix up output weights for candidate unit. ;; Use minus the correlation times the *weight-multiplier* as an ;; initial guess. At least the sign should be right. - (dotimes (o *noutputs*) + (dotimes1 (o *noutputs*) (setf (fvref (svref *output-weights* o) *nunits*) (*sf (-sf (fvref (svref *cand-prev-cor* *best-candidate*) o)) *weight-multiplier*))) ;; If using cache, run an epoch to compute this unit's values. (when *use-cache* - (dotimes (i *max-cases*) + (dotimes1 (i *max-cases*) (setq *values* (svref *values-cache* i)) (compute-unit-value *nunits*))) ;; Reinitialize candidate units with random weights. @@ -1096,23 +1083,20 @@ unit and begin to compute the correlation between that unit's value and the error at each output. We have already done a forward-prop and computed the error values for active units." - (dotimes (u *ncandidates*) - (declare (fixnum u)) + (dotimes1 (u *ncandidates*) (let ((sum 0.0) (v 0.0) (cw (svref *cand-weights* u)) (cc (svref *cand-cor* u))) (declare (short-float sum v)) ;; Determine activation value of each candidate unit. - (dotimes (i *nunits*) - (declare (fixnum i)) + (dotimes1 (i *nunits*) (incf-sf sum (*sf (fvref cw i) (fvref *values* i)))) (setq v (activation sum)) (incf-sf (fvref *cand-sum-values* u) v) ;; Accumulate value of each unit times error at each output. - (dotimes (o *noutputs*) - (declare (fixnum o)) + (dotimes1 (o *noutputs*) (incf-sf (fvref cc o) (*sf v (fvref *errors* o))))))) ;;; Note: When we were computing true correlations between candidates and @@ -1133,16 +1117,14 @@ correlation score." (setq *best-candidate* 0) (setq *best-candidate-score* 0.0) - (dotimes (u *ncandidates*) - (declare (fixnum u)) + (dotimes1 (u *ncandidates*) (let* ((cc (svref *cand-cor* u)) (cpc (svref *cand-prev-cor* u)) (offset (*sf (fvref *cand-sum-values* u) *avg-error*)) (cor 0.0) (score 0.0)) (declare (short-float offset cor score)) - (dotimes (o *noutputs*) - (declare (fixnum o)) + (dotimes1 (o *noutputs*) (setq cor (/sf (-sf (fvref cc o) offset) *sum-sq-error*)) (setf (fvref cpc o) cor) (setf (fvref cc o) 0.0) @@ -1158,8 +1140,7 @@ "Given the correlation values for each candidate-output pair, compute the derivative of the candidate's score with respect to each incoming weight." - (dotimes (u *ncandidates*) - (declare (fixnum u)) + (dotimes1 (u *ncandidates*) (let* ((sum 0.0) (value 0.0) (actprime 0.0) @@ -1170,16 +1151,14 @@ (cpc (svref *cand-prev-cor* u))) (declare (short-float sum value actprime direction)) ;; Forward pass through each candidate unit to compute activation-prime. - (dotimes (i *nunits*) - (declare (fixnum i)) + (dotimes1 (i *nunits*) (incf-sf sum (*sf (fvref cw i) (fvref *values* i)))) (setq value (activation sum)) (setq actprime (activation-prime value sum)) ;; Now compute which way we want to adjust each unit's incoming ;; activation. - (dotimes (o *noutputs*) - (declare (fixnum o)) + (dotimes1 (o *noutputs*) (let ((error (fvref *errors* o))) (decf-sf direction (*sf (if (minusp (fvref cpc o)) -1.0 1.0) @@ -1190,8 +1169,7 @@ (incf-sf (fvref cc o) (*sf error value)))) ;; Given the direction we want to push the candidate, compute ;; which way we want to tweak each incoming weight. - (dotimes (i *nunits*) - (declare (fixnum i)) + (dotimes1 (i *nunits*) (incf-sf (fvref cs i) (*sf direction (fvref *values* i))))))) @@ -1205,14 +1183,12 @@ "Update the input weights, using the pre-computed slopes, prev-slopes, and delta values. Uses the quickprop update function." (let ((eps (/ *input-epsilon* (* *ncases* *nunits*)))) - (dotimes (u *ncandidates*) - (declare (fixnum u)) + (dotimes1 (u *ncandidates*) (let ((cw (svref *cand-weights* u)) (cd (svref *cand-deltas* u)) (cs (svref *cand-slopes* u)) (cp (svref *cand-prev-slopes* u))) - (dotimes (i *nunits*) - (declare (fixnum i)) + (dotimes1 (i *nunits*) (quickprop-update i cw cd cs cp eps *input-decay* *input-mu* *input-shrink-factor*)))))) @@ -1278,8 +1254,7 @@ (first-time t)) (declare (fixnum quit) (short-float last-score)) - (dotimes (i max-epochs :timeout) - (declare (fixnum i)) + (dotimes1 (i max-epochs :timeout) (train-inputs-epoch) (cond ((zerop *input-patience*)) (first-time @@ -1318,11 +1293,10 @@ (unless restart (init-net)) (list-parameters) (when *use-cache* - (dotimes (i *max-cases*) + (dotimes1 (i *max-cases*) (setq *values* (svref *values-cache* i)) (set-up-inputs (svref *training-inputs* i)))) - (dotimes (r rounds :lose) - (declare (fixnum r)) + (dotimes1 (r rounds :lose) (case (train-outputs outlimit) (:win (list-parameters) @@ -1357,7 +1331,7 @@ (*sum-error* 0.0) (*sum-sq-error* 0.0)) ;; Run all training patterns and count errors. - (dotimes (i (length *training-inputs*)) + (dotimes1 (i (length *training-inputs*)) (setq *goal* (svref *training-outputs* i)) (full-forward-pass (svref *training-inputs* i)) (compute-errors *goal* nil t)) @@ -1370,7 +1344,7 @@ (setq *sum-sq-error* 0.0) ;; Now run all test patterns and report the results. (when *test-inputs* - (dotimes (i (length *test-inputs*)) + (dotimes1 (i (length *test-inputs*)) (setq *goal* (svref *test-outputs* i)) (full-forward-pass (svref *test-inputs* i)) (compute-errors *goal* nil t))) @@ -1385,6 +1359,7 @@ (setq *nunits* nunits) (do ((i (1+ *ninputs*) (1+ i))) ((= i *nunits*)) + (declare (fixnum i)) (setf (ivref *nconnections* i) i) (setf (svref *connections* i) *all-connections*))) @@ -1402,7 +1377,7 @@ (setq *noutputs* 1) (let ((ti (make-array (* 2 n))) (to (make-array (* 2 n)))) - (dotimes (i n) + (dotimes1 (i n) (setf (svref ti (* i 2)) (vector (+ i 1.0))) (setf (svref to (* i 2)) @@ -1427,11 +1402,12 @@ (defun build-two-spirals (&optional (n 97)) "Build N point-pairs of the two-spiral problem, with standard default of 97 pairs." + (declare (fixnum n)) (setq *ninputs* 2) (setq *noutputs* 1) (let ((ti (make-array (* 2 n))) (to (make-array (* 2 n)))) - (dotimes (i n) + (dotimes1 (i n) (let* ((angle (/ (* i (coerce pi 'short-float)) 16.0)) (radius (/ (* 6.5 (- 104.0 i)) 104)) (x (* radius (sin angle))) @@ -1463,4 +1439,10 @@ ;;; IMu 2.00, IEps 100.00, IDcy 0.00000, IPat 8, IChange 0.030 ;;; Utype :SIGMOID, Otype :SIGMOID, RawErr NIL, Pool 8 +(defun time-two-spirals () + (setq *random-state* (make-random-state)) + (build-two-spirals) + (time (train 100 100 25))) + ;;; The End. + -- GitLab