1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PXU:VFVECT.SL 4% Description: very fast vector access 5% Author: H. Melenk 6% Created: 25 January 1989 7% Modified: 8% Mode: Lisp 9% Package: Utilities 10% Status: Open Source: BSD License 11% 12% Redistribution and use in source and binary forms, with or without 13% modification, are permitted provided that the following conditions are met: 14% 15% * Redistributions of source code must retain the relevant copyright 16% notice, this list of conditions and the following disclaimer. 17% * Redistributions in binary form must reproduce the above copyright 18% notice, this list of conditions and the following disclaimer in the 19% documentation and/or other materials provided with the distribution. 20% 21% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 22% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 23% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 24% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 25% CONTRIBUTORS 26% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 27% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 28% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 29% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 30% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 31% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32% POSSIBILITY OF SUCH DAMAGE. 33% 34%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 35% 36% this file is needed compiletime only 37% 38% This file defines a macro VFOR which has the same syntax as IFOR. 39% The basic difference is that VFOR looks into the body to be executed 40% and replaces all vector accesses via IgetV and IputV by references to 41% explicitly calculated addresses. 42(fluid '(*second-value* *variables*)) 43(fluid '(veccis gettis)) 44 45(dm vfor(u) 46 (prog (vars body cvar veccis gettis by from to lvars pvars zvars let 47 cvars *variables*) 48 (setq from (append (assoc 'from u) '(1))) 49 (setq by (caddr(cddr from))) 50 (setq to (cadddr from)) 51 (setq cvar (cadr from)) % control variable 52 (setq cvars (list cvar)) 53 (setq from (caddr from)) 54 (setq body (assoc 'do u)) 55 (when (null body) 56 (comperr "******* do clause missing in vfor expansion")) 57 (setq body (cadr body)) % strip off tag 'DO 58 (setq let (assoc 'let u)) 59 (when let (setq let (cdr let)) 60 (setq cvars (cons (car let) cvars)) 61 (setq body (subst (cadr let) (car let) body)) 62 (extract-variables (cadr let)) 63 (setq *variables* (delete cvar *variables*))) 64 (select-putv/getv body cvar) 65 (setq zvars (mapcar gettis (function 66 (lambda (x) (cons x (gensym)))))) 67 (setq pvars (cons cvar (mapcar zvars (function cdr)))) 68 (when let (setq pvars (cons (car let) pvars))) 69 70 % case 1: from is a number 71 (when (numberp from) 72 (return 73 `(prog ,pvars 74 (setq ,cvar ,from) 75 (progn . ,(mapcar zvars 76 (function (lambda (x) 77 `(setq ,(cdr x) 78 ,(vfor-simp 79 `(iplus2 (inf ,(caar x)) 80 (itimes2 addressingunitsperitem 81 (iplus2 ,(subst from cvar (cdar x)) 82 1))))))))) 83 84 ***loop*** 85 ,(if (greaterp by 0) 86 `(cond((igreaterp ,cvar ,to)(return NIL))) 87 `(cond((ilessp ,cvar ,to)(return NIL)))) 88 ,(reform-vfor body zvars) 89 (progn . ,(mapcar zvars 90 (function (lambda (x) 91 `(setq ,(cdr x) 92 ,(vfor-simp 93 ` (iplus2 ,(cdr x) 94 (itimes2 addressingunitsperitem 95 (idifference 96 ,(subst by cvar (cdar x)) 97 ,(subst 0 cvar (cdar x)) 98 ))))))))) 99 (setq ,cvar (iplus2 ,cvar ,by)) 100 (go ***loop***)))) 101 % case 2: from is an arbitrary expression 102 (return 103 `(prog ,pvars 104 (setq ,cvar ,from) 105 (progn . ,(mapcar zvars 106 (function (lambda (x) 107 `(setq ,(cdr x) 108 ,(vfor-simp 109 `(iplus2 (inf ,(caar x)) 110 (itimes2 addressingunitsperitem 111 (iplus2 ,(subst from cvar (cdar x)) 112 1))))))))) 113 ***loop*** 114 ,(if (greaterp by 0) 115 `(cond((igreaterp ,cvar ,to)(return NIL))) 116 `(cond((ilessp ,cvar ,to)(return NIL)))) 117 ,(reform-vfor body zvars) 118 (progn . ,(mapcar zvars 119 (function (lambda (x) 120 `(setq ,(cdr x) 121 ,(vfor-simp 122 `(iplus2 ,(cdr x) 123 (itimes2 addressingunitsperitem 124 (idifference 125 ,(subst by cvar (cdar x)) 126 ,(subst 0 cvar (cdar x)) 127 ))))))))) 128 (setq ,cvar (iplus2 ,cvar ,by)) 129 (go ***loop***))) 130 131)) 132 133(de select-putv/getv(form var) 134 (cond ((atom form) nil) 135 ((and (eqcar form 'iputv) (dependsof (caddr form) var)) 136 (setq gettis (union gettis (list (cons (cadr form) (caddr form))))) 137 (select-putv/getv (cadddr form) var)) 138 ((and (eqcar form 'igetv) (dependsof (caddr form) var)) 139 (setq gettis (union gettis (list (cons (cadr form) (caddr form)))))) 140 (t (mapc form (function (lambda(x)(select-putv/getv x var))))))) 141 142(de reform-vfor(form lvars) 143 (cond ((atom form) form) 144 ((and (eqcar form 'iputv)(assoc (cons (cadr form)(caddr form)) lvars)) 145 `(putmem ,(cdr (assoc (cons (cadr form)(caddr form)) lvars)) 146 ,(reform-vfor (cadddr form) lvars))) 147 ((and (eqcar form 'igetv)(assoc (cons (cadr form)(caddr form)) lvars)) 148 `(getmem ,(cdr (assoc (cons (cadr form)(caddr form)) lvars)))) 149 (t (mapcar form (function (lambda(x)(reform-vfor x lvars))))))) 150 151 152(de dependsof(form var) 153 % test if the form depends only linearly from var 154 (cond ((equal form var)t) 155 ((numberp form) t) 156 ((memq form *variables*) t) 157 ((and (atom form) (get form 'constant?)(numberp (eval form))) T) 158 ((atom form) nil) 159 ((eqcar form 'iplus2)(and (dependsof (cadr form) var) 160 (dependsof (caddr form) var))) 161 ((eqcar form 'idifference)(and (dependsof (cadr form) var) 162 (dependsof (caddr form) var))) 163 ((eqcar form 'itimes2) 164 (or (and (dependsof (cadr form) nil) 165 (dependsof (caddr form) var)) 166 (and (dependsof (cadr form) nil) 167 (dependsof (caddr form) var)))) 168 ((memq (car form) '(iadd1 isub1)) (dependsof (cadr form) var)) 169 (T nil))) 170 171(de extract-variables(u) 172 % extract the variables from an expression 173 (cond ((null u) *variables*) 174 ((numberp u) *variables*) 175 ((pairp u) (mapc (cdr u) (function extract-variables)) *variables*) 176 ((get u 'constant?) *variables*) 177 (t (setq *variables* (union (cons u nil) *variables*))))) 178 179(fluid '(*ioperators)) 180(setq *ioperators '((iplus2 . plus2)(idifference . difference) 181 (itimes2 . times2)(iquotient . quotient) 182 (isub1 . sub1)(iadd1 . add1))) 183 184(de vfor-simp (u) 185 % simplify an arithmetic expression based on i-operations 186 (cond ((null u) nil) 187 ((numberp u) u) 188 ((get u 'constant?) (eval u)) 189 ((atom u) u) 190 ((null (assoc (car u) *ioperators)) u) 191 (T (prog (o x y h) 192 (setq o (car u)) 193 (when (cdr u) (setq x (vfor-simp (cadr u))) 194 (when (cddr u) (setq y(vfor-simp (caddr u))))) 195 (when (and (eq o 'idifference) (numberp y)) 196 (setq o 'iplus2)(setq y (minus y))) 197 (when (and (numberp x)(numberp y)) 198 (return (apply (cdr (assoc o *ioperators)) 199 (list x y)))) 200 (when (and (memq o '(itimes2 iplus2)) (numberp x)) 201 (setq h x)(setq x y)(setq y h)) 202 (setq u(list o x y)) 203 (while (setq h (vfor-pat u)) (setq u (vfor-simp h))) 204 (return u))))) 205 206(fluid '(vfor-patterns*)) 207(setq vfor-patterns* '( 208 ( (iadd1 *a nil)(iplus2 *a 1)) 209 ( (isub1 *a nil)(iplus2 *a -1)) 210 ( (iplus2 (iplus2 *a *n)(iplus2 *b *m)) 211 (iplus2 (iplus2 *a *b)(iplus2 *n *m))) 212 ( (iplus2 (iplus2 *a *n) *m) (iplus2 *a (iplus2 *n *m))) 213 ( (iplus2 *a 0) *a) 214 ( (iplus2 *n *m)(eval (plus *n *m))) 215 ( (idifference *a 0) *a) 216 ( (idifference *a *a) 0) 217 ( (idifference *a (iplus2 *a *n)) (iminus *n)) 218 ( (idifference (iplus2 *a *n) *b) (idifference *a (iplus2 *b(iminus *n)))) 219 ( (idifference (idifference *a *b) (idifference *a *c)) 220 (idifference *c *b)) 221 ( (idifference (iplus2 *a *b) *a) *b) 222 ( (iminus *n) (eval (minus *n))) 223 224)) 225 226(de vfor-pat (u) 227 (prog (p q) 228 (setq p vfor-patterns*) 229 loop (when (null p)(return nil)) 230 (setq q(vfor-match u (caar p) (list nil))) 231 (when q (setq q (subla q (cadar p))) 232 (when (eqcar q 'eval) 233 (setq q (eval (cadr q)))) 234 (return q)) 235 (setq p (cdr p)) 236 (go loop))) 237 238(de vfor-match(u pat a) 239 (cond ((equal u pat) a) 240 ((memq pat '(*a *b *c *d *n *m)) (vfor-match-variable u pat a)) 241 ((or (atom u) (atom pat))nil) 242 ((setq a (vfor-match (car u)(car pat) a)) 243 (vfor-match (cdr u)(cdr pat) a)))) 244 245(de vfor-match-variable(u pat a) 246 (cond ((null (assoc pat a)) % not yet bound 247 (cond ((or (not (memq pat '(*n *m))) (numberp u)) 248 (nconc a (list (cons pat u)))) 249 (T nil))) 250 ((equal (cdr (assoc pat a)) u) a) 251 (T nil))) 252 253 254