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;;; Machine Model for Spectrum 28;;; package: (compiler) 29 30(declare (usual-integrations)) 31 32;;;; Architecture Parameters 33 34(define use-pre/post-increment? true) 35(define-integrable endianness 'BIG) 36(define-integrable addressing-granularity 8) 37(define-integrable scheme-object-width 32) 38(define-integrable scheme-type-width 6) ;or 8 39 40;; NOTE: expt is not being constant-folded now. 41;; For the time being, some of the parameters below are 42;; pre-computed and marked with *** 43;; There are similar parameters in lapgen.scm 44;; Change them if any of the parameters above do. 45 46(define-integrable scheme-datum-width 47 (- scheme-object-width scheme-type-width)) 48 49(define-integrable type-scale-factor 50 ;; (expt 2 (- 8 scheme-type-width)) *** 51 4) 52 53(define-integrable float-width 64) 54(define-integrable float-alignment 64) 55 56(define-integrable address-units-per-float 57 (quotient float-width addressing-granularity)) 58 59;;; It is currently required that both packed characters and objects 60;;; be integrable numbers of address units. Furthermore, the number 61;;; of address units per object must be an integral multiple of the 62;;; number of address units per character. This will cause problems 63;;; on a machine that is word addressed: we will have to rethink the 64;;; character addressing strategy. 65 66(define-integrable address-units-per-object 67 (quotient scheme-object-width addressing-granularity)) 68 69(define-integrable address-units-per-packed-char 1) 70 71(define-integrable signed-fixnum/upper-limit 72 ;; (expt 2 (-1+ scheme-datum-width)) *** 73 33554432) 74 75(define-integrable signed-fixnum/lower-limit 76 (- signed-fixnum/upper-limit)) 77 78(define-integrable unsigned-fixnum/upper-limit 79 (* 2 signed-fixnum/upper-limit)) 80 81(define-integrable (stack->memory-offset offset) offset) 82(define-integrable ic-block-first-parameter-offset 2) 83(define-integrable execute-cache-size 3) ; Long words per UUO link slot 84 85;;;; Closures and multi-closures 86 87;; On the 68k, to save space, entries can be at 2 mod 4 addresses, 88;; which makes it impossible to use an arbitrary closure entry-point 89;; to reference closed-over variables since the compiler only uses 90;; long-word offsets. Instead, all closure entry points are bumped 91;; back to the first entry point, which is always long-word aligned. 92 93;; On the HP-PA, and all other RISCs, all the entry points are 94;; long-word aligned, so there is no need to bump back to the first 95;; entry point. 96 97(define-integrable closure-entry-size 98 #| 99 Long words in a single closure entry: 100 GC offset word 101 LDIL L'target,26 102 BLE R'target(5,26) 103 ADDI -12,31,31 104 |# 105 4) 106 107;; Given: the number of entry points in a closure, and a particular 108;; entry point number, compute the distance from that entry point to 109;; the first variable slot in the closure object (in long words). 110 111(define (closure-first-offset nentries entry) 112 (if (zero? nentries) 113 1 ; Strange boundary case 114 (- (* closure-entry-size (- nentries entry)) 1))) 115 116;; Like the above, but from the start of the complete closure object, 117;; viewed as a vector, and including the header word. 118 119(define (closure-object-first-offset nentries) 120 (case nentries 121 ((0) 122 ;; Vector header only 123 1) 124 ((1) 125 ;; Manifest closure header followed by single entry point 126 (+ 1 closure-entry-size)) 127 (else 128 ;; Manifest closure header, number of entries, then entries. 129 (+ 1 1 (* closure-entry-size nentries))))) 130 131;; Bump distance in bytes from one entry point to another. 132;; Used for invocation purposes. 133 134(define (closure-entry-distance nentries entry entry*) 135 nentries ; ignored 136 (* (* closure-entry-size 4) (- entry* entry))) 137 138;; Bump distance in bytes from one entry point to the entry point used 139;; for variable-reference purposes. 140;; On a RISC, this is the entry point itself. 141 142(define (closure-environment-adjustment nentries entry) 143 nentries entry ; ignored 144 0) 145 146;;;; Machine Registers 147 148(define-integrable g0 0) 149(define-integrable g1 1) 150(define-integrable g2 2) 151(define-integrable g3 3) 152(define-integrable g4 4) 153(define-integrable g5 5) 154(define-integrable g6 6) 155(define-integrable g7 7) 156(define-integrable g8 8) 157(define-integrable g9 9) 158(define-integrable g10 10) 159(define-integrable g11 11) 160(define-integrable g12 12) 161(define-integrable g13 13) 162(define-integrable g14 14) 163(define-integrable g15 15) 164(define-integrable g16 16) 165(define-integrable g17 17) 166(define-integrable g18 18) 167(define-integrable g19 19) 168(define-integrable g20 20) 169(define-integrable g21 21) 170(define-integrable g22 22) 171(define-integrable g23 23) 172(define-integrable g24 24) 173(define-integrable g25 25) 174(define-integrable g26 26) 175(define-integrable g27 27) 176(define-integrable g28 28) 177(define-integrable g29 29) 178(define-integrable g30 30) 179(define-integrable g31 31) 180 181;; fp0 - fp3 are status registers. The rest are real registers 182(define-integrable fp0 32) 183(define-integrable fp1 33) 184(define-integrable fp2 34) 185(define-integrable fp3 35) 186(define-integrable fp4 36) 187(define-integrable fp5 37) 188(define-integrable fp6 38) 189(define-integrable fp7 39) 190(define-integrable fp8 40) 191(define-integrable fp9 41) 192(define-integrable fp10 42) 193(define-integrable fp11 43) 194(define-integrable fp12 44) 195(define-integrable fp13 45) 196(define-integrable fp14 46) 197(define-integrable fp15 47) 198 199;; The following registers are available only on the newer processors 200(define-integrable fp16 48) 201(define-integrable fp17 49) 202(define-integrable fp18 50) 203(define-integrable fp19 51) 204(define-integrable fp20 52) 205(define-integrable fp21 53) 206(define-integrable fp22 54) 207(define-integrable fp23 55) 208(define-integrable fp24 56) 209(define-integrable fp25 57) 210(define-integrable fp26 58) 211(define-integrable fp27 59) 212(define-integrable fp28 60) 213(define-integrable fp29 61) 214(define-integrable fp30 62) 215(define-integrable fp31 63) 216 217(define-integrable number-of-machine-registers 64) 218(define-integrable number-of-temporary-registers 256) 219 220;;; Fixed-use registers for Scheme compiled code. 221(define-integrable regnum:return-value g2) 222(define-integrable regnum:scheme-to-interface-ble g3) 223(define-integrable regnum:regs-pointer g4) 224(define-integrable regnum:quad-bitmask g5) 225(define-integrable regnum:dynamic-link g19) 226(define-integrable regnum:memtop-pointer g20) 227(define-integrable regnum:free-pointer g21) 228(define-integrable regnum:stack-pointer g22) 229 230;;; Fixed-use registers due to architecture or OS calling conventions. 231(define-integrable regnum:zero g0) 232(define-integrable regnum:addil-result g1) 233(define-integrable regnum:C-global-pointer g27) 234(define-integrable regnum:C-return-value g28) 235(define-integrable regnum:C-stack-pointer g30) 236(define-integrable regnum:ble-return g31) 237(define-integrable regnum:fourth-arg g23) 238(define-integrable regnum:third-arg g24) 239(define-integrable regnum:second-arg g25) 240(define-integrable regnum:first-arg g26) 241 242(define (machine-register-value-class register) 243 (cond ((or (= register 0) 244 (<= 6 register 18) 245 (<= 23 register 26) 246 (= register 29) 247 (= register 31)) 248 value-class=word) 249 ((or (= register 2) (= register 28)) 250 value-class=object) 251 ((or (= register 1) (= register 3)) 252 value-class=unboxed) 253 ((or (= register 4) 254 (<= 19 register 22) 255 (= register 27) 256 (= register 30)) 257 value-class=address) 258 ((= register 5) 259 value-class=immediate) 260 ((<= 32 register 63) 261 value-class=float) 262 (else 263 (error "illegal machine register" register)))) 264 265(define-integrable (machine-register-known-value register) 266 register ;ignore 267 false) 268 269;;;; Interpreter Registers 270 271(define-integrable (interpreter-free-pointer) 272 (rtl:make-machine-register regnum:free-pointer)) 273 274(define (interpreter-free-pointer? expression) 275 (and (rtl:register? expression) 276 (= (rtl:register-number expression) regnum:free-pointer))) 277 278(define-integrable (interpreter-regs-pointer) 279 (rtl:make-machine-register regnum:regs-pointer)) 280 281(define (interpreter-regs-pointer? expression) 282 (and (rtl:register? expression) 283 (= (rtl:register-number expression) regnum:regs-pointer))) 284 285(define-integrable (interpreter-value-register) 286 (rtl:make-machine-register regnum:return-value)) 287 288(define (interpreter-value-register? expression) 289 (and (rtl:register? expression) 290 (= (rtl:register-number expression) regnum:return-value))) 291 292(define-integrable (interpreter-stack-pointer) 293 (rtl:make-machine-register regnum:stack-pointer)) 294 295(define (interpreter-stack-pointer? expression) 296 (and (rtl:register? expression) 297 (= (rtl:register-number expression) regnum:stack-pointer))) 298 299(define-integrable (interpreter-dynamic-link) 300 (rtl:make-machine-register regnum:dynamic-link)) 301 302(define (interpreter-dynamic-link? expression) 303 (and (rtl:register? expression) 304 (= (rtl:register-number expression) regnum:dynamic-link))) 305 306(define-integrable (interpreter-environment-register) 307 (rtl:make-offset (interpreter-regs-pointer) 308 (rtl:make-machine-constant 3))) 309 310(define (interpreter-environment-register? expression) 311 (and (rtl:offset? expression) 312 (interpreter-regs-pointer? (rtl:offset-base expression)) 313 (let ((offset (rtl:offset-offset expression))) 314 (and (rtl:machine-constant? offset) 315 (= 3 (rtl:machine-constant-value offset)))))) 316 317(define-integrable (interpreter-register:access) 318 (rtl:make-machine-register g28)) 319 320(define-integrable (interpreter-register:cache-reference) 321 (rtl:make-machine-register g28)) 322 323(define-integrable (interpreter-register:cache-unassigned?) 324 (rtl:make-machine-register g28)) 325 326(define-integrable (interpreter-register:lookup) 327 (rtl:make-machine-register g28)) 328 329(define-integrable (interpreter-register:unassigned?) 330 (rtl:make-machine-register g28)) 331 332(define-integrable (interpreter-register:unbound?) 333 (rtl:make-machine-register g28)) 334 335;;;; RTL Registers, Constants, and Primitives 336 337(define (rtl:machine-register? rtl-register) 338 (case rtl-register 339 ((STACK-POINTER) 340 (interpreter-stack-pointer)) 341 ((DYNAMIC-LINK) 342 (interpreter-dynamic-link)) 343 ((VALUE) 344 (interpreter-value-register)) 345 ((FREE) 346 (interpreter-free-pointer)) 347 ((MEMORY-TOP) 348 (rtl:make-machine-register regnum:memtop-pointer)) 349 ((INTERPRETER-CALL-RESULT:ACCESS) 350 (interpreter-register:access)) 351 ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) 352 (interpreter-register:cache-reference)) 353 ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?) 354 (interpreter-register:cache-unassigned?)) 355 ((INTERPRETER-CALL-RESULT:LOOKUP) 356 (interpreter-register:lookup)) 357 ((INTERPRETER-CALL-RESULT:UNASSIGNED?) 358 (interpreter-register:unassigned?)) 359 ((INTERPRETER-CALL-RESULT:UNBOUND?) 360 (interpreter-register:unbound?)) 361 (else false))) 362 363(define (rtl:interpreter-register? rtl-register) 364 (case rtl-register 365 ((INT-MASK) 1) 366 ((ENVIRONMENT) 3) 367 ((TEMPORARY) 4) 368 (else false))) 369 370(define (rtl:interpreter-register->offset locative) 371 (or (rtl:interpreter-register? locative) 372 (error "Unknown register type" locative))) 373 374(define (rtl:constant-cost expression) 375 ;; Magic numbers. 376 (let ((if-integer 377 (lambda (value) 378 (cond ((zero? value) 1) 379 ((fits-in-5-bits-signed? value) 2) 380 (else 3))))) 381 (let ((if-synthesized-constant 382 (lambda (type datum) 383 (if-integer (make-non-pointer-literal type datum))))) 384 (case (rtl:expression-type expression) 385 ((CONSTANT) 386 (let ((value (rtl:constant-value expression))) 387 (if (non-pointer-object? value) 388 (if-synthesized-constant (object-type value) 389 (object-datum value)) 390 3))) 391 ((MACHINE-CONSTANT) 392 (if-integer (rtl:machine-constant-value expression))) 393 ((ENTRY:PROCEDURE 394 ENTRY:CONTINUATION 395 ASSIGNMENT-CACHE 396 VARIABLE-CACHE 397 OFFSET-ADDRESS 398 BYTE-OFFSET-ADDRESS 399 FLOAT-OFFSET-ADDRESS) 400 3) 401 ((CONS-POINTER) 402 (and (rtl:machine-constant? (rtl:cons-pointer-type expression)) 403 (rtl:machine-constant? (rtl:cons-pointer-datum expression)) 404 (if-synthesized-constant 405 (rtl:machine-constant-value (rtl:cons-pointer-type expression)) 406 (rtl:machine-constant-value 407 (rtl:cons-pointer-datum expression))))) 408 (else false))))) 409 410(define compiler:open-code-floating-point-arithmetic? 411 true) 412 413(define compiler:primitives-with-no-open-coding 414 '(DIVIDE-FIXNUM GCD-FIXNUM &/ FLONUM-EXPM1 FLONUM-LOG1P))