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