1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% 4% File: PU:VFVECT.SL 5% Description: very fast vector access 6% Author: H. Melenk 7% Created: 25 January 1989 8% Modified: 9% Mode: Lisp 10% Package: Utilities 11% Status: Experimental 12% 13%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 14% 15% this file is needed compiletime only 16% 17% This file defines a macro VFOR which has the same syntax as IFOR. 18% The basic difference is that VFOR looks into the body to be executed 19% and replaces all vector accesses via IgetV and IputV by references to 20% explicitly calculated addresses. 21(fluid '(*second-value* *variables* *by* *cites* *cvar*)) 22(fluid '(veccis gettis)) 23 24(dm vfor(u) 25 (prog (vars body cvar veccis gettis by from to lvars pvars zvars let 26 cvars *variables* *cites*) 27 (setq from (append (assoc 'from u) '(1))) 28 (setq by (caddr(cddr from))) 29 (setq to (cadddr from)) 30 (setq cvar (cadr from)) % control variable 31 (setq cvars (list cvar)) 32 (setq from (caddr from)) 33 (setq body (assoc 'do u)) 34 (when (null body) 35 (comperr "******* do clause missing in vfor expansion")) 36 (setq body (vfor-macroexpand (cadr body))) % strip off tag 'DO 37 (setq let (assoc 'let u)) 38 (when let (setq let (cdr let)) 39 (setq cvars (cons (car let) cvars)) 40 (rplaca (cdr let) (vfor-macroexpand (cadr let))) 41 (setq body (subst (cadr let) (car let) body)) 42 (extract-variables (cadr let)) 43 (setq *variables* (delete cvar *variables*))) 44 (select-putv/getv body cvar) 45 (setq zvars (mapcar gettis (function 46 (lambda (x) (cons x (gensym)))))) 47 (setq pvars (cons cvar (mapcar zvars (function cdr)))) 48 (when let (setq pvars (cons (car let) pvars))) 49 50 (setq *by* by *cvar* cvar) 51 52 % case 1: from is a number 53 (when (numberp from) 54 (return 55 `(prog ,pvars 56 (setq ,cvar ,from) 57 (progn . ,(mapcar zvars 58 (function (lambda (x) 59 `(setq ,(cdr x) 60 ,(vfor-simp 61 `(iplus2 (inf ,(caar x)) 62 (itimes2 addressingunitsperitem 63 (iplus2 ,(subst from cvar (cdar x)) 64 1))))))))) 65 66 ***loop*** 67 ,(if (greaterp by 0) 68 `(cond((igreaterp ,cvar ,to)(return NIL))) 69 `(cond((ilessp ,cvar ,to)(return NIL)))) 70 ,(reform-vfor body zvars) 71 (progn . ,(mapcar zvars (function make-offset))) 72 (setq ,cvar (iplus2 ,cvar ,by)) 73 (go ***loop***)))) 74 % case 2: from is an arbitrary expression 75 (return 76 `(prog ,pvars 77 (setq ,cvar ,from) 78 (progn . ,(mapcar zvars 79 (function (lambda (x) 80 `(setq ,(cdr x) 81 ,(vfor-simp 82 `(iplus2 (inf ,(caar x)) 83 (itimes2 addressingunitsperitem 84 (iplus2 ,(subst from cvar (cdar x)) 85 1))))))))) 86 ***loop*** 87 ,(if (greaterp by 0) 88 `(cond((igreaterp ,cvar ,to)(return NIL))) 89 `(cond((ilessp ,cvar ,to)(return NIL)))) 90 ,(reform-vfor body zvars) 91 (progn . ,(mapcar zvars (function make-offset))) 92 (setq ,cvar (iplus2 ,cvar ,by)) 93 (go ***loop***))) 94 95)) 96 97(de make-offset(x) 98 % generate expression for updating an index variable. 99 % if the variable has been used only once, generate its 100 % update in place like a i++ expression in C. 101 (prog (offset r name) 102 (setq name (cdr x)) 103 (setq offset 104 (vfor-simp 105 `(itimes2 addressingunitsperitem 106 (idifference 107 ,(subst *by* *cvar* (cdar x)) 108 ,(subst 0 *cvar* (cdar x)))))) 109 % look if we have unique reference 110 (setq r (unique-reference name)) 111 (when (and r (null (cdr r))) % only for getv 112 (rplaca r 113 % `((lambda($$$)(setq ,name (iplus2 $$$ ,offset)) $$$) 114 % ,name) 115 `(wdifference (setq ,name (wplus2 ,name addressingunitsperitem)) 116 addressingunitsperitem) 117 ) 118 (return nil)) 119 (return 120 `(setq ,(cdr x) (iplus2 ,(cdr x) ,offset))))) 121 122(de unique-reference(v) 123 (let ((r (assoc v *cites*))) 124 (if (null (assoc v (delete r *cites*))) 125 r 126 nil))) 127 128(de select-putv/getv(form var) 129 (cond ((atom form) nil) 130 ((and (eqcar form 'iputv) (dependsof (caddr form) var)) 131 (setq gettis 132 (union gettis (list (cons (cadr form) (caddr form))))) 133 (select-putv/getv (cadddr form) var)) 134 ((and (eqcar form 'igetv) (dependsof (caddr form) var)) 135 (setq gettis 136 (union gettis (list (cons (cadr form) (caddr form)))))) 137 (t (mapc form (function (lambda(x)(select-putv/getv x var))))))) 138 139(de reform-vfor(form lvars) 140 (cond ((atom form) form) 141 ((and (eqcar form 'iputv) 142 (assoc (cons (cadr form)(caddr form)) lvars)) 143 (let (c) 144 (setq c 145 `(putmem 146 ,(cdr (assoc (cons (cadr form)(caddr form)) lvars)) 147 ,(reform-vfor (cadddr form) lvars))) 148 (push (cdr c) *cites*) 149 c)) 150 ((and (eqcar form 'igetv) 151 (assoc (cons (cadr form)(caddr form)) lvars)) 152 (let (c) 153 (setq c 154 `(getmem 155 ,(cdr (assoc (cons (cadr form)(caddr form)) lvars)))) 156 (push (cdr c) *cites*) 157 c)) 158 (t (mapcar form (function (lambda(x)(reform-vfor x lvars))))))) 159 160(de dependsof(form var) 161 % test if the form depends only linearly from var 162 (cond ((equal form var)t) 163 ((numberp form) t) 164 ((memq form *variables*) t) 165 ((and (atom form) (get form 'constant?)(numberp (eval form))) T) 166 ((atom form) nil) 167 ((eqcar form 'iplus2)(and (dependsof (cadr form) var) 168 (dependsof (caddr form) var))) 169 ((eqcar form 'idifference)(and (dependsof (cadr form) var) 170 (dependsof (caddr form) var))) 171 ((eqcar form 'itimes2) 172 (or (and (dependsof (cadr form) nil) 173 (dependsof (caddr form) var)) 174 (and (dependsof (cadr form) nil) 175 (dependsof (caddr form) var)))) 176 ((memq (car form) '(iadd1 isub1)) (dependsof (cadr form) var)) 177 (T nil))) 178 179(de extract-variables(u) 180 % extract the variables from an expression 181 (cond ((null u) *variables*) 182 ((numberp u) *variables*) 183 ((pairp u) 184 (mapc (cdr u) (function extract-variables)) *variables*) 185 ((get u 'constant?) *variables*) 186 (t (setq *variables* (union (cons u nil) *variables*))))) 187 188(fluid '(*ioperators)) 189(setq *ioperators '((iplus2 . plus2)(idifference . difference) 190 (itimes2 . times2)(iquotient . quotient) 191 (isub1 . sub1)(iadd1 . add1))) 192 193(de vfor-simp (u) 194 % simplify an arithmetic expression based on i-operations 195 (cond ((null u) nil) 196 ((numberp u) u) 197 ((get u 'constant?) (eval u)) 198 ((atom u) u) 199 ((null (assoc (car u) *ioperators)) u) 200 (T (prog (o x y h) 201 (setq o (car u)) 202 (when (cdr u) (setq x (vfor-simp (cadr u))) 203 (when (cddr u) (setq y(vfor-simp (caddr u))))) 204 (when (and (eq o 'idifference) (numberp y)) 205 (setq o 'iplus2)(setq y (minus y))) 206 (when (and (numberp x)(numberp y)) 207 (return (apply (cdr (assoc o *ioperators)) 208 (list x y)))) 209 (when (and (memq o '(itimes2 iplus2)) (numberp x)) 210 (setq h x)(setq x y)(setq y h)) 211 (setq u(list o x y)) 212 (while (setq h (vfor-pat u)) (setq u (vfor-simp h))) 213 (return u))))) 214 215(fluid '(vfor-patterns*)) 216(setq vfor-patterns* '( 217 ( (iadd1 *a nil)(iplus2 *a 1)) 218 ( (isub1 *a nil)(iplus2 *a -1)) 219 ( (iplus2 (iplus2 *a *n)(iplus2 *b *m)) 220 (iplus2 (iplus2 *a *b)(iplus2 *n *m))) 221 ( (iplus2 (iplus2 *a *n) *m) (iplus2 *a (iplus2 *n *m))) 222 ( (iplus2 *a 0) *a) 223 ( (iplus2 *n *m)(eval (plus *n *m))) 224 ( (idifference *a 0) *a) 225 ( (idifference *a *a) 0) 226 ( (idifference *a (iplus2 *a *n)) (iminus *n)) 227 ( (idifference (iplus2 *a *n) *b) 228 (idifference *a (iplus2 *b(iminus *n)))) 229 ( (idifference (idifference *a *b) (idifference *a *c)) 230 (idifference *c *b)) 231 ( (idifference (iplus2 *a *b) *a) *b) 232 ( (iminus *n) (eval (minus *n))) 233 234)) 235 236(de vfor-pat (u) 237 (prog (p q) 238 (setq p vfor-patterns*) 239 loop (when (null p)(return nil)) 240 (setq q(vfor-match u (caar p) (list nil))) 241 (when q (setq q (subla q (cadar p))) 242 (when (eqcar q 'eval) 243 (setq q (eval (cadr q)))) 244 (return q)) 245 (setq p (cdr p)) 246 (go loop))) 247 248(de vfor-match(u pat a) 249 (cond ((equal u pat) a) 250 ((memq pat '(*a *b *c *d *n *m)) (vfor-match-variable u pat a)) 251 ((or (atom u) (atom pat))nil) 252 ((setq a (vfor-match (car u)(car pat) a)) 253 (vfor-match (cdr u)(cdr pat) a)))) 254 255(de vfor-match-variable(u pat a) 256 (cond ((null (assoc pat a)) % not yet bound 257 (cond ((or (not (memq pat '(*n *m))) (numberp u)) 258 (nconc a (list (cons pat u)))) 259 (T nil))) 260 ((equal (cdr (assoc pat a)) u) a) 261 (T nil))) 262 263(de vfor-macroexpand(u) 264 (cond 265 ((atom u)u) 266 ((eq (get (car u) 'type) 'macro) 267 (vfor-macroexpand (apply (car u) (list u)))) 268 (t (cons (car u) 269 (mapcar (cdr u) (function vfor-macroexpand)))) )) 270