Context Navigation

maopt.lisp @ 226

Revision 226, 25.2 KB (checked in by rjs, 22 months 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.

Download in other formats:

Original Format