root/trunk/lisp/lispm/maopt.lisp @ 226

Revision 226, 25.2 KB (checked in by rjs, 3 years ago)

Initial versions.

Line 
1;-*- MODE: LISP; PACKAGE: COMPILER; BASE: 8 -*-
2;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
3
4; these should probably eventually go in DEFMIC
5(DEFPROP %DATA-TYPE DTP-FIX RESULT-DATA-TYPE)
6(DEFPROP M-EQ T-OR-NIL RESULT-DATA-TYPE)
7(DEFPROP M-=  T-OR-NIL RESULT-DATA-TYPE)
8
9
10;An optimization is a several-to-several source to source transformation in MCLAP.
11; It is expressed in pattern - action form.
12; The pattern spans some number of instructions, and can match against various aspects
13;  of the instruction including code and operands.
14; The action corresponds with the pattern and usually acts on the matched code.
15
16;Optimization pattern matching "language"
17; a list of transformations each of which is
18;   a list whose first element is
19;     a list each element of which is to be matched the code of an instruction.
20;   whose second element is
21;     a list of actions, the elements of which are corresponded with matched instructions
22
23;Pattern variables are denoted by (== <name> <restriction predicates> ..).
24; <name> can be a list, see discussion of name chaining below.
25; Similiar to most pattern matching languages, pattern variables start out unassigned.
26;   The first time the variable is seen, it becomes assigned to whatever it was matched
27;   against.  If the same variable is seen again, it must be matched against EQUAL
28;   list structure to its assignment in order for the match to succeed.
29; The following pattern variables are special:
30;   ? matches anything, always.
31;   *INST* is the instruction being matched.
32;   *FUNCTION-ARG* is the argument to the current function.
33; <restriction predicates> are LISP expressions.  However, the proposed value for
34;   the variable is "stuck in" as the first arg.  For example, (MEMQ (JUMP JUMP-NOT-EQUAL))
35;   would restrict the variable to matching one of those symbols.
36; Non-NIL symbols in the CDR position of lists are also pattern variables.
37
38;variable chaining or "non-atomic" variables.
39; The MAP-MATCH construct matches a single pattern to each of the members of a list.
40;For example, the list of instructions that can preceed the current one.
41; Since the same pattern is being reused multiple times, a mechanism
42;is needed to "index" the variables, otherwise, they would be shared between all
43;matches.  This capability is provided by associating a control variable
44;with the MAP-MATCH, then using this variable as part of a chained
45;variable name.  Since the control variable will change as the MAP-MATCH
46;progresses, this provides unique variables for each application
47;of the pattern. 
48;  The variable *namechain* is the list of the control variables of currently
49;nested MAP-MATCHs.  This chain is postfixed by default to all generated
50;pattern variables with names that are symbols.  With a pattern variable whose
51;name is a list, this postfixing can be suppressed or modified.  In particular,
52;(== (= foo)) suppresses all prefixing, and references foo.
53;(== (* foo)) cdr's *namechain* before postfixing, thus referencing the previous
54;"lexical" level.
55;  When the variable is "seen", all symbols but the first are replaced
56;with their current values, thus forming the desired name.  Note chained variables
57;cannot be used in the dotted REST position, since they could not be recognized.
58;However, an ordinary variable can be used to receive the value, and then the value
59;moved into a "safe" chained variable via LET.
60
61; MATCH-FUNCTIONs allow recursive patterns as well as "subroutinizing" pattern expressions.
62;The "argument" of the function is the new binding for *namechain*.
63; Similarily to a optimization, MATCH-FUNCTION has two parts, a pattern part
64;and an action part.
65
66
67; MATCH-CASE provides an OR capability (without duplicating the entire pattern).
68;Furthermore, a control variable is associated which gets set to the path number
69;that was successful.  This variable is then available at ACTION time to select
70;a corresponding ACTION via PUT-CASE.
71
72(DEFCONST *MA-OPT-TRACE-VARS* NIL)      ;print when vars on this list assigned.
73(DEFCONST *MA-OPT-TRACE-ACTS* NIL)
74(DEFCONST *MA-OPT-MATCH-TRACE* NIL)
75(DEFCONST *MA-OPT-PRINT-INPUT* NIL)
76
77(DEFVAR *NAMECHAIN* NIL)                ;postfixed to pattern variables, see above.
78
79(DEFCONST *MA-OPTIMIZATIONS* '(
80  ;flush move to self
81    ( ( ((CODE (MOVE (== O) (== O))  )) )
82      ( ((FLUSH) )            ) )
83  ;combine push followed immediately by pop.
84    ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S) . REST) ))
85        ((CODE (MOVE (== D) (PDL-POP)) )) )
86      ( ((FLUSH))
87        ((PUT  (MOVE (== D) (== S) . REST)))  ) )
88  ;combine move x s, ... move d,x where ... is within sequence and doesnt clobber x.
89    ( ( ((CODE (MOVE (== D) (== X (SYMBOLP))))
90         (OP1-LIST (MA-ONE-AND-ONLY-USE-P))
91         (LET I2 (== *INST*))
92         (LET-APPLY-TEST I1 (MA-OP1-SOURCE-INST (== *INST*)))
93         (MATCH (== I1)
94                ((PRED (MA-SAME-SEQUENCE (== *INST*) (== I2)))
95                 (CODE (MOVE (== X) (== S) . REST))
96                 (MAP-RANGE (== *INST*) (== I2) (== D) NO-REFERENCE)
97                 (MAP-RANGE (== *INST*) (== I2) (== X) NO-CLOBBER)))))
98      ( ((FLUSH)
99         (PUT-INST (== I1)
100                   ((PUT (MOVE (== D) (== S) . REST)))))))
101  ;combine MOVE into following JUMP if arg can live in A-MEM. 
102    ( ( ((CODE (MOVE (== R) (== O (MA-CAN-LIVE-IN-A-MEM))))
103         (RESULT-OP (MA-OPERAND-ONE-USE-P)))   ;not used elsewhere
104        ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) (== M) (== R) (UTAG (== TAG)))) ) )
105      ( ((FLUSH))
106        ((PUT  ((== I) (== M) (== O) (UTAG (== TAG)))))))
107  ;flush lossage if a (MOVE T (PDL-POP)) is reached only by
108  ;              (MOVE (PDL-PUSH) T)  or
109  ;              (MOVE (PDL-PUSH) T) (JUMP ..) or
110  ;              (MOVE (PDL-PUSH) T) (<CONDITIONAL-JUMP> T ..>) (DISCARD-TOP-OF-STACK)
111  ;This happens quite frequently, due to CONDs.
112
113    ( ( ((CODE (MOVE T (PDL-POP)))
114         (MATCH-FUNCTION OP-IN-T-AND-PDL ?)))
115     (  ((MATCH-FUNCTION OP-IN-T-AND-PDL ?)
116         (FLUSH))))
117))
118
119;If there is a PUSH-PDL in all paths to the current instruction, factor
120;it out and leave the result in T instead.  If a non-? argument is supplied,
121;it is a source which must have the same data as was pushed, or, in other
122;words, the push must have been a (MOVE (PUSH-PDL ?) <source>).  This is of
123;interest when <source> is being tested by a conditional jump.
124(DEFPROP OP-IN-T-AND-PDL
125   ( ((LET IN (== *INST*))
126      (MAP-MATCH %%1 (MA-PRECEEDING-INSTS-LIST)
127        ((MATCH-CASE OP
128            ( ((CODE (MOVE (PUSH-PDL (== ?)) (== SOURCE)))       ;drop thru
129               (PRED (MA-MATCH-EQUAL (== (* *FUNCTION-ARG*))
130                                     (== SOURCE))))
131              ((CODE (JUMP NIL NIL (UTAG (== TAG))))             ;unconditional jump
132               (MATCH-FUNCTION OP-IN-T-AND-PDL (== (* *FUNCTION-ARG*))))
133              ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL)))  ;conditional jump
134                      T
135                      (== A)
136                      (UTAG (== TAG))))
137               (MATCH-FUNCTION OP-IN-T-AND-PDL T)
138               (MAP-MATCH %%2 (MA-FOLLOWING-INSTS-LIST)
139                          ((MATCH-CASE C
140                               ( ((PRED (EQ (== *INST*) (== (* (* IN))))))
141                                 ((CODE (DISCARD-TOP-OF-STACK))))))))
142             )) )))
143     ((MAP-PUT %%1 (MA-PRECEEDING-INSTS-LIST)
144         ((PUT-CASE OP
145            ( ((PUT (MOVE T (== SOURCE))))                       ;drop thru
146              ((MATCH-FUNCTION OP-IN-T-AND-PDL
147                               (== (* *FUNCTION-ARG*))))         ;unconditional jump
148              ((MATCH-FUNCTION OP-IN-T-AND-PDL T)                ;conditional jump
149               (MAP-PUT %%2 (MA-FOLLOWING-INSTS-LIST)
150                        ((PUT-CASE C
151                           ( ()
152                            ((FLUSH)))))))))))))
153   MA-OPT-FUNCTION)
154
155(DEFPROP M-EQ (
156  ;open code EQ
157    ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S))))
158        ((CODE (CALL (POPS 2) (== ?) (MISC-ENTRY M-EQ))))
159        ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) T A-V-NIL (UTAG (== TAG))))
160         (OP1-LIST (MA-ONE-AND-ONLY-USE-P))) )
161      ( ((PUT  (MOVE C (PDL-POP))))
162        ((PUT  (MOVE B (== S))) )
163        ((PUT  ((== I (MA-INVERT (JUMP-EQUAL JUMP-NOT-EQUAL))) C B (UTAG (== TAG)))))   ) )
164    )
165    MA-OPTIMIZATIONS)
166
167(DEFPROP M-= (
168  ;open code =.  Must know both operands are fixnums.
169    ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S) . REST)))
170        ((CODE (CALL (POPS 2) (== ?) (MISC-ENTRY M-=)))
171         (STACK-OPERANDS-MAP (MA-OPERAND-FIX-P NIL)))
172        ((CODE ((== I (MEMQ (JUMP-EQUAL JUMP-NOT-EQUAL))) T A-V-NIL (UTAG (== TAG))))
173         (OP1-LIST (MA-ONE-AND-ONLY-USE-P))) )
174      ( ((PUT  (MOVE C (PDL-POP))))
175        ((PUT  (MOVE B (== S) . REST)) )
176        ((PUT  ((== I (MA-INVERT (JUMP-EQUAL JUMP-NOT-EQUAL))) C B (UTAG (== TAG)))))   ) )
177    )
178    MA-OPTIMIZATIONS)
179
180(DEFPROP %DATA-TYPE (
181    ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S))))
182        ((CODE (CALL (POPS 1) (== ?) (MISC-ENTRY %DATA-TYPE)))) )
183      ( ((PUT  (MOVE T (== S) (DTP-FIX 5 24.))))
184        ((FLUSH)) ) ))
185    MA-OPTIMIZATIONS)
186
187(DEFPROP %POINTER (
188    ( ( ((CODE (MOVE (PUSH-PDL (== ?)) (== S))))
189        ((CODE (CALL (POPS 1) (== ?) (MISC-ENTRY %POINTER)))) )
190      ( ((PUT  (MOVE T (== S) (DTP-FIX 24. 0))))
191        ((FLUSH)) ) ))
192    MA-OPTIMIZATIONS)
193
194(DEFUN MA-OPTIMIZE NIL
195  (PROG (*MA-OPT-FLAG*)
196        (IF *MA-OPT-PRINT-INPUT*
197            (MA-PRINT-CODE))
198        (DOLIST (SEQ *MA-SEQUENCES*)
199          (MA-OPT-SEQUENCE SEQ))
200        (RETURN *MA-OPT-FLAG*)))
201
202(DEFUN MA-OPT-SEQUENCE (*SEQ*)
203 (*CATCH 'OPT-SEQUENCE
204        (PROG (INSTS MISC-ENTRIES CODE)
205              (SETQ INSTS (MA-ELEM-MEMBERS *SEQ*))
206              (DOLIST (I INSTS)         ;misc-entries gets all such that appear in seq.
207                (COND ((NOT (SYMBOLP I))
208                       (SETQ CODE (MA-INST-CODE I))
209                       (COND ((AND (LISTP CODE)
210                                   (EQ (CAR CODE) 'CALL)
211                                   (LISTP (CAR (LAST CODE)))
212                                   (EQ (CAAR (LAST CODE)) 'MISC-ENTRY))
213                              (SETQ MISC-ENTRIES (CONS (CADAR (LAST CODE)) MISC-ENTRIES)))))))
214           L    (COND ((NULL INSTS) (RETURN NIL)))
215              (MA-OPT-MATCH-LIST INSTS *MA-OPTIMIZATIONS*)
216              (DOLIST (ME MISC-ENTRIES)
217                (MA-OPT-MATCH-LIST INSTS (GET ME 'MA-OPTIMIZATIONS)))
218              (SETQ INSTS (CDR INSTS))
219              (GO L))))
220
221(DEFUN MA-OPT-MATCH-LIST (INSTS OPT-LIST)
222  (DOLIST (OPT OPT-LIST)
223    (LET ((PATTERN (CAR OPT))
224          (ACTIONS (CADR OPT)))
225      (IF (>= (LENGTH INSTS) (LENGTH PATTERN))
226          (MULTIPLE-VALUE-BIND (MATCH-P ALIST)
227              (MA-OPT-MATCH INSTS PATTERN NIL)
228            (IF MATCH-P
229                (MA-OPT-ACT INSTS ACTIONS ALIST)))))))
230
231(DEFUN MA-OPT-MATCH (INSTS PATTERN ALIST)
232 (PROG (MATCH-P P I)
233    L  (COND ((NULL PATTERN)
234              (RETURN T ALIST))
235             ((NULL INSTS)      ;should not get here unless enuf insts to maybe win
236              (FERROR NIL "insts too short"))) 
237       (SETQ P (CAR PATTERN)
238             I (CAR INSTS))
239       (MULTIPLE-VALUE (MATCH-P ALIST)
240         (MA-OPT-MATCH-INST I P ALIST NIL))
241       (COND ((NULL MATCH-P) (RETURN NIL ALIST)))
242       (SETQ INSTS (CDR INSTS)
243             PATTERN (CDR PATTERN))
244       (GO L)))
245
246(DEFUN MA-OPT-MATCH-INST (*INST* *PATTERN* *ALIST* *NAMECHAIN*)
247 (LET ((*MA-OPT-MATCH-TRACE* *MA-OPT-MATCH-TRACE*))
248  (PROG (MATCH-P P-ELEM FCTN)
249        (COND ((NULL *INST*) (RETURN NIL *ALIST*)))
250        (COND (*MA-OPT-MATCH-TRACE*
251               (FORMAT T "~% begin match ~S, pat ~S, alist ~s" *INST* *PATTERN* *ALIST*)))
252     L  (COND ((NULL *PATTERN*)
253               (COND (*MA-OPT-MATCH-TRACE*
254                      (FORMAT T "~% match on ~s succeeded" *INST*)))
255               (RETURN T *ALIST*)))
256        (SETQ P-ELEM (CAR *PATTERN*))
257        (IF (NULL (SETQ FCTN (GET (CAR P-ELEM) 'MA-OPT-MATCHER)))
258            (FERROR NIL "unknown type match")
259            (SETQ MATCH-P (FUNCALL FCTN (CDR P-ELEM))))
260        (COND ((NULL MATCH-P)
261               (COND (*MA-OPT-MATCH-TRACE*
262                      (FORMAT T "~% match on ~S failed, P-ELEM ~S" *INST* P-ELEM)))
263               (RETURN NIL *ALIST*)))
264        (SETQ *PATTERN* (CDR *PATTERN*))
265        (GO L))))
266
267(DEFUN (CODE MA-OPT-MATCHER) (PAT)
268   (MA-OPT-MATCH-WD (MA-INST-CODE *INST*)
269                         (CAR PAT)))
270
271(DEFUN (OP1 MA-OPT-MATCHER) (PAT)
272       (AND (NULL (MA-INST-CHANGED *INST*))
273            (NULL (DOLIST (OP (CDR (MA-INST-OP1 *INST*)))  ;pred must be true of
274                    (COND ((NULL (MA-OPT-APPLY OP (CAR PAT)))
275                           (RETURN T)))))))     ;all possibilities
276
277(DEFUN (OP2 MA-OPT-MATCHER) (PAT)
278  (AND (NULL (MA-INST-CHANGED *INST*))
279       (NULL (DOLIST (OP (CDR (MA-INST-OP2 *INST*)))
280               (COND ((NULL (MA-OPT-APPLY OP (CAR PAT)))
281                      (RETURN T)))))))
282
283(DEFUN (RESULT-OP MA-OPT-MATCHER) (PAT)
284  (MA-OPT-APPLY-INST (MA-INST-RESULT-OPERAND *INST*)
285                          (CAR PAT)))
286
287(DEFUN (OP1-LIST MA-OPT-MATCHER) (PAT)
288  (MA-OPT-APPLY-INST (CDR (MA-INST-OP1 *INST*)) (CAR PAT)))
289
290(DEFUN (OP2-LIST MA-OPT-MATCHER) (PAT)
291  (MA-OPT-APPLY-INST (CDR (MA-INST-OP2 *INST*)) (CAR PAT)))
292
293(DEFUN (STACK-OPERANDS-MAP MA-OPT-MATCHER) (PAT)
294  (AND (NULL (MA-INST-CHANGED *INST*))
295       (NULL (*CATCH 'VAL
296                     (DOLIST (OPL (MA-INST-OP1 *INST*))
297                       (DOLIST (OP (CDR OPL))
298                         (COND ((NULL (MA-OPT-APPLY
299                                        OP
300                                        (CAR PAT)))
301                                (*THROW 'VAL T)))))))))
302(DEFUN (LET MA-OPT-MATCHER) (PAT)
303  (MA-OPT-LET (CAR PAT) (CADR PAT))
304  T)
305
306(DEFUN MA-OPT-LET (SYM VAL)
307  (LET ((ISYM (MA-OPT-EXPAND-CHAIN-VAR SYM)))
308    (SETQ *ALIST* (CONS (CONS ISYM
309                              (MA-OPT-SUBS VAL))
310                      *ALIST*))))
311
312(DEFUN (LET-APPLY-TEST MA-OPT-MATCHER) (PAT)
313  (LET ((SYM (MA-OPT-EXPAND-CHAIN-VAR (CAR PAT))))
314    (LET* ((EXP (MA-OPT-SUBS (CADR PAT)))
315           (VAL (APPLY (CAR EXP) (CDR EXP))))
316      (IF (NULL VAL)
317          NIL
318          (SETQ *ALIST* (CONS (CONS SYM VAL) *ALIST*))
319          T))))
320
321(DEFUN (MATCH MA-OPT-MATCHER) (PAT)
322  (MULTIPLE-VALUE (NIL *ALIST*)
323    (MA-OPT-MATCH-INST (MA-OPT-SUBS (CAR PAT))
324                            (CADR PAT)
325                            *ALIST*
326                            *NAMECHAIN*)))
327
328
329(DEFUN (MAP-MATCH MA-OPT-MATCHER) (PAT)
330  (PROG (CONTROL-VAR CONTROL-VAR-PNTR LIST-TO-MAP PATTERN)
331        (SETQ CONTROL-VAR (CAR PAT)
332              LIST-TO-MAP (MA-OPT-APPLY *INST* (CADR PAT))
333              PATTERN (CADDR PAT))
334        (SETQ CONTROL-VAR (MA-OPT-EXPAND-CHAIN-VAR CONTROL-VAR))
335        (SETQ *ALIST* (CONS (SETQ CONTROL-VAR-PNTR (CONS CONTROL-VAR 0)) *ALIST*))
336        (SETQ *NAMECHAIN* (CONS CONTROL-VAR *NAMECHAIN*))
337     L  (COND ((NULL LIST-TO-MAP)
338               (RETURN T)))
339        (COND ((NULL (MULTIPLE-VALUE (NIL *ALIST*)
340                       (MA-OPT-MATCH-INST (CAR LIST-TO-MAP)
341                                               PATTERN
342                                               *ALIST*
343                                               *NAMECHAIN*)))
344               (RETURN NIL)))
345        (SETQ LIST-TO-MAP (CDR LIST-TO-MAP))
346        (RPLACD CONTROL-VAR-PNTR (1+ (CDR CONTROL-VAR-PNTR)))
347        (GO L)))
348
349(DEFUN (MAP-PUT MA-OPT-ACT) (ACT)
350  (PROG (CONTROL-VAR CONTROL-VAR-PNTR LIST-TO-MAP ACT-LIST)
351        (SETQ CONTROL-VAR (CAR ACT)
352              LIST-TO-MAP (MA-OPT-APPLY *INST* (CADR ACT))
353              ACT-LIST (CADDR ACT))
354        (SETQ CONTROL-VAR (MA-OPT-EXPAND-CHAIN-VAR CONTROL-VAR))
355        (SETQ *ALIST* (CONS (SETQ CONTROL-VAR-PNTR (CONS CONTROL-VAR 0)) *ALIST*))
356        (SETQ *NAMECHAIN* (CONS CONTROL-VAR *NAMECHAIN*))
357     L  (COND ((NULL LIST-TO-MAP)
358               (RETURN T)))
359        (MA-OPT-ACT-ON (CAR LIST-TO-MAP)
360                            ACT-LIST
361                            *NAMECHAIN*)
362        (SETQ LIST-TO-MAP (CDR LIST-TO-MAP))
363        (RPLACD CONTROL-VAR-PNTR (1+ (CDR CONTROL-VAR-PNTR)))
364        (GO L)))
365
366(DEFUN (MATCH-CASE MA-OPT-MATCHER) (PAT)
367  (PROG (CONTROL-VAR CONTROL-VAR-PNTR LIST-OF-CASES TEM-ALIST)
368        (SETQ CONTROL-VAR (CAR PAT)
369              LIST-OF-CASES (CADR PAT))
370        (SETQ CONTROL-VAR (MA-OPT-EXPAND-CHAIN-VAR CONTROL-VAR))
371        (COND ((ASSOC CONTROL-VAR *ALIST*)
372               (FERROR NIL "~% control variable has reused name ~S" CONTROL-VAR)))
373        (SETQ *ALIST* (CONS (SETQ CONTROL-VAR-PNTR (CONS CONTROL-VAR 0)) *ALIST*))
374    L   (COND ((NULL LIST-OF-CASES) (RETURN NIL))
375              ((MULTIPLE-VALUE (NIL TEM-ALIST)
376                 (MA-OPT-MATCH-INST *INST* (CAR LIST-OF-CASES) *ALIST* *NAMECHAIN*))
377               (SETQ *ALIST* TEM-ALIST) ;this one won, gobble
378               (RETURN T)))
379        (SETQ LIST-OF-CASES (CDR LIST-OF-CASES))
380        (RPLACD CONTROL-VAR-PNTR (1+ (CDR CONTROL-VAR-PNTR)))
381        (GO L)
382))
383
384(DEFUN (PUT-CASE MA-OPT-ACT) (ACT)
385  (PROG (CONTROL-VAR CONTROL-VAR-VAL LIST-OF-CASES)
386        (SETQ CONTROL-VAR (CAR ACT)
387              LIST-OF-CASES (CADR ACT))
388        (SETQ CONTROL-VAR (MA-OPT-EXPAND-CHAIN-VAR CONTROL-VAR))
389        (IF (NOT (NUMBERP (SETQ CONTROL-VAR-VAL (MA-OPT-SYMEVAL CONTROL-VAR))))
390            (FERROR NIL "control var not number"))
391        (IF *MA-OPT-TRACE-ACTS*
392            (FORMAT T "~%Taking case ~s, control var ~s, namechain ~s"
393                    CONTROL-VAR-VAL CONTROL-VAR *NAMECHAIN*))
394        (RETURN (MA-OPT-ACT-ON *INST* (NTH CONTROL-VAR-VAL LIST-OF-CASES) *NAMECHAIN*))
395))
396
397(DEFUN (MATCH-FUNCTION MA-OPT-MATCHER) (PAT)
398  (LET* ((FCTN (CAR PAT))
399         (EXP (GET FCTN 'MA-OPT-FUNCTION)))
400    (MA-OPT-LET '*FUNCTION-ARG* (CADR PAT))
401    (MULTIPLE-VALUE (NIL *ALIST*)
402      (MA-OPT-MATCH-INST *INST* (CAR EXP) *ALIST* *NAMECHAIN*))))
403
404(DEFUN (MATCH-FUNCTION MA-OPT-ACT) (ACT)
405  (LET* ((FCTN (CAR ACT))
406         (EXP (GET FCTN 'MA-OPT-FUNCTION)))
407    (MA-OPT-ACT-ON *INST* (CADR EXP) *NAMECHAIN*)))
408
409(DEFUN (PRED MA-OPT-MATCHER) (PAT)
410  (LET ((F (CAAR PAT))
411        (ARGS (MA-OPT-SUBS (CDAR PAT))))
412    (IF *MA-OPT-MATCH-TRACE* (FORMAT T "~%pred: ~s args ~s" F ARGS))
413    (APPLY F ARGS)))
414
415(DEFUN MA-MATCH-EQUAL (A B)
416  (OR (EQ A '?)
417      (EQ B '?)
418      (EQUAL A B)))
419
420(DEFUN (MAP-RANGE MA-OPT-MATCHER) (PAT)
421  (LEXPR-FUNCALL
422    'MA-SEQ-MAP-RANGE
423    *SEQ*           ;args: from-inst to-inst slot pred
424    (MA-OPT-SUBS PAT)))
425
426(DEFUN (TRACE MA-OPT-MATCHER) (PAT) PAT
427  (FORMAT T "~% begin trace ~S, pat ~S, alist ~S" *INST* *PATTERN* *ALIST*)
428  (SETQ *MA-OPT-MATCH-TRACE* T))        ;returns T
429
430(DEFUN (BREAK MA-OPT-MATCHER) (PAT) PAT
431  (CERROR T NIL NIL "break")
432  T)
433
434;test instructions after FROM and before TO
435(DEFUN MA-SEQ-MAP-RANGE (SEQ FROM TO SLOT OPER)
436  (PROG (INSTS)
437        (SETQ INSTS (MA-ELEM-MEMBERS SEQ))
438    L   (COND ((NULL INSTS) (FERROR NIL "p1"))
439              ((EQ (CAR INSTS) FROM)
440               (GO E1)))
441        (SETQ INSTS (CDR INSTS))
442        (GO L)
443    E1  (SETQ INSTS (CDR INSTS))        ;flush from INST.
444    L1  (COND ((NULL INSTS) (FERROR NIL "p2"))
445              ((EQ (CAR INSTS) TO)
446               (RETURN T))              ;doesnt clobber
447              ((MA-INST-MAP-OPER-P (CAR INSTS) SLOT OPER)
448               (COND (*MA-OPT-MATCH-TRACE*
449                      (FORMAT T "~%    ~s violates ~s ~s" (CAR INSTS) OPER SLOT)))
450               (RETURN NIL)))           ;does clobber
451        (SETQ INSTS (CDR INSTS))
452        (GO L1)
453  ))
454
455(DEFUN MA-INST-MAP-OPER-P (INST SLOT OPER)
456  (SELECTQ OPER
457    (NO-CLOBBER
458     (COND ((MA-INST-CLOBBERS-CONTEXT-P INST))
459           ((EQUAL SLOT (MA-DEST-CODE (MA-INST-CODE INST))))))
460    (NO-REFERENCE
461     (OR (MA-OPERAND-REFS-SLOT SLOT (MA-INST-OP1 INST))
462         (MA-OPERAND-REFS-SLOT SLOT (MA-INST-OP2 INST))))))
463
464(DEFUN MA-INST-CLOBBERS-CONTEXT-P (INST)
465  (MA-CONTEXT-CLOBBERAGE (MA-INST-CODE INST))   ;this may eventually be too conservative.
466)
467
468(DEFUN MA-OPERAND-REFS-SLOT (SLOT OP)
469  (COND ((NULL OP) NIL)
470        ((EQUAL SLOT (CAR OP)))))
471
472(DEFUN MA-SAME-SEQUENCE (I1 I2)
473  (EQ (MA-INST-SEQUENCE I1) (MA-INST-SEQUENCE I2)))
474
475(DEFUN MA-OP1-SOURCE-INST (INST)
476  (LET ((OP1 (MA-INST-OP1 INST)))
477    (COND ((OR (NLISTP OP1)
478               (NOT (= (LENGTH (CDR OP1)) 1)))    ;flush register spec
479           (FERROR NIL ""))
480          (T (MA-OPERAND-SOURCE (CADR OP1))))))
481
482(DEFUN MA-OP1-SOURCE-INST-LIST (INST)
483  (LET ((OP1 (MA-INST-OP1 INST))
484        ANS)
485    (COND ((NLISTP OP1)
486           (FERROR NIL ""))
487          (T (DOLIST (OP (CDR OP1))     ;flush register spec.
488               (SETQ ANS (CONS (MA-OPERAND-SOURCE OP) ANS)))
489             (NREVERSE ANS)))))
490
491(DEFUN MA-PRECEEDING-INSTS-LIST (INST)
492  (LET* ((BS (MA-INST-BEFORE-STATE INST))
493         (PS (MA-STATE-PRECEEDING-STATES BS)))
494    (AND (NULL (MA-INST-CHANGED INST))
495         (MAPCAR (FUNCTION (LAMBDA (X) (MA-STATE-INST X)))
496                 PS))))
497
498(DEFUN MA-FOLLOWING-INSTS-LIST (INST)
499  (LET* ((AS (MA-INST-AFTER-STATE INST))
500         (FS (MA-STATE-FOLLOWING-STATES AS)))
501    (AND (NULL (MA-INST-CHANGED INST))
502         (MAPCAR (FUNCTION (LAMBDA (X) (MA-STATE-INST X)))
503                 FS))))
504
505(DEFUN MA-OPERAND-ONE-USE-P (OP)
506  (= (LENGTH (MA-OPERAND-USES OP)) 1))
507
508(DEFUN MA-ONE-AND-ONLY-USE-P (OL)
509  (AND OL (NULL (CDR OL)) (MA-OPERAND-ONE-USE-P (CAR OL))))
510
511(DEFUN MA-OPERAND-FIX-P (OP PATH &AUX SOURCE-INST SOURCE-INST-CODE SOURCE-INST-OP1)
512  (OR (EQ (MA-OPERAND-TYPE OP) 'DTP-FIX)
513      (AND (SETQ SOURCE-INST (MA-OPERAND-SOURCE OP))
514           (NULL (MA-INST-CHANGED SOURCE-INST))
515           (LISTP (SETQ SOURCE-INST-CODE (MA-INST-CODE SOURCE-INST)))
516           (EQ (CAR SOURCE-INST-CODE) 'MOVE)
517           (NULL (CDDDR SOURCE-INST-CODE))      ;no byte specifier
518           (SETQ SOURCE-INST-OP1 (CDR (MA-INST-OP1 SOURCE-INST)))
519           (NOT (MEMQ SOURCE-INST-OP1 PATH))    ;avoid infinite loop in degenerate case
520           (NULL (DOLIST (OP SOURCE-INST-OP1)
521                   (COND ((NULL (MA-OPERAND-FIX-P OP (CONS OP PATH)))
522                          (RETURN T))))))))     ;if any one not a fix, it isnt
523
524;return nil if more than one.
525(DEFUN MA-OPT-PRECEEDING-INST (INST)
526  (LET* ((BS (MA-INST-BEFORE-STATE INST))
527         (PS (MA-STATE-PRECEEDING-STATES BS)))
528    (AND (NULL (MA-INST-CHANGED INST))
529         (NULL (CDR PS))                ;just one preceeding state
530         (LET* ((PRECEEDING-STATE (CAR PS))
531                (PRECEEDING-INST (MA-STATE-INST PRECEEDING-STATE)))
532           (AND (NULL (MA-INST-CHANGED PRECEEDING-INST))
533                PRECEEDING-INST)))))
534
535(DEFUN MA-OPT-FOLLOWING-INST (INST)
536  (LET* ((AS (MA-INST-AFTER-STATE INST))
537         (FS (MA-STATE-FOLLOWING-STATES AS)))
538    (AND (NULL (MA-INST-CHANGED INST))
539         (NULL (CDR FS))
540         (LET* ((FOLLOWING-STATE (CAR FS))
541                (FOLLOWING-INST (MA-STATE-INST FOLLOWING-STATE)))
542           (AND (NULL (MA-INST-CHANGED FOLLOWING-INST))
543                FOLLOWING-INST)))))
544
545(DEFUN MA-OPT-IS-A-FOLLOWER (INST BEFORE-INST)
546  (LET* ((AS (MA-INST-AFTER-STATE BEFORE-INST))
547         (FS (MA-STATE-FOLLOWING-STATES AS)))
548    (AND (NULL (MA-INST-CHANGED INST))
549         (DOLIST (F FS)
550           (COND ((EQ INST (MA-STATE-INST F))
551                  (RETURN T)))))))
552
553(DEFUN MA-OPT-ONLY-PRECEEDER (BEFORE-INST INST)
554  (LET* ((BS (MA-INST-BEFORE-STATE INST))
555         (PS (MA-STATE-PRECEEDING-STATES BS)))
556    (AND (NULL (MA-INST-CHANGED INST))
557         (NULL (CDR PS))
558         (EQ BEFORE-INST (MA-STATE-INST (CAR PS))))))
559
560;return nil if not defined.
561(DEFUN MA-OPT-OTHER-FOLLOWING-INST (INST NOT-INST)
562  (LET* ((AS (MA-INST-AFTER-STATE INST))
563         (FS (MA-STATE-FOLLOWING-STATES AS)))
564    (AND (NULL (MA-INST-CHANGED INST))
565         (NULL (MA-INST-CHANGED NOT-INST))
566         (NULL (CDDR FS))                       ;two following states
567         (LET* ((FS1 (CAR FS))
568                (FI1 (MA-STATE-INST FS1))
569                (FS2 (CADR FS))
570                (FI2 (MA-STATE-INST FS2)))
571           (AND (NULL (MA-INST-CHANGED FI1))
572                (NULL (MA-INST-CHANGED FI2))
573                (PROG2 (IF (NOT (OR (EQ FI1 NOT-INST) (EQ FI2 NOT-INST)))
574                           (FERROR NIL "not inst not one of choices"))
575                       (IF (EQ FI1 NOT-INST) FI2 FI1)))))))
576
577(DEFUN MA-OPT-APPLY-INST (ARG PC)
578  (AND (NULL (MA-INST-CHANGED *INST*))
579       (MA-OPT-APPLY ARG PC)))
580
581(DEFUN MA-OPT-APPLY (ARG PC)
582  (LEXPR-FUNCALL (CAR PC) ARG (CDR PC)))
583
584(DEFUN MA-OPT-SYMEVAL (SYM)
585  (COND ((EQ SYM '*INST*) *INST*)               ;special frob
586        (T (CDR (ASSOC SYM *ALIST*)))))
587
588
589(DEFUN MA-OPT-MATCH-WD (CODE P)
590  (PROG ()
591        (COND ((ATOM P) (RETURN (EQ P CODE))))
592    L   (COND ((NULL P)
593               (RETURN (NULL CODE)))
594              ((ATOM P)         ;dotted rest variable
595               (RETURN (MATCH-OPT-MATCH-VAR CODE P NIL)))
596              ((AND (LISTP P)
597                    (EQ (CAR P) '==))
598               (RETURN (MATCH-OPT-MATCH-VAR CODE (CADR P) (CDDR P))))
599              ((NLISTP CODE)
600               (RETURN NIL)))
601        (COND ((NULL (MA-OPT-MATCH-WD (CAR CODE) (CAR P))) (RETURN NIL)))
602        (SETQ CODE (CDR CODE) P (CDR P))
603        (GO L))
604)
605
606(DEFUN MATCH-OPT-MATCH-VAR (CODE VAR RESTRICTIONS)
607  (LET ((SYM (MA-OPT-EXPAND-CHAIN-VAR VAR))
608        TEM)
609    (COND ((EQ SYM '?)
610           T)
611          ((SETQ TEM (ASSOC SYM *ALIST*))
612           (EQUAL (CDR TEM) CODE))
613          ((AND RESTRICTIONS
614                (DOLIST (E RESTRICTIONS)
615                  (COND ((NULL (APPLY (CAR E)
616                                      (CONS CODE (CDR E))))
617                         (RETURN T)))))
618           NIL)                 ;predicate not true.
619          (T (COND ((MEMBER SYM *MA-OPT-TRACE-VARS*)
620                    (FORMAT T "~%Assigning ~s: ~s" SYM CODE)))
621             (SETQ *ALIST* (CONS (CONS SYM CODE) *ALIST*))
622             T))))
623
624(DEFUN MA-OPT-EXPAND-CHAIN-VAR (VAR)
625  (PROG (NC)
626        (COND ((MEMQ VAR '(? *INST*))
627               (RETURN VAR)))
628        (SETQ NC *NAMECHAIN*)
629    L   (COND ((SYMBOLP VAR))
630              ((EQ (CAR VAR) '=)
631               (SETQ NC NIL VAR (CADR VAR))
632               (GO L))
633              ((EQ (CAR VAR) '*)
634               (SETQ NC (CDR NC) VAR (CADR VAR))
635               (GO L)))
636        (COND ((AND (SYMBOLP VAR)
637                    (NULL NC))
638               (RETURN VAR))
639              (T (RETURN (CONS VAR (MAPCAR (FUNCTION MA-OPT-SYMEVAL) NC)))))))
640
641(DEFUN MA-OPT-ACT (INSTS ACTIONS *ALIST*)
642  (DO ((I INSTS (CDR I))
643       (A ACTIONS (CDR A)))
644      ((NULL A)
645       (COND ((MA-SEQ-CHANGED *SEQ*)
646              (*THROW 'OPT-SEQUENCE T))))   ;dont hack this sequence since its changed
647    (MA-OPT-ACT-ON (CAR I) (CAR A) NIL)))
648
649(DEFUN MA-OPT-ACT-ON (*INST* ACT-LIST *NAMECHAIN*)
650 (PROG (ACT FCTN ICODE)
651      (COND (*MA-OPT-TRACE-ACTS*
652             (FORMAT T "~%Enter ACT ~S, namechain ~S, ==>" *INST* *NAMECHAIN*)))
653      (SETQ ICODE (MA-INST-CODE *INST*))
654   L  (COND ((NULL ACT-LIST)
655             (COND (*MA-OPT-TRACE-ACTS* (FORMAT T "~% ~S ==> ~S, namechain ~S"
656                                                ICODE (MA-INST-CODE *INST*) *NAMECHAIN*)))
657             (RETURN T)))
658      (SETQ ACT (CAR ACT-LIST))
659      (IF (NULL (SETQ FCTN (GET (CAR ACT) 'MA-OPT-ACT)))
660          (FERROR NIL "~%unknown action")
661          (FUNCALL FCTN (CDR ACT)))
662      (SETQ ACT-LIST (CDR ACT-LIST))
663      (GO L)))
664
665(DEFUN (FLUSH MA-OPT-ACT) (ACT) ACT
666  (MA-OPT-FLUSH))
667
668(DEFUN MA-OPT-FLUSH NIL
669  (SETF (MA-INST-OP1 *INST*) (MA-INST-CODE *INST*))  ;save for debugging
670  (SETF (MA-INST-CODE *INST*) NIL)
671  (SETF (MA-INST-CHANGED *INST*) T)
672  (MA-FLUSH-INST *INST*)          ;flush it.
673  (SETQ *MA-OPT-FLAG* T)
674  (SETF (MA-SEQ-CHANGED (MA-INST-SEQUENCE *INST*)) T))
675
676(DEFUN (PUT MA-OPT-ACT) (ACT)
677  (SETF (MA-INST-CODE *INST*) (MA-OPT-SUBS (CAR ACT)))
678  (SETF (MA-INST-CHANGED *INST*) T)
679  (SETQ *MA-OPT-FLAG* T)
680  (SETF (MA-SEQ-CHANGED (MA-INST-SEQUENCE *INST*)) T))
681
682(DEFUN (PUT-INST MA-OPT-ACT) (ACT)
683  (MA-OPT-ACT-ON (MA-OPT-SUBS (CAR ACT))
684                 (CADR ACT)
685                 *NAMECHAIN*))
686
687(DEFUN MA-OPT-SUBS (PAT)
688  (PROG (V P)
689        (COND ((NULL PAT) (RETURN NIL))
690              ((NLISTP PAT) (RETURN PAT))
691              ((EQ (CAR PAT) '==)
692               (RETURN (MA-OPT-SUBS-VAR (CADR PAT) (CDDR PAT))))
693              ((EQ (CAR PAT) 'QUOTE)
694               (RETURN PAT)))
695        (SETQ P (VALUE-CELL-LOCATION 'V))
696   L    (COND ((NULL PAT) (RETURN V))
697              ((SYMBOLP PAT)            ;dotted rest var.
698               (RPLACD P (MA-OPT-SUBS-VAR PAT NIL))
699               (RETURN V)))
700        (RPLACD P (SETQ P (LIST (MA-OPT-SUBS (CAR PAT)))))
701        (SETQ PAT (CDR PAT))
702        (GO L)))
703
704(DEFUN MA-OPT-SUBS-VAR (VAR ALTERATION)
705  (LET* ((SYM (MA-OPT-EXPAND-CHAIN-VAR VAR))
706         (VAL (MA-OPT-SYMEVAL SYM)))
707    (IF ALTERATION
708        (SETQ VAL (APPLY (CAAR ALTERATION)      ;call function to alter value
709                         (CONS VAL (CDAR ALTERATION)))))
710    VAL))
711
712(DEFUN MA-INVERT (V 2-LIST)
713  (COND ((EQ V (CAR 2-LIST)) (CADR 2-LIST))
714        ((EQ V (CADR 2-LIST)) (CAR 2-LIST))
715        (T (FERROR NIL ""))))
Note: See TracBrowser for help on using the browser.