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