1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:           PVC:386-COMP.SL
4% Title:          Compiler patterns for VAX PSL, plus a few cmacro expanders
5% Author:         Eric Benson
6% Created:        11 January 1982
7% Modified:       5 June 1984 (Vicki O'Day)
8% Status:         Open Source: BSD License
9% Mode:           Lisp
10% Package:        Compiler
11%
12% (c) Copyright 1982, University of Utah
13%
14% Redistribution and use in source and binary forms, with or without
15% modification, are permitted provided that the following conditions are met:
16%
17%    * Redistributions of source code must retain the relevant copyright
18%      notice, this list of conditions and the following disclaimer.
19%    * Redistributions in binary form must reproduce the above copyright
20%      notice, this list of conditions and the following disclaimer in the
21%      documentation and/or other materials provided with the distribution.
22%
23% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
24% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
25% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
26% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
27% CONTRIBUTORS
28% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
29% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
30% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
31% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
32% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
33% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34% POSSIBILITY OF SUCH DAMAGE.
35
36%
37%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
38%
39% Revisions:
40%
41% 17-Aug 1993 (Herbert Melenk)
42%   Introduced TVPAT-eq and TVPAT-tag for simple comparisons returning
43%   NIL/T.
44% 10-Aug 1993 (Herbert Melenk)
45%   Modified MODMEMPAT: update register database when aux register
46%   needed.
47% 22 April 1987 (Harold Carr)
48%   Moved *lambind, *jumpon, and *foreignlink cmacros (and support) from
49%   this file to vax-cmac.sl, where they belong.
50% 5 June 1984 (Vicki O'Day)
51%   Incorporated Utah change to make foreign functions be linked
52%   through SYMFNC.
53% 18-Jan-84 (Sam Sands)
54%   Hacked up so that FIELD will find what constant value it is getting
55%   if it is given a register.
56% 12-Jan-84 (Sam Sands)
57%   Added patterns 'CARCDRPAT and 'MEMORYPAT;  modified MODMEMPAT
58% 06-Dec-83 10:00 (Brian Beach)
59%   Translated from Rlisp to Lisp.
60%
61%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
62
63(PUT 'CARCDRPAT 'PATTERN
64  '(NIL NIL
65    ( ANY ('*RETURN (FN A1)))))
66
67(PUT 'MEMORYPAT 'PATTERN
68  '(NIL NIL
69    ((ANY CONST) ('*RETURN (FN A1 A2)))
70    ((REGNP ANY) ('*WPLUS2 A1 A2) ('*SET A1 ('*WPLUS2 A1 A2))
71                                  ('*RETURN (FN A1 ('WCONST '0))))
72    ((ANY REGNP) ('*WPLUS2 A2 A1) ('*SET A2 ('*WPLUS2 A2 A1))
73                                  ('*RETURN (FN A2 ('WCONST '0))))
74    ( ANY        ('*LOAD   T1 A1) ('*WPLUS2 T1 A2)
75                 ('*SET T1 ('*WPLUS2 T1 A2))
76                                  ('*RETURN (FN T1 ('WCONST '0))))
77    ))
78
79
80(commentoutcode
81
82(put 'tvpat 'pattern
83     '(!&regmem ('!*destroy dest)
84                ((dest any) (mac l1 a1 a2) ('!*load dest ''nil)
85                 ('!*jump l2) ('!*lbl l1) ('!*load dest ''t) ('!*lbl l2))
86                ((any dest) (mac l1 a1 a2) ('!*load dest ''nil)
87                 ('!*jump l2) ('!*lbl l1) ('!*load dest ''t) ('!*lbl l2))
88                ((usesdest any) (mac l1 a1 a2) ('!*load dest ''nil)
89                 ('!*jump l2) ('!*lbl l1) ('!*load dest ''t) ('!*lbl l2))
90                ((any usesdest) (mac l1 a1 a2) ('!*load dest ''nil)
91                 ('!*jump l2) ('!*lbl l1) ('!*load dest ''t) ('!*lbl l2))
92                (any ('!*load dest ''t) (mac l1 a1 a2)
93                     ('!*load dest ''nil) ('!*lbl l1))))
94)
95
96(compiletime (remprop 'nil-t-diff* 'constant!?))
97(fluid '(nil-t-diff*))
98(setq nil-t-diff* (difference (id2int nil)(id2int t)))
99(put 'nil-t-diff* 'constant!? t)
100
101(put 'tvpat 'pattern
102     '(!&regmem ('!*destroy dest)
103                ((dest any) (mac l1 a1 a2) ('!*load dest ''nil)
104                 ('!*jump l2) ('!*lbl l1) ('!*load dest ''t) ('!*lbl l2))
105                ((any dest) (mac l1 a1 a2) ('!*load dest ''nil)
106                 ('!*jump l2) ('!*lbl l1) ('!*load dest ''t) ('!*lbl l2))
107                ((usesdest any) (mac l1 a1 a2) ('!*load dest ''nil)
108                 ('!*jump l2) ('!*lbl l1) ('!*load dest ''t) ('!*lbl l2))
109                ((any usesdest) (mac l1 a1 a2) ('!*load dest ''nil)
110                 ('!*jump l2) ('!*lbl l1) ('!*load dest ''t) ('!*lbl l2))
111                (any ('!*load dest ''t) (mac l1 a1 a2)
112                     ('!*wplus2 dest '(wconst nil-t-diff*)) ('!*lbl l1))))
113
114
115(put 'tvpat1 'pattern
116     '(!&regmem ('!*destroy dest)
117                ((dest) (mac l1 a1 p2) ('!*load dest ''nil) ('!*jump l2)
118                 ('!*lbl l1) ('!*load dest ''t) ('!*lbl l2))
119                ((usesdest) (mac l1 a1 p2) ('!*load dest ''nil)
120                 ('!*jump l2) ('!*lbl l1) ('!*load dest ''t) ('!*lbl l2))
121                (any ('!*load dest ''t) (mac l1 a1 p2)
122                     ('!*load dest ''nil) ('!*lbl l1))))
123
124% similar to tvpat for eq/neq tests
125
126(put 'tvpat-eq 'pattern
127     '(!&regmem ('!*destroy dest)
128               (any ('*Wcmp a1 a2)
129                    ('!*load dest ''t)
130                    (&convert-mac l1)
131                    ('!*wplus2 dest '(wconst nil-t-diff*))
132                    ('!*lbl l1))))
133
134% similar to tvpat1 for tag tests
135
136(put 'tvpat-tag 'pattern
137     '(!&regmem ('!*destroy dest)
138                (any
139                       ('!*load dest a1)
140                       ('*wshift dest '-27)
141                       ('*wcmp dest p2)
142                       ('!*load dest ''t)
143                       (&convert-mac l1)
144                       ('!*wplus2 dest '(wconst nil-t-diff*))
145                       ('!*lbl l1))))
146
147
148% transform *JUMPTYPE/*JUMPEQ to JE, *JUMPNOTTYPE/*JUMPNOTEQ to JNE
149
150(put '&convert-mac 'substfn '&convert-mac)
151
152(de &convert-mac(arg args params)
153     (if (or (eq (cadr params) '*JUMPTYPE)
154             (eq (cadr params) '*JUMPEQ))
155         'je 'jne))
156
157(put 'tstpat 'pattern
158     '(nil !&fixregtest ((regn any) (mac dest a1 a2))
159           (any (mac dest a2 a1))))
160
161(put 'tstpatc 'pattern
162     '(nil !&setregs1 ((regn any) (mac dest a1 a2)) (any (p2 dest a2 a1))))
163
164(put 'tstpat2 'pattern '(nil !&setregs1 (any (mac dest a1 p2))))
165
166(put 'setqpat 'pattern
167     '(nil nil ((noval any notanyreg) ('!*store a2 a1))
168           ((noval dest any) ('!*store a2 dest))
169           ((noval usesdest any) ('!*load t1 a2) ('!*store t1 a1))
170           ((noval any any) ('!*load dest a2) ('!*store dest a1))
171           ((any dest) ('!*store dest a1)) ((dest any) ('!*store a2 dest))
172           ((usesdest any) ('!*store a2 a1) ('!*store a2 dest))
173           (any ('!*load dest a2) ('!*store dest a1))))
174
175(put 'rplacpat 'pattern
176     '(nil nil ((noval any any) ('!*store a2 (mac a1)))
177           ((dest any) ('!*store a2 (mac a1)))
178           ((usesdest any) ('!*store a2 (mac a1)) ('!*load dest a1))
179           ((any dest) ('!*store a2 (mac a1)) ('!*load dest a1))
180           ((any usesdest) ('!*store a2 (mac a1)) ('!*load dest a1))
181           (any ('!*load dest a1) ('!*store a2 (mac dest)))))
182
183(put 'assocpat 'pattern
184     '(nil ('!*set dest (fn a1 a2)) ((dest any) (mac a1 a2))
185           ((any dest) (mac a2 a1))
186           ((usesdest usesdest) ('!*load t1 a1) ('!*load dest a2)
187            (mac dest t1))
188           ((any usesdest) ('!*load dest a2) (mac dest a1))
189           (any ('!*load dest a1) (mac dest a2))))
190
191(put 'subpat 'pattern
192     '(nil ('!*set dest (fn a1 a2)) ((dest any) (mac a1 a2))
193           ((any dest) ('!*wminus dest dest) ('!*wplus2 a2 a1))
194           ((any usesdest) ('!*load t1 a2) ('!*load dest a1) (mac dest t1))
195           (any ('!*load dest a1) (mac dest a2))))
196
197(put 'nonassocpat 'pattern
198     '(nil ('!*set dest (fn a1 a2)) ((dest any) (mac a1 a2))
199           ((any usesdest) ('!*load t1 a2) ('!*load dest a1) (mac dest t1))
200           (any ('!*load dest a1) (mac dest a2))))
201
202(put 'fieldpat 'pattern
203     '(&constfieldargs  ('!*set dest (fn a1 a2 a3)) (any (mac dest a1 a2 a3))))
204
205(de &constfieldargs(args)
206  (cond ((registerp (second args))
207	 (&constfieldargs
208	  (list (first args) (&constregval (second args)) (third args))))
209        ((registerp (third args))
210	 (list (first args) (second args) (&constregval (third args))))
211	(t args)))
212
213(de &constregval (reg)
214  % Return a constant value known to be in the register, if any, otherwise
215  % just return the register.
216  (for (in value (&regval reg))
217       (do (when (&constp value)
218		 (return value)))
219       (returns reg)
220       ))
221
222(put 'putfieldpat 'pattern
223     '(nil nil ((noval any any any any) (mac a1 a2 a3 a4))
224           (any (mac a1 a2 a3 a4) ('!*store a1 dest))))
225
226(put 'unarypat 'pattern
227     '(!&noanyreg ('!*set dest (fn a1)) (any (mac dest a1))))
228
229(put 'modmempat 'pattern '(nil nil
230     ((NOVAL ANY ANY)      (mac a1 a2))
231     ((      ANY REGNP)    (P2  A2 LA1)
232                           ('*STORE A2 A1)
233                           ('*RETURN A2))
234     ( ANY                 ('*LOAD T2 A2)
235                           (P2  T2 LA1)
236                           ('!*set t2 (fn a1 a2)) % HM
237                           ('*STORE T2 A1)
238                           ('*RETURN T2))
239     ))
240
241(put 'modmempat1 'pattern '(nil nil (any (mac a1 a1))))
242
243% End of file.
244
245