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