1#| -*-Scheme-*-
2
3Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6    Institute of Technology
7
8This file is part of MIT/GNU Scheme.
9
10MIT/GNU Scheme is free software; you can redistribute it and/or modify
11it under the terms of the GNU General Public License as published by
12the Free Software Foundation; either version 2 of the License, or (at
13your option) any later version.
14
15MIT/GNU Scheme is distributed in the hope that it will be useful, but
16WITHOUT ANY WARRANTY; without even the implied warranty of
17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18General Public License for more details.
19
20You should have received a copy of the GNU General Public License
21along with MIT/GNU Scheme; if not, write to the Free Software
22Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23USA.
24
25|#
26
27;;;; Register Transfer Language: Expression Operations
28;;; package: (compiler)
29
30(declare (usual-integrations))
31
32(define (rtl:invocation? rtl)
33  (memq (rtl:expression-type rtl)
34	'(INVOCATION:APPLY
35	  INVOCATION:JUMP
36	  INVOCATION:COMPUTED-JUMP
37	  INVOCATION:LEXPR
38	  INVOCATION:COMPUTED-LEXPR
39	  INVOCATION:PRIMITIVE
40	  INVOCATION:SPECIAL-PRIMITIVE
41	  INVOCATION:UUO-LINK
42	  INVOCATION:GLOBAL-LINK
43	  INVOCATION:CACHE-REFERENCE
44	  INVOCATION:LOOKUP)))
45
46(define (rtl:invocation-prefix? rtl)
47  (memq (rtl:expression-type rtl)
48	'(INVOCATION-PREFIX:DYNAMIC-LINK
49	  INVOCATION-PREFIX:MOVE-FRAME-UP)))
50
51(define (rtl:expression-value-class expression)
52  (case (rtl:expression-type expression)
53    ((REGISTER)
54     (register-value-class (rtl:register-number expression)))
55    ((CONS-NON-POINTER CONS-POINTER CONSTANT FIXNUM->OBJECT FLOAT->OBJECT
56		       GENERIC-BINARY GENERIC-UNARY OFFSET POST-INCREMENT
57		       PRE-INCREMENT)
58     value-class=object)
59    ((FIXNUM->ADDRESS OBJECT->ADDRESS
60		      ASSIGNMENT-CACHE VARIABLE-CACHE
61		      CONS-CLOSURE CONS-MULTICLOSURE
62		      ENTRY:CONTINUATION ENTRY:PROCEDURE
63		      OFFSET-ADDRESS
64		      FLOAT-OFFSET-ADDRESS
65		      BYTE-OFFSET-ADDRESS)
66     value-class=address)
67    ((MACHINE-CONSTANT)
68     value-class=immediate)
69    ((BYTE-OFFSET CHAR->ASCII)
70     value-class=ascii)
71    ((OBJECT->DATUM)
72     value-class=datum)
73    ((ADDRESS->FIXNUM FIXNUM-1-ARG FIXNUM-2-ARGS OBJECT->FIXNUM
74		      OBJECT->UNSIGNED-FIXNUM)
75     value-class=fixnum)
76    ((OBJECT->TYPE)
77     value-class=type)
78    ((OBJECT->FLOAT FLONUM-1-ARG FLONUM-2-ARGS FLOAT-OFFSET)
79     value-class=float)
80    (else
81     (error "unknown RTL expression type" expression))))
82
83(define (rtl:object-valued-expression? expression)
84  (value-class=object? (rtl:expression-value-class expression)))
85
86(define (rtl:volatile-expression? expression)
87  (memq (rtl:expression-type expression) '(POST-INCREMENT PRE-INCREMENT)))
88
89(define (rtl:machine-register-expression? expression)
90  (and (rtl:register? expression)
91       (machine-register? (rtl:register-number expression))))
92
93(define (rtl:pseudo-register-expression? expression)
94  (and (rtl:register? expression)
95       (pseudo-register? (rtl:register-number expression))))
96
97(define (rtl:stack-reference-expression? expression)
98  (and (rtl:offset? expression)
99       (interpreter-stack-pointer? (rtl:offset-base expression))))
100
101(define (rtl:register-assignment? rtl)
102  (and (rtl:assign? rtl)
103       (rtl:register? (rtl:assign-address rtl))))
104
105(define (rtl:expression-cost expression)
106  (if (rtl:register? expression)
107      1
108      (or (rtl:constant-cost expression)
109	  (let loop ((parts (cdr expression)) (cost 2))
110	    (if (null? parts)
111		cost
112		(loop (cdr parts)
113		      (if (pair? (car parts))
114			  (+ cost (rtl:expression-cost (car parts)))
115			  cost)))))))
116
117(define (rtl:map-subexpressions expression procedure)
118  (if (rtl:constant? expression)
119      expression
120      (cons (car expression)
121	    (map (lambda (x)
122		   (if (pair? x)
123		       (procedure x)
124		       x))
125		 (cdr expression)))))
126
127(define (rtl:for-each-subexpression expression procedure)
128  (if (not (rtl:constant? expression))
129      (for-each (lambda (x)
130		  (if (pair? x)
131		      (procedure x)))
132		(cdr expression))))
133
134(define (rtl:any-subexpression? expression predicate)
135  (and (not (rtl:constant? expression))
136       (there-exists? (cdr expression)
137	 (lambda (x)
138	   (and (pair? x)
139		(predicate x))))))
140
141(define (rtl:expression-contains? expression predicate)
142  (let loop ((expression expression))
143    (or (predicate expression)
144	(rtl:any-subexpression? expression loop))))
145
146(define (rtl:all-subexpressions? expression predicate)
147  (or (rtl:constant? expression)
148      (for-all? (cdr expression)
149	(lambda (x)
150	  (or (not (pair? x))
151	      (predicate x))))))
152
153(define (rtl:reduce-subparts expression operator initial if-expression if-not)
154  (let ((remap
155	 (if (rtl:constant? expression)
156	     if-not
157	     (lambda (x)
158	       (if (pair? x)
159		   (if-expression x)
160		   (if-not x))))))
161    (let loop ((parts (cdr expression)) (accum initial))
162      (if (null? parts)
163	  accum
164	  (loop (cdr parts)
165		(operator accum (remap (car parts))))))))
166
167(define (rtl:expression=? x y)
168  (let ((type (car x)))
169    (and (eq? type (car y))
170	 (if (eq? type 'CONSTANT)
171	     (eqv? (cadr x) (cadr y))
172	     (let loop ((x (cdr x)) (y (cdr y)))
173	       ;; Because of fixed format, all expressions of same
174	       ;; type have the same length, and each entry is either
175	       ;; a subexpression or a non-expression.
176	       (or (null? x)
177		   (and (if (pair? (car x))
178			    (rtl:expression=? (car x) (car y))
179			    (eqv? (car x) (car y)))
180			(loop (cdr x) (cdr y)))))))))
181
182(define (rtl:match-subexpressions x y predicate)
183  (let ((type (car x)))
184    (and (eq? type (car y))
185	 (if (eq? type 'CONSTANT)
186	     (eqv? (cadr x) (cadr y))
187	     (let loop ((x (cdr x)) (y (cdr y)))
188	       (or (null? x)
189		   (and (if (pair? (car x))
190			    (predicate (car x) (car y))
191			    (eqv? (car x) (car y)))
192			(loop (cdr x) (cdr y)))))))))
193
194(define (rtl:refers-to-register? rtl register)
195  (let loop
196      ((expression
197	(if (rtl:register-assignment? rtl) (rtl:assign-expression rtl) rtl)))
198    (cond ((not (pair? expression)) false)
199	  ((rtl:register? expression)
200	   (= (rtl:register-number expression) register))
201	  ((rtl:contains-no-substitutable-registers? expression) false)
202	  (else (there-exists? (cdr expression) loop)))))
203
204(define (rtl:subst-register rtl register substitute)
205  (letrec
206      ((loop
207	(lambda (expression)
208	  (cond ((not (pair? expression)) expression)
209		((rtl:register? expression)
210		 (if (= (rtl:register-number expression) register)
211		     substitute
212		     expression))
213		((rtl:contains-no-substitutable-registers? expression)
214		 expression)
215		(else (cons (car expression) (map loop (cdr expression))))))))
216    (if (rtl:register-assignment? rtl)
217	(list (rtl:expression-type rtl)
218	      (rtl:assign-address rtl)
219	      (loop (rtl:assign-expression rtl)))
220	(loop rtl))))
221
222(define (rtl:substitutable-registers rtl)
223  (if (rtl:register-assignment? rtl)
224      (rtl:substitutable-registers (rtl:assign-expression rtl))
225      (let outer ((expression rtl) (registers '()))
226	(cond ((not (pair? expression)) registers)
227	      ((rtl:register? expression)
228	       (let ((register (rtl:register-number expression)))
229		 (if (memq register registers)
230		     registers
231		     (cons register registers))))
232	      ((rtl:contains-no-substitutable-registers? expression) registers)
233	      (else
234	       (let inner
235		   ((subexpressions (cdr expression)) (registers registers))
236		 (if (null? subexpressions)
237		     registers
238		     (inner (cdr subexpressions)
239			    (outer (car subexpressions) registers)))))))))
240
241(define (rtl:contains-no-substitutable-registers? expression)
242  ;; True for all expressions that cannot possibly contain registers.
243  ;; In addition, this is also true of expressions that do contain
244  ;; registers but are not candidates for substitution (e.g.
245  ;; `pre-increment').
246  (memq (rtl:expression-type expression)
247	'(ASSIGNMENT-CACHE
248	  CONS-CLOSURE
249	  CONS-MULTICLOSURE
250	  CONSTANT
251	  ENTRY:CONTINUATION
252	  ENTRY:PROCEDURE
253	  MACHINE-CONSTANT
254	  POST-INCREMENT
255	  PRE-INCREMENT
256	  VARIABLE-CACHE)))
257
258(define (rtl:constant-expression? expression)
259  (case (rtl:expression-type expression)
260    ((ASSIGNMENT-CACHE
261      CONSTANT
262      ENTRY:CONTINUATION
263      ENTRY:PROCEDURE
264      MACHINE-CONSTANT
265      VARIABLE-CACHE)
266     true)
267    ((BYTE-OFFSET-ADDRESS
268      CHAR->ASCII
269      CONS-NON-POINTER
270      CONS-POINTER
271      FIXNUM-1-ARG
272      FIXNUM-2-ARGS
273      FIXNUM->ADDRESS
274      FIXNUM->OBJECT
275      FLOAT-OFFSET-ADDRESS
276      FLONUM-1-ARG
277      FLONUM-2-ARGS
278      GENERIC-BINARY
279      GENERIC-UNARY
280      OBJECT->ADDRESS
281      OBJECT->DATUM
282      OBJECT->FIXNUM
283      OBJECT->TYPE
284      OBJECT->UNSIGNED-FIXNUM
285      OFFSET-ADDRESS)
286     (let loop ((subexpressions (cdr expression)))
287       (or (null? subexpressions)
288	   (and (let ((expression (car subexpressions)))
289		  (or (not (pair? expression))
290		      (rtl:constant-expression? expression)))
291		(loop (cdr subexpressions))))))
292    (else
293     false)))
294
295(define (rtx-set/union* set sets)
296  (let loop ((set set) (sets sets) (accum '()))
297    (let ((set (rtx-set/union set accum)))
298      (if (null? sets)
299	  set
300	  (loop (car sets) (cdr sets) set)))))
301
302(define (rtx-set/union x y)
303  (if (null? y)
304      x
305      (let loop ((x x) (y y))
306	(if (null? x)
307	    y
308	    (loop (cdr x)
309		  (let ((x (car x)))
310		    (if (there-exists? y
311			  (lambda (y)
312			    (rtl:expression=? x y)))
313			y
314			(cons x y))))))))