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))))))))