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;;;; RTL Rewrite Rules
28;;; Package: (compiler lap-syntaxer)
29
30(declare (usual-integrations))
31
32;;;; Synthesized Data
33
34(define-rule rewriting
35  (CONS-NON-POINTER (REGISTER (? type register-known-value))
36		    (REGISTER (? datum register-known-value)))
37  (QUALIFIER (and (rtl:machine-constant? type)
38		  (rtl:machine-constant? datum)))
39  (rtl:make-cons-non-pointer type datum))
40
41(define-rule rewriting
42  (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
43  (QUALIFIER
44   (and (rtl:object->type? type)
45	(rtl:constant? (rtl:object->type-expression type))))
46  (rtl:make-cons-pointer
47   (rtl:make-machine-constant
48    (object-type (rtl:object->type-expression datum)))
49   datum))
50
51(define-rule rewriting
52  (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
53  (QUALIFIER (rtl:machine-constant? type))
54  (rtl:make-cons-pointer type datum))
55
56(define-rule rewriting
57  (CONS-NON-POINTER (REGISTER (? type register-known-value)) (? datum))
58  (QUALIFIER (rtl:machine-constant? type))
59  (rtl:make-cons-non-pointer type datum))
60
61(define-rule rewriting
62  (CONS-NON-POINTER (REGISTER (? type register-known-value)) (? datum))
63  (QUALIFIER
64   (and (rtl:object->type? type)
65	(rtl:constant? (rtl:object->type-expression type))))
66  (rtl:make-cons-non-pointer
67   (rtl:make-machine-constant
68    (object-type (rtl:object->type-expression datum)))
69   datum))
70
71(define-rule rewriting
72  (CONS-NON-POINTER (? type) (REGISTER (? datum register-known-value)))
73  (QUALIFIER
74   (and (rtl:object->datum? datum)
75	(rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
76  (rtl:make-cons-non-pointer
77   type
78   (rtl:make-machine-constant
79    (careful-object-datum
80     (rtl:constant-value (rtl:object->datum-expression datum))))))
81
82(define-rule rewriting
83  (OBJECT->TYPE (REGISTER (? source register-known-value)))
84  (QUALIFIER (rtl:constant? source))
85  (rtl:make-machine-constant (object-type (rtl:constant-value source))))
86
87(define-rule rewriting
88  (OBJECT->DATUM (REGISTER (? source register-known-value)))
89  (QUALIFIER (rtl:constant-non-pointer? source))
90  (rtl:make-machine-constant
91   (careful-object-datum (rtl:constant-value source))))
92
93(define (rtl:constant-non-pointer? expression)
94  (and (rtl:constant? expression)
95       (non-pointer-object? (rtl:constant-value expression))))
96
97;;; These rules are losers because there's no abstract way to cons a
98;;; statement or a predicate without also getting some CFG structure.
99
100(define-rule rewriting
101  (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
102  (QUALIFIER (rtl:immediate-zero-constant? comparand))
103  (list 'ASSIGN target (rtl:make-machine-register regnum:zero)))
104
105(define-rule rewriting
106  (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
107  (QUALIFIER (rtl:immediate-zero-constant? comparand))
108  (list 'EQ-TEST source (rtl:make-machine-register regnum:zero)))
109
110(define-rule rewriting
111  (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
112  (QUALIFIER (rtl:immediate-zero-constant? comparand))
113  (list 'EQ-TEST source (rtl:make-machine-register regnum:zero)))
114
115(define (rtl:immediate-zero-constant? expression)
116  (cond ((rtl:constant? expression)
117	 (let ((value (rtl:constant-value expression)))
118	   (and (non-pointer-object? value)
119		(zero? (object-type value))
120		(zero? (careful-object-datum value)))))
121	((rtl:cons-non-pointer? expression)
122	 (and (let ((expression (rtl:cons-non-pointer-type expression)))
123		(and (rtl:machine-constant? expression)
124		     (zero? (rtl:machine-constant-value expression))))
125	      (let ((expression (rtl:cons-non-pointer-datum expression)))
126		(and (rtl:machine-constant? expression)
127		     (zero? (rtl:machine-constant-value expression))))))
128	(else false)))
129
130;;;; Fixnums
131
132;; I've copied this rule from the MC68020.  -- Jinx
133;; It should probably be qualified to be in the immediate range.
134
135(define-rule rewriting
136  (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
137  (QUALIFIER (rtl:constant-fixnum? source))
138  (rtl:make-object->fixnum source))
139
140(define-rule rewriting
141  (FIXNUM-2-ARGS FIXNUM-LSH
142		 (? operand-1)
143		 (REGISTER (? operand-2 register-known-value))
144		 #F)
145  (QUALIFIER (and (rtl:register? operand-1)
146		  (rtl:constant-fixnum? operand-2)))
147  (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 #F))
148
149(define-rule rewriting
150  (FIXNUM-2-ARGS MULTIPLY-FIXNUM
151		 (REGISTER (? operand-1 register-known-value))
152		 (? operand-2)
153		 #F)
154  (QUALIFIER (rtl:constant-fixnum-4? operand-1))
155  (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
156
157(define-rule rewriting
158  (FIXNUM-2-ARGS MULTIPLY-FIXNUM
159		 (? operand-1)
160		 (REGISTER (? operand-2 register-known-value))
161		 #F)
162  (QUALIFIER (rtl:constant-fixnum-4? operand-2))
163  (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
164
165(define-rule rewriting
166  (FIXNUM-2-ARGS MULTIPLY-FIXNUM
167		 (REGISTER (? operand-1 register-known-value))
168		 (? operand-2)
169		 #F)
170  (QUALIFIER
171   (and (rtl:object->fixnum-of-register? operand-1)
172	(rtl:constant-fixnum-4? operand-2)))
173  (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
174
175(define-rule rewriting
176  (FIXNUM-2-ARGS MULTIPLY-FIXNUM
177		 (? operand-1)
178		 (REGISTER (? operand-2 register-known-value))
179		 #F)
180  (QUALIFIER
181   (and (rtl:constant-fixnum-4? operand-1)
182	(rtl:object->fixnum-of-register? operand-2)))
183  (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 #F))
184
185(define (rtl:constant-fixnum? expression)
186  (and (rtl:constant? expression)
187       (fix:fixnum? (rtl:constant-value expression))))
188
189(define (rtl:constant-fixnum-4? expression)
190  (and (rtl:object->fixnum? expression)
191       (let ((expression (rtl:object->fixnum-expression expression)))
192	 (and (rtl:constant? expression)
193	      (eqv? 4 (rtl:constant-value expression))))))
194
195(define (rtl:object->fixnum-of-register? expression)
196   (and (rtl:object->fixnum? expression)
197	(rtl:register? (rtl:object->fixnum-expression expression))))
198
199;;;; Closures and othe optimizations.
200
201;; These rules are Spectrum specific
202
203(define-rule rewriting
204  (CONS-POINTER (REGISTER (? type register-known-value))
205		(REGISTER (? datum register-known-value)))
206  (QUALIFIER (and (rtl:machine-constant? type)
207		  (= (rtl:machine-constant-value type)
208		     (ucode-type compiled-entry))
209		  (or (rtl:entry:continuation? datum)
210		      (rtl:entry:procedure? datum)
211		      (rtl:cons-closure? datum))))
212  (rtl:make-cons-pointer type datum))
213
214#|
215;; Not yet written.
216
217;; A type is compatible when a depi instruction can put it in assuming that
218;; the datum has the quad bits set.
219;; A register is a machine-address-register if it is a machine register and
220;; always contains an address (ie. free pointer, stack pointer, or dlink register)
221
222(define-rule rewriting
223  (CONS-POINTER (REGISTER (? type register-known-value))
224		(REGISTER (? datum machine-address-register)))
225  (QUALIFIER (and (rtl:machine-constant? type)
226		  (spectrum-type-optimizable? (rtl:machine-constant-value type))))
227  (rtl:make-cons-pointer type datum))
228|#
229