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;;;; LAP Generation Rules 28;;; package: (compiler lap-syntaxer) 29 30(declare (usual-integrations)) 31 32(define-rule statement 33 (ASSIGN (REGISTER (? target)) 34 (REGISTER (? source))) 35 (move-to-alias-register! source (register-type target) target) 36 (LAP)) 37 38(define-rule statement 39 (ASSIGN (REGISTER (? target)) 40 (? thunk parse-memory-ref)) 41 (receive (scale source) (thunk) 42 (let ((target (case scale 43 ((BYTE WORD) (word-target target)) 44 ((FLOAT) (float-target target)) 45 (else (error "Unexpected load scale:" scale))))) 46 (inst:load scale target source)))) 47 48(define-rule statement 49 (ASSIGN (? thunk parse-memory-ref) 50 (REGISTER (? source))) 51 (receive (scale target) (thunk) 52 (let ((source (case scale 53 ((BYTE WORD) (word-source source)) 54 ((FLOAT) (float-source source)) 55 (else (error "Unexpected store scale:" scale))))) 56 (inst:store scale source target)))) 57 58(define-rule statement 59 (ASSIGN (? thunk parse-memory-ref) 60 (CONSTANT (? constant))) 61 (receive (scale target) (thunk) 62 (let ((temp (case scale 63 ((BYTE WORD) (word-temporary)) 64 ((FLOAT) (float-temporary)) 65 (else (error "Unexpected store constant scale:" scale))))) 66 (LAP ,@(load-constant temp constant) 67 ,@(inst:store scale temp target))))) 68 69(define-rule statement 70 (ASSIGN (REGISTER (? target)) 71 (? thunk parse-memory-address)) 72 (receive (scale source-ea) (thunk) 73 scale 74 (inst:load-address (word-target target) source-ea))) 75 76(define-rule statement 77 (ASSIGN (REGISTER (? target)) 78 (CONSTANT (? object))) 79 (load-constant (word-target target) object)) 80 81(define-rule statement 82 (ASSIGN (REGISTER (? target)) 83 (MACHINE-CONSTANT (? n))) 84 (inst:load-immediate (word-target target) n)) 85 86(define-rule statement 87 (ASSIGN (REGISTER (? target)) 88 (ENTRY:PROCEDURE (? label))) 89 (inst:load-address (word-target target) 90 (ea:address (internal->external-label label)))) 91 92(define-rule statement 93 (ASSIGN (REGISTER (? target)) 94 (ENTRY:CONTINUATION (? label))) 95 (inst:load-address (word-target target) (ea:address label))) 96 97(define-rule statement 98 (ASSIGN (REGISTER (? target)) 99 (VARIABLE-CACHE (? name))) 100 (inst:load 'WORD 101 (word-target target) 102 (ea:address (free-reference-label name)))) 103 104(define-rule statement 105 (ASSIGN (REGISTER (? target)) 106 (ASSIGNMENT-CACHE (? name))) 107 (inst:load 'WORD 108 (word-target target) 109 (ea:address (free-assignment-label name)))) 110 111(define-rule statement 112 (ASSIGN (REGISTER (? target)) 113 (CONS-NON-POINTER (REGISTER (? type)) 114 (REGISTER (? datum)))) 115 (let ((type (word-source type)) 116 (datum (word-source datum))) 117 (inst:load-non-pointer (word-target target) 118 type 119 datum))) 120 121(define-rule statement 122 (ASSIGN (REGISTER (? target)) 123 (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) 124 (REGISTER (? datum)))) 125 (let ((datum (word-source datum))) 126 (inst:load-non-pointer (word-target target) 127 type 128 datum))) 129 130(define-rule statement 131 (ASSIGN (REGISTER (? target)) 132 (CONS-NON-POINTER (MACHINE-CONSTANT (? type)) 133 (MACHINE-CONSTANT (? datum)))) 134 (if (>= datum signed-fixnum/upper-limit) 135 (error "Can't encode non-pointer datum:" datum)) 136 (inst:load-non-pointer (word-target target) 137 type 138 datum)) 139 140(define-rule statement 141 (ASSIGN (REGISTER (? target)) 142 (CONS-POINTER (REGISTER (? type)) 143 (REGISTER (? datum)))) 144 (let ((type (word-source type)) 145 (datum (word-source datum))) 146 (inst:load-pointer (word-target target) 147 type 148 datum))) 149 150(define-rule statement 151 (ASSIGN (REGISTER (? target)) 152 (CONS-POINTER (MACHINE-CONSTANT (? type)) 153 (REGISTER (? datum)))) 154 (let ((datum (word-source datum))) 155 (inst:load-pointer (word-target target) 156 type 157 datum))) 158 159(define-rule statement 160 (ASSIGN (REGISTER (? target)) 161 (CONS-POINTER (MACHINE-CONSTANT (? type)) 162 (? thunk parse-memory-address))) 163 (receive (scale source-ea) (thunk) 164 scale 165 (let ((temp (word-temporary))) 166 (LAP ,@(inst:load-address temp source-ea) 167 ,@(inst:load-pointer (word-target target) type temp))))) 168 169(define-rule statement 170 (ASSIGN (REGISTER (? target)) 171 (CONS-POINTER (MACHINE-CONSTANT (? type)) 172 (ENTRY:PROCEDURE (? label)))) 173 (let ((temp (word-temporary))) 174 (LAP ,@(inst:load-address temp (ea:address (rtl-procedure/external-label 175 (label->object label)))) 176 ,@(inst:load-pointer (word-target target) type temp)))) 177 178(define-rule statement 179 (ASSIGN (REGISTER (? target)) 180 (CONS-POINTER (MACHINE-CONSTANT (? type)) 181 (ENTRY:CONTINUATION (? label)))) 182 (let ((temp (word-temporary))) 183 (LAP ,@(inst:load-address temp (ea:address label)) 184 ,@(inst:load-pointer (word-target target) type temp)))) 185 186(define-rule statement 187 (ASSIGN (REGISTER (? target)) 188 (OBJECT->TYPE (REGISTER (? source)))) 189 (let ((source (word-source source))) 190 (inst:object-type (word-target target) 191 source))) 192 193(define-rule statement 194 (ASSIGN (REGISTER (? target)) 195 (OBJECT->TYPE (CONSTANT (? object)))) 196 (inst:load-immediate (word-target target) 197 (object-type object))) 198 199(define-rule statement 200 (ASSIGN (REGISTER (? target)) 201 (OBJECT->DATUM (REGISTER (? source)))) 202 (let ((source (word-source source))) 203 (inst:object-datum (word-target target) 204 source))) 205 206(define-rule statement 207 (ASSIGN (REGISTER (? target)) 208 (OBJECT->DATUM (CONSTANT (? object)))) 209 (QUALIFIER (and (object-non-pointer? object) 210 (load-immediate-operand? (object-datum object)))) 211 (inst:load-immediate (word-target target) 212 (object-datum object))) 213 214(define-rule statement 215 (ASSIGN (REGISTER (? target)) 216 (OBJECT->ADDRESS (REGISTER (? source)))) 217 (let ((source (word-source source))) 218 (inst:object-address (word-target target) 219 source))) 220 221(define-rule statement 222 (ASSIGN (REGISTER (? target)) 223 (CHAR->ASCII (REGISTER (? source)))) 224 (let ((source (word-source source))) 225 (inst:object-datum (word-target target) 226 source))) 227 228(define-rule statement 229 (ASSIGN (REGISTER (? target)) 230 (CHAR->ASCII (CONSTANT (? char)))) 231 (QUALIFIER (and (char? char) (char-ascii? char))) 232 (inst:load-immediate (word-target target) 233 (object-datum char))) 234 235(define-rule predicate 236 (TYPE-TEST (REGISTER (? source)) (? type)) 237 (let ((temp (word-temporary))) 238 (simple-branches! 'EQ (word-source source) temp) 239 (inst:load-immediate temp type))) 240 241(define-rule predicate 242 (EQ-TEST (REGISTER (? source1)) 243 (REGISTER (? source2))) 244 (simple-branches! 'EQ 245 (word-source source1) 246 (word-source source2)) 247 (LAP)) 248 249(define-rule predicate 250 (EQ-TEST (REGISTER (? source1)) (CONSTANT (? constant))) 251 (QUALIFIER (non-pointer-object? constant)) 252 (let ((temp (word-temporary))) 253 (simple-branches! 'EQ (word-source source1) temp) 254 (load-constant temp constant))) 255 256(define-rule predicate 257 (PRED-1-ARG INDEX-FIXNUM? 258 (REGISTER (? source))) 259 (simple-branches! 'IFIX (word-source source)) 260 (LAP)) 261 262;;;; Fixnums 263 264(define-rule statement 265 (ASSIGN (REGISTER (? target)) 266 (OBJECT->FIXNUM (REGISTER (? source)))) 267 (let ((source (word-source source))) 268 (inst:fixnum->integer (word-target target) 269 source))) 270 271(define-rule statement 272 (ASSIGN (REGISTER (? target)) 273 (FIXNUM->OBJECT (REGISTER (? source)))) 274 (let ((source (word-source source))) 275 (inst:integer->fixnum (word-target target) 276 source))) 277 278;; The next two are no-ops on this architecture. 279 280(define-rule statement 281 (ASSIGN (REGISTER (? target)) 282 (ADDRESS->FIXNUM (REGISTER (? source)))) 283 (move-to-alias-register! source (register-type target) target) 284 (LAP)) 285 286(define-rule statement 287 (ASSIGN (REGISTER (? target)) 288 (FIXNUM->ADDRESS (REGISTER (? source)))) 289 (move-to-alias-register! source (register-type target) target) 290 (LAP)) 291 292(define-rule predicate 293 (FIXNUM-PRED-1-ARG (? predicate) 294 (REGISTER (? source))) 295 (simple-branches! (case predicate 296 ((ZERO-FIXNUM?) 'EQ) 297 ((NEGATIVE-FIXNUM?) 'SLT) 298 ((POSITIVE-FIXNUM?) 'SGT) 299 (else (error "Unknown fixnum predicate:" predicate))) 300 (word-source source)) 301 (LAP)) 302 303(define-rule predicate 304 (FIXNUM-PRED-2-ARGS (? predicate) 305 (REGISTER (? source1)) 306 (REGISTER (? source2))) 307 (simple-branches! (case predicate 308 ((EQUAL-FIXNUM?) 'EQ) 309 ((LESS-THAN-FIXNUM?) 'SLT) 310 ((GREATER-THAN-FIXNUM?) 'SGT) 311 ((UNSIGNED-LESS-THAN-FIXNUM?) 'LT) 312 ((UNSIGNED-GREATER-THAN-FIXNUM?) 'GT) 313 (else (error "Unknown fixnum predicate:" predicate))) 314 (word-source source1) 315 (word-source source2)) 316 (LAP)) 317 318(define-rule predicate 319 (OVERFLOW-TEST) 320 ;; The fixnum methods must test for overflow. 321 (LAP)) 322 323(define-rule statement 324 (ASSIGN (REGISTER (? target)) 325 (FIXNUM-1-ARG (? operation) 326 (REGISTER (? source)) 327 (? overflow?))) 328 (let ((source (word-source source))) 329 ((or (1d-table/get fixnum-1-arg-methods operation #f) 330 (error "Unknown fixnum operation:" operation)) 331 (word-target target) 332 source 333 overflow?))) 334 335(define fixnum-1-arg-methods 336 (make-1d-table)) 337 338(define (define-fixnum-1-arg-method name method) 339 (1d-table/put! fixnum-1-arg-methods name method)) 340 341(let ((standard 342 (lambda (name inst) 343 (define-fixnum-1-arg-method name 344 (lambda (target source overflow?) 345 (if overflow? (simple-branches! 'NFIX target)) 346 (inst target source)))))) 347 (standard 'ONE-PLUS-FIXNUM inst:increment) 348 (standard 'MINUS-ONE-PLUS-FIXNUM inst:decrement) 349 (standard 'FIXNUM-NEGATE inst:negate) 350 (standard 'FIXNUM-NOT inst:not)) 351 352(define-rule statement 353 (ASSIGN (REGISTER (? target)) 354 (FIXNUM-2-ARGS (? operation) 355 (REGISTER (? source1)) 356 (REGISTER (? source2)) 357 (? overflow?))) 358 (let ((source1 (word-source source1)) 359 (source2 (word-source source2))) 360 ((or (1d-table/get fixnum-2-args-methods operation #f) 361 (error "Unknown fixnum operation:" operation)) 362 (word-target target) 363 source1 364 source2 365 overflow?))) 366 367(define fixnum-2-args-methods 368 (make-1d-table)) 369 370(define (define-fixnum-2-args-method name method) 371 (1d-table/put! fixnum-2-args-methods name method)) 372 373(let ((standard 374 (lambda (name inst) 375 (define-fixnum-2-args-method name 376 (lambda (target source1 source2 overflow?) 377 (if overflow? (simple-branches! 'NFIX target)) 378 (inst target source1 source2)))))) 379 (standard 'PLUS-FIXNUM inst:+) 380 (standard 'MINUS-FIXNUM inst:-) 381 (standard 'FIXNUM-QUOTIENT inst:quotient) 382 (standard 'FIXNUM-REMAINDER inst:remainder) 383 (standard 'FIXNUM-LSH inst:lsh) 384 (standard 'FIXNUM-AND inst:and) 385 (standard 'FIXNUM-ANDC inst:andc) 386 (standard 'FIXNUM-OR inst:or) 387 (standard 'FIXNUM-XOR inst:xor)) 388 389(define-fixnum-2-args-method 'MULTIPLY-FIXNUM 390 (lambda (target source1 source2 overflow?) 391 (if overflow? (simple-branches! 'NFIX target)) 392 ((if overflow? inst:product inst:*) 393 target source1 source2))) 394 395;;;; Flonums 396 397(define-rule statement 398 (ASSIGN (REGISTER (? target)) 399 (FLOAT->OBJECT (REGISTER (? source)))) 400 (let ((source (float-source source)) 401 (temp (word-temporary))) 402 (LAP ,@(inst:flonum-align rref:free-pointer rref:free-pointer) 403 ,@(inst:load-pointer (word-target target) 404 (ucode-type flonum) 405 rref:free-pointer) 406 ,@(inst:flonum-header temp 1) 407 ,@(inst:store 'WORD temp (ea:alloc-word)) 408 ,@(inst:store 'FLOAT source (ea:alloc-float))))) 409 410(define-rule statement 411 (ASSIGN (REGISTER (? target)) 412 (OBJECT->FLOAT (REGISTER (? source)))) 413 (let ((source (word-source source)) 414 (temp (word-temporary))) 415 (LAP ,@(inst:object-address temp source) 416 ,@(inst:load 'FLOAT 417 (float-target target) 418 (ea:offset temp 1 'WORD))))) 419 420(define-rule statement 421 (ASSIGN (REGISTER (? target)) 422 (OBJECT->FLOAT (CONSTANT (? value)))) 423 (QUALIFIER (flo:flonum? value)) 424 (inst:load-immediate (float-target target) value)) 425 426(define-rule predicate 427 (FLONUM-PRED-1-ARG (? predicate) 428 (REGISTER (? source))) 429 (simple-branches! (case predicate 430 ((FLONUM-ZERO?) 'EQ) 431 ((FLONUM-NEGATIVE?) 'LT) 432 ((FLONUM-POSITIVE?) 'GT) 433 (else (error "Unknown flonum predicate:" predicate))) 434 (float-source source)) 435 (LAP)) 436 437(define-rule predicate 438 (FLONUM-PRED-2-ARGS (? predicate) 439 (REGISTER (? source1)) 440 (REGISTER (? source2))) 441 (simple-branches! (case predicate 442 ((FLONUM-EQUAL?) 'EQ) 443 ((FLONUM-LESS?) 'LT) 444 ((FLONUM-GREATER?) 'GT) 445 (else (error "Unknown flonum predicate:" predicate))) 446 (float-source source1) 447 (float-source source2)) 448 (LAP)) 449 450(define-rule predicate 451 (FLONUM-PRED-2-ARGS (? predicate) 452 (REGISTER (? source1)) 453 (OBJECT->FLOAT (CONSTANT (? constant)))) 454 (QUALIFIER (flo:flonum? constant)) 455 (let ((temp (float-temporary))) 456 (simple-branches! (case predicate 457 ((FLONUM-EQUAL?) 'EQ) 458 ((FLONUM-LESS?) 'LT) 459 ((FLONUM-GREATER?) 'GT) 460 (else (error "Unknown flonum predicate:" predicate))) 461 (float-source source1) temp) 462 (inst:load-immediate temp constant))) 463 464(define-rule predicate 465 (FLONUM-PRED-2-ARGS (? predicate) 466 (OBJECT->FLOAT (CONSTANT (? constant))) 467 (REGISTER (? source))) 468 (QUALIFIER (flo:flonum? constant)) 469 (let ((temp (float-temporary))) 470 (simple-branches! (case predicate 471 ((FLONUM-EQUAL?) 'EQ) 472 ((FLONUM-LESS?) 'LT) 473 ((FLONUM-GREATER?) 'GT) 474 (else (error "Unknown flonum predicate:" predicate))) 475 temp (float-source source)) 476 (inst:load-immediate temp constant))) 477 478(define-rule statement 479 (ASSIGN (REGISTER (? target)) 480 (FLONUM-1-ARG (? operation) 481 (REGISTER (? source)) 482 (? overflow?))) 483 (let ((source (float-source source))) 484 ((or (1d-table/get flonum-1-arg-methods operation #f) 485 (error "Unknown flonum operation:" operation)) 486 (float-target target) 487 source 488 overflow?))) 489 490(define flonum-1-arg-methods 491 (make-1d-table)) 492 493(define (define-flonum-1-arg-method name method) 494 (1d-table/put! flonum-1-arg-methods name method)) 495 496(let ((standard 497 (lambda (name inst) 498 (define-flonum-1-arg-method name 499 (lambda (target source overflow?) 500 overflow? 501 (inst target source)))))) 502 (standard 'FLONUM-NEGATE inst:negate) 503 (standard 'FLONUM-ABS inst:abs) 504 (standard 'FLONUM-SQRT inst:sqrt) 505 (standard 'FLONUM-ROUND inst:round) 506 (standard 'FLONUM-CEILING inst:ceiling) 507 (standard 'FLONUM-FLOOR inst:floor) 508 (standard 'FLONUM-TRUNCATE inst:truncate) 509 (standard 'FLONUM-LOG inst:log) 510 (standard 'FLONUM-EXP inst:exp) 511 (standard 'FLONUM-COS inst:cos) 512 (standard 'FLONUM-SIN inst:sin) 513 (standard 'FLONUM-TAN inst:tan) 514 (standard 'FLONUM-ACOS inst:acos) 515 (standard 'FLONUM-ASIN inst:asin) 516 (standard 'FLONUM-ATAN inst:atan)) 517 518(define-rule statement 519 (ASSIGN (REGISTER (? target)) 520 (FLONUM-2-ARGS (? operation) 521 (REGISTER (? source1)) 522 (REGISTER (? source2)) 523 (? overflow?))) 524 (let ((source1 (float-source source1)) 525 (source2 (float-source source2))) 526 ((or (1d-table/get flonum-2-args-methods operation #f) 527 (error "Unknown flonum operation:" operation)) 528 (float-target target) 529 source1 530 source2 531 overflow?))) 532 533(define-rule statement 534 (ASSIGN (REGISTER (? target)) 535 (FLONUM-2-ARGS (? operation) 536 (REGISTER (? source1)) 537 (OBJECT->FLOAT (CONSTANT (? value))) 538 (? overflow?))) 539 (let ((source1 (float-source source1)) 540 (temp (float-temporary))) 541 (LAP ,@(inst:load-immediate temp value) 542 ,@((or (1d-table/get flonum-2-args-methods operation #f) 543 (error "Unknown flonum operation:" operation)) 544 (float-target target) 545 source1 546 temp 547 overflow?)))) 548 549(define-rule statement 550 (ASSIGN (REGISTER (? target)) 551 (FLONUM-2-ARGS (? operation) 552 (OBJECT->FLOAT (CONSTANT (? value))) 553 (REGISTER (? source2)) 554 (? overflow?))) 555 (let ((source2 (float-source source2)) 556 (temp (float-temporary))) 557 (LAP ,@(inst:load-immediate temp value) 558 ,@((or (1d-table/get flonum-2-args-methods operation #f) 559 (error "Unknown flonum operation:" operation)) 560 (float-target target) 561 temp 562 source2 563 overflow?)))) 564 565(define flonum-2-args-methods 566 (make-1d-table)) 567 568(define (define-flonum-2-args-method name method) 569 (1d-table/put! flonum-2-args-methods name method)) 570 571(let ((standard 572 (lambda (name inst) 573 (define-flonum-2-args-method name 574 (lambda (target source1 source2 overflow?) 575 overflow? 576 (inst target source1 source2)))))) 577 (standard 'FLONUM-ADD inst:+) 578 (standard 'FLONUM-SUBTRACT inst:-) 579 (standard 'FLONUM-MULTIPLY inst:*) 580 (standard 'FLONUM-DIVIDE inst:/) 581 (standard 'FLONUM-ATAN2 inst:atan2)) 582 583;;;; Invocations 584 585(define-rule statement 586 (POP-RETURN) 587 ;; The continuation is on the stack. 588 ;; The type code needs to be cleared first. 589 (let ((checks (get-exit-interrupt-checks))) 590 (LAP ,@(clear-map!) 591 ,@(if (null? checks) '() (inst:interrupt-test-continuation)) 592 ,@(inst:load 'WORD rref:word-0 (ea:stack-pop)) 593 ,@(inst:object-address rref:word-0 rref:word-0) 594 ,@(inst:jump (ea:indirect rref:word-0))))) 595 596(define-rule statement 597 (INVOCATION:APPLY (? frame-size) (? continuation)) 598 continuation 599 (expect-no-exit-interrupt-checks) 600 (LAP ,@(clear-map!) 601 ,@(inst:load 'WORD rref:word-0 (ea:stack-pop)) 602 ,@(inst:load-immediate rref:word-1 frame-size) 603 ,@(trap:apply rref:word-0 rref:word-1))) 604 605(define-rule statement 606 (INVOCATION:JUMP (? frame-size) (? continuation) (? label)) 607 frame-size continuation 608 (expect-no-exit-interrupt-checks) 609 (LAP ,@(clear-map!) 610 ,@(inst:jump (ea:address label)))) 611 612(define-rule statement 613 (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation)) 614 frame-size continuation 615 (expect-no-exit-interrupt-checks) 616 (LAP ,@(clear-map!) 617 ,@(inst:load 'WORD rref:word-0 (ea:stack-pop)) 618 ,@(inst:object-address rref:word-0 rref:word-0) 619 ,@(inst:jump (ea:indirect rref:word-0)))) 620 621(define-rule statement 622 (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label)) 623 continuation 624 (expect-no-exit-interrupt-checks) 625 (LAP ,@(clear-map!) 626 ,@(inst:load-address rref:word-0 (ea:address label)) 627 ,@(inst:load-immediate rref:word-1 number-pushed) 628 ,@(trap:lexpr-apply rref:word-0 rref:word-1))) 629 630(define-rule statement 631 (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation)) 632 continuation 633 (expect-no-exit-interrupt-checks) 634 (LAP ,@(clear-map!) 635 ,@(inst:load 'WORD rref:word-0 (ea:stack-pop)) 636 ,@(inst:object-address rref:word-0 rref:word-0) 637 ,@(inst:load-immediate rref:word-1 number-pushed) 638 ,@(trap:lexpr-apply rref:word-0 rref:word-1))) 639 640(define-rule statement 641 (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) 642 continuation 643 (expect-no-exit-interrupt-checks) 644 (LAP ,@(clear-map!) 645 ,@(inst:jump (ea:uuo-entry-address 646 (free-uuo-link-label name frame-size))))) 647 648(define-rule statement 649 (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name)) 650 continuation 651 (expect-no-exit-interrupt-checks) 652 (LAP ,@(clear-map!) 653 ,@(inst:jump (ea:uuo-entry-address 654 (global-uuo-link-label name frame-size))))) 655 656(define-rule statement 657 (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension)) 658 (QUALIFIER (interpreter-call-argument? extension)) 659 continuation 660 (expect-no-exit-interrupt-checks) 661 (let ((rref:cache-addr (interpreter-call-temporary extension)) 662 (rref:block-addr (word-temporary)) 663 (rref:frame-size (word-temporary))) 664 (LAP ,@(clear-map!) 665 ,@(inst:load-immediate rref:frame-size frame-size) 666 ,@(inst:load-address rref:block-addr (ea:address *block-label*)) 667 ,@(trap:cache-reference-apply 668 rref:cache-addr rref:block-addr rref:frame-size)))) 669 670#| There is no comutil_lookup_apply, no (trap:lookup-apply ...) instruction. 671 (define-rule statement 672 (INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name)) 673 (QUALIFIER (interpreter-call-argument? environment)) 674 continuation 675 (expect-no-entry-interrupt-checks) 676 (let ((rref:environment (interpreter-call-temporary environment)) 677 (rref:frame-size (word-temporary)) 678 (rref:name (word-temporary))) 679 (LAP ,@(clear-map!) 680 ,@(inst:load-immediate rref:frame-size frame-size) 681 ,@(load-constant rref:name name) 682 ,@(trap:lookup-apply rref:environment rref:frame-size rref:name)))) 683|# 684 685(define-rule statement 686 (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) 687 continuation ; ignored 688 (LAP ,@(clear-map!) 689 ,@(if (eq? primitive compiled-error-procedure) 690 (LAP ,@(inst:load-immediate rref:word-0 frame-size) 691 ,@(trap:error rref:word-0)) 692 (LAP ,@(load-constant rref:word-0 primitive) 693 ,@(let ((arity (primitive-procedure-arity primitive))) 694 (cond 695 ((>= arity 0) 696 (trap:primitive-apply rref:word-0)) 697 ((= arity -1) 698 (LAP 699 ,@(inst:load-immediate rref:word-1 (- frame-size 1)) 700 ,@(inst:store 'WORD rref:word-1 (ea:lexpr-actuals)) 701 ,@(trap:primitive-lexpr-apply rref:word-0))) 702 (else 703 (LAP ,@(inst:load-immediate rref:word-1 frame-size) 704 ,@(trap:apply rref:word-0 rref:word-1))))))))) 705 706(define-syntax define-primitive-invocation 707 (sc-macro-transformer 708 (lambda (form environment) 709 (let ((name (cadr form))) 710 `(define-rule statement 711 (INVOCATION:SPECIAL-PRIMITIVE (? frame-size) 712 (? continuation) 713 ,(make-primitive-procedure name #t)) 714 frame-size continuation 715 (expect-no-exit-interrupt-checks) 716 (%primitive-invocation 717 ,(close-syntax (symbol-append 'TRAP: name) environment))))))) 718 719(define (%primitive-invocation make-trap) 720 (LAP ,@(clear-map!) 721 ,@(make-trap))) 722 723(define-primitive-invocation &+) 724(define-primitive-invocation &-) 725(define-primitive-invocation &*) 726(define-primitive-invocation &/) 727(define-primitive-invocation &=) 728(define-primitive-invocation &<) 729(define-primitive-invocation &>) 730(define-primitive-invocation 1+) 731(define-primitive-invocation -1+) 732(define-primitive-invocation zero?) 733(define-primitive-invocation positive?) 734(define-primitive-invocation negative?) 735(define-primitive-invocation quotient) 736(define-primitive-invocation remainder) 737 738;;; Invocation Prefixes 739 740(define-rule statement 741 (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? register))) 742 (move-frame-up frame-size (word-source register))) 743 744(define-rule statement 745 (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size) 746 (REGISTER (? r1)) 747 (REGISTER (? r2))) 748 (if (and (= frame-size 0) 749 (= r1 regnum:stack-pointer)) 750 (LAP) 751 (let ((temp (word-temporary))) 752 (LAP ,@(inst:min-unsigned temp (word-source r1) (word-source r2)) 753 ,@(move-frame-up frame-size temp))))) 754 755(define (move-frame-up frame-size source) 756 (if (= frame-size 0) 757 (if (= (reference->register source) regnum:stack-pointer) 758 (LAP) 759 (inst:copy rref:stack-pointer source)) 760 (let ((temp (word-temporary))) 761 (LAP ,@(inst:load-address temp (ea:offset source (- frame-size) 'WORD)) 762 ,@(inst:copy-block frame-size 'WORD rref:stack-pointer temp) 763 ,@(inst:copy rref:stack-pointer temp))))) 764 765;;;; Procedure headers 766 767;;; The following calls MUST appear as the first thing at the entry 768;;; point of a procedure. They assume that the register map is clear 769;;; and that no register contains anything of value. 770;;; 771;;; The only reason that this is true is that no register is live 772;;; across calls. If that were not true, then we would have to save 773;;; any such registers on the stack so that they would be GC'ed 774;;; appropriately. 775;;; 776;;; The only exception is the dynamic link register, handled 777;;; specially. Procedures that require a dynamic link use a different 778;;; interrupt handler that saves and restores the dynamic link 779;;; register. 780 781(define (simple-procedure-header label interrupt-test) 782 (let ((checks (get-entry-interrupt-checks))) 783 (if (null? checks) 784 label 785 (LAP ,@label 786 ,@(interrupt-test))))) 787 788(define-rule statement 789 (CONTINUATION-ENTRY (? label)) 790 (expect-no-entry-interrupt-checks) 791 (make-continuation-label label label)) 792 793(define-rule statement 794 (CONTINUATION-HEADER (? label)) 795 (expect-no-entry-interrupt-checks) 796 (make-continuation-label label label)) 797 798(define-rule statement 799 (IC-PROCEDURE-HEADER (? internal-label)) 800 (get-entry-interrupt-checks) ; force search 801 (let ((external-label (internal->external-label internal-label))) 802 (LAP (ENTRY-POINT ,external-label) 803 (EQUATE ,external-label ,internal-label) 804 ,@(make-expression-label internal-label) 805 ,@(inst:interrupt-test-ic-procedure)))) 806 807(define-rule statement 808 (OPEN-PROCEDURE-HEADER (? internal-label)) 809 (let ((rtl-proc (label->object internal-label))) 810 (LAP (EQUATE ,(internal->external-label internal-label) ,internal-label) 811 ,@(simple-procedure-header 812 (make-internal-procedure-label internal-label) 813 (if (rtl-procedure/dynamic-link? rtl-proc) 814 inst:interrupt-test-dynamic-link 815 inst:interrupt-test-procedure))))) 816 817(define-rule statement 818 (PROCEDURE-HEADER (? internal-label) (? min) (? max)) 819 (LAP (EQUATE ,(internal->external-label internal-label) ,internal-label) 820 ,@(simple-procedure-header 821 (make-procedure-label min max internal-label) 822 inst:interrupt-test-procedure))) 823 824;; Interrupt check placement 825;; 826;; The first two procedures are the interface. 827;; GET-EXIT-INTERRUPT-CHECKS and GET-ENTRY-INTERRUPT-CHECKS get a list 828;; of kinds interrupt check. An empty list implies no check is 829;; required. The list can contain these symbols: 830;; 831;; STACK stack check required here 832;; HEAP heap check required here 833;; INTERRUPT check required here to avoid loops without checks. 834;; 835;; The traversal and decision making is done immediately prior to LAP 836;; generation (from PRE-LAPGEN-ANALYSIS.) 837 838(define (get-entry-interrupt-checks) 839 (get-interrupt-checks 'ENTRY-INTERRUPT-CHECKS)) 840 841(define (get-exit-interrupt-checks) 842 (get-interrupt-checks 'EXIT-INTERRUPT-CHECKS)) 843 844(define (expect-no-entry-interrupt-checks) 845 (if (not (null? (get-entry-interrupt-checks))) 846 (error "No entry interrupt checks expected here:" *current-bblock*))) 847 848(define (expect-no-exit-interrupt-checks) 849 (if (not (null? (get-exit-interrupt-checks))) 850 (error "No exit interrupt checks expected here:" *current-bblock*))) 851 852(define (get-interrupt-checks kind) 853 (cdr (or (cfg-node-get *current-bblock* kind) 854 (error "DETERMINE-INTERRUPT-CHECKS failed:" kind)))) 855 856;; This algorithm finds leaf-procedure-like paths in the rtl control 857;; flow graph. If a procedure entry point can only reach a return, it 858;; is leaf-like. If a return can only be reached from a procedure 859;; entry, it too is leaf-like. 860;; 861;; If a procedure reaches a procedure call, that could be a loop, so 862;; it is not leaf-like. Similarly, if a continuation entry reaches 863;; return, that could be a long unwinding of recursion, so a check is 864;; needed in case the unwinding does allocation. 865;; 866;; Typically, true leaf procedures avoid both checks, and trivial 867;; cases (like MAP returning '()) avoid the exit check. 868;; 869;; This could be a lot smarter. For example, a procedure entry does 870;; not need to check for interrupts if it reaches call sites of 871;; strictly lesser arity; or it could analyze the cycles in the CFG 872;; and select good places to break them 873;; 874;; The algorithm has three phases: (1) explore the CFG to find all 875;; entry and exit points, (2) propagate entry (exit) information so 876;; that each potential interrupt check point knows what kinds of exits 877;; (entrys) it reaches (is reached from), and (3) decide on the kinds 878;; of interrupt check that are required at each entry and exit. 879;; 880;; [TOFU is just a header node for the list of interrupt checks, to 881;; distingish () and #F] 882 883(define (determine-interrupt-checks bblock) 884 (let ((entries '()) 885 (exits '())) 886 887 (define (explore bblock) 888 (or (cfg-node-get bblock 'INTERRUPT-CHECK-EXPLORE) 889 (begin 890 (cfg-node-put! bblock 'INTERRUPT-CHECK-EXPLORE #T) 891 (if (node-previous=0? bblock) 892 (set! entries (cons bblock entries)) 893 (if (rtl:continuation-entry? 894 (rinst-rtl (bblock-instructions bblock))) 895 ;; previous block is invocation:special-primitive 896 ;; so it is just an out of line instruction 897 (cfg-node-put! bblock 'ENTRY-INTERRUPT-CHECKS '(TOFU)))) 898 899 (for-each-previous-node bblock explore) 900 (for-each-subsequent-node bblock explore) 901 (if (and (snode? bblock) 902 (or (not (snode-next bblock)) 903 (let ((last (last-insn bblock))) 904 (or (rtl:invocation:special-primitive? last) 905 (rtl:invocation:primitive? last))))) 906 (set! exits (cons bblock exits)))))) 907 908 (define (for-each-subsequent-node node procedure) 909 (if (snode? node) 910 (if (snode-next node) 911 (procedure (snode-next node))) 912 (begin 913 (procedure (pnode-consequent node)) 914 (procedure (pnode-alternative node))))) 915 916 (define (propagator for-each-link) 917 (lambda (node update place) 918 (let propagate ((node node)) 919 (let ((old (cfg-node-get node place))) 920 (let ((new (update old))) 921 (if (not (equal? old new)) 922 (begin 923 (cfg-node-put! node place new) 924 (for-each-link node propagate)))))))) 925 926 (define upward (propagator for-each-previous-node)) 927 (define downward (propagator for-each-subsequent-node)) 928 929 (define (setting-flag old) old #T) 930 931 (define (propagate-entry-info bblock) 932 (let ((insn (rinst-rtl (bblock-instructions bblock)))) 933 (cond ((or (rtl:continuation-entry? insn) 934 (rtl:continuation-header? insn)) 935 (downward bblock setting-flag 'REACHED-FROM-CONTINUATION)) 936 ((or (rtl:closure-header? insn) 937 (rtl:ic-procedure-header? insn) 938 (rtl:open-procedure-header? insn) 939 (rtl:procedure-header? insn)) 940 (downward bblock setting-flag 'REACHED-FROM-PROCEDURE)) 941 (else unspecific)))) 942 943 (define (propagate-exit-info exit-bblock) 944 (let ((insn (last-insn exit-bblock))) 945 (cond ((rtl:pop-return? insn) 946 (upward exit-bblock setting-flag 'REACHES-POP-RETURN)) 947 (else 948 (upward exit-bblock setting-flag 'REACHES-INVOCATION))))) 949 950 (define (decide-entry-checks bblock) 951 (define (checks! types) 952 (cfg-node-put! bblock 'ENTRY-INTERRUPT-CHECKS (cons 'TOFU types))) 953 (define (decide-label internal-label) 954 (let ((object (label->object internal-label))) 955 (let ((stack? 956 (if (and (rtl-procedure? object) 957 (not (rtl-procedure/stack-leaf? object)) 958 compiler:generate-stack-checks?) 959 '(STACK) 960 '()))) 961 (if (or (cfg-node-get bblock 'REACHES-INVOCATION) 962 (pair? stack?)) 963 (checks! (cons* 'HEAP 'INTERRUPT stack?)) 964 (checks! '()))))) 965 966 (let ((insn (rinst-rtl (bblock-instructions bblock)))) 967 (cond ((rtl:continuation-entry? insn) (checks! '())) 968 ((rtl:continuation-header? insn) (checks! '())) 969 ((rtl:closure-header? insn) 970 (decide-label (rtl:closure-header-procedure insn))) 971 ((rtl:ic-procedure-header? insn) 972 (decide-label (rtl:ic-procedure-header-procedure insn))) 973 ((rtl:open-procedure-header? insn) 974 (decide-label (rtl:open-procedure-header-procedure insn))) 975 ((rtl:procedure-header? insn) 976 (decide-label (rtl:procedure-header-procedure insn))) 977 (else 978 (checks! '(INTERRUPT)))))) 979 980 (define (last-insn bblock) 981 (rinst-rtl (rinst-last (bblock-instructions bblock)))) 982 983 (define (decide-exit-checks bblock) 984 (define (checks! types) 985 (cfg-node-put! bblock 'EXIT-INTERRUPT-CHECKS (cons 'TOFU types))) 986 (if (rtl:pop-return? (last-insn bblock)) 987 (if (cfg-node-get bblock 'REACHED-FROM-CONTINUATION) 988 (checks! '(INTERRUPT)) 989 (checks! '())) 990 (checks! '()))) 991 992 (explore bblock) 993 994 (for-each propagate-entry-info entries) 995 (for-each propagate-exit-info exits) 996 (for-each decide-entry-checks entries) 997 (for-each decide-exit-checks exits) 998 999 )) 1000 1001;;;; Closures: 1002 1003(define-integrable (low-byte short) (fix:and short #xFF)) 1004(define-integrable (high-byte short) (fix:lsh short -8)) 1005 1006(define (generate/cons-closure target procedure-label min max size) 1007 (let ((target (word-target target)) 1008 (temp (word-temporary)) 1009 (free rref:free-pointer) 1010 (total-words (+ 1 ;; header 1011 1 ;; count 1012 1 ;; padded entry 1013 1 ;; targets 1014 size ;; variables 1015 )) 1016 (entry-type (encode-procedure-type min max)) 1017 (label (internal->external-label procedure-label)) 1018 (count-offset (* 1 address-units-per-object)) 1019 (entry-offset (* 2 address-units-per-object)) 1020 (target-offset (* 3 address-units-per-object))) 1021 (LAP 1022 ;; header 1023 ,@(inst:load-non-pointer temp 1024 (ucode-type manifest-closure) (-1+ total-words)) 1025 ,@(inst:store 'WORD temp (ea:indirect free)) 1026 1027 ;; entry count 1028 ,@(inst:load-immediate temp 1) 1029 ,@(inst:store 'BYTE temp (ea:offset free count-offset 'BYTE)) 1030 ,@(inst:load-immediate temp 0) 1031 ,@(inst:store 'BYTE temp (ea:offset free (1+ count-offset) 'BYTE)) 1032 1033 ;; entry type 1034 ,@(inst:load-immediate temp (low-byte entry-type)) 1035 ,@(inst:store 'BYTE temp (ea:offset free (- entry-offset 2) 'BYTE)) 1036 ,@(inst:load-immediate temp (high-byte entry-type)) 1037 ,@(inst:store 'BYTE temp (ea:offset free (- entry-offset 1) 'BYTE)) 1038 1039 ;; entry point 1040 ,@(inst:load-address target (ea:offset free entry-offset 'BYTE)) 1041 ,@(inst:load-immediate temp svm1-inst:enter-closure) 1042 ,@(inst:store 'BYTE temp (ea:offset free entry-offset 'BYTE)) 1043 ,@(inst:load-immediate temp 0) 1044 ,@(inst:store 'BYTE temp (ea:offset free (+ 1 entry-offset) 'BYTE)) 1045 ,@(inst:store 'BYTE temp (ea:offset free (+ 2 entry-offset) 'BYTE)) 1046 1047 ;; target 1048 ,@(inst:load-address temp (ea:address label)) 1049 ,@(inst:load-pointer temp (ucode-type compiled-entry) temp) 1050 ,@(inst:store 'WORD temp (ea:offset free target-offset 'BYTE)) 1051 1052 ,@(inst:load-address free (ea:offset free total-words 'WORD))))) 1053 1054(define (generate/cons-multiclosure target nentries size entries) 1055 (let ((free rref:free-pointer)) 1056 (let ((entry-words (integer-ceiling (- (* closure-entry-size nentries) 1057 entry-type-size) 1058 address-units-per-object))) 1059 (let ((target (word-target target)) 1060 (temp (word-temporary)) 1061 (total-words (+ 1 ;; header 1062 1 ;; count 1063 entry-words ;; padded entries 1064 nentries ;; targets 1065 size ;; variables 1066 )) 1067 (count-offset (* 1 address-units-per-object)) 1068 (first-entry-offset (* 2 address-units-per-object)) 1069 (first-target-woffset (+ 1 1 entry-words))) 1070 1071 (define (generate-entries entries index offset) 1072 (let ((entry-type (let ((entry (car entries))) 1073 (let ((min (cadr entry)) 1074 (max (caddr entry))) 1075 (encode-procedure-type min max))))) 1076 (LAP 1077 ;; entry type 1078 ,@(inst:load-immediate temp (low-byte entry-type)) 1079 ,@(inst:store 'BYTE temp (ea:offset free (- offset 2) 'BYTE)) 1080 ,@(inst:load-immediate temp (high-byte entry-type)) 1081 ,@(inst:store 'BYTE temp (ea:offset free (- offset 1) 'BYTE)) 1082 1083 ;; entry point 1084 ,@(inst:load-immediate temp svm1-inst:enter-closure) 1085 ,@(inst:store 'BYTE temp (ea:offset free offset 'BYTE)) 1086 ,@(inst:load-immediate temp (low-byte index)) 1087 ,@(inst:store 'BYTE temp (ea:offset free (1+ offset) 'BYTE)) 1088 ,@(inst:load-immediate temp (high-byte index)) 1089 ,@(inst:store 'BYTE temp (ea:offset free (+ 2 offset) 'BYTE)) 1090 ,@(if (null? (cdr entries)) 1091 (LAP) 1092 (generate-entries (cdr entries) (1+ index) 1093 (+ offset closure-entry-size)))))) 1094 1095 (define (generate-targets entries woffset) 1096 (let ((label (internal->external-label (caar entries)))) 1097 (LAP 1098 ,@(inst:load-address temp (ea:address label)) 1099 ,@(inst:load-pointer temp (ucode-type compiled-entry) temp) 1100 ,@(inst:store 'WORD temp (ea:offset free woffset 'WORD)) 1101 ,@(if (null? (cdr entries)) 1102 (LAP) 1103 (generate-targets (cdr entries) (1+ woffset)))))) 1104 1105 (LAP 1106 ;; header 1107 ,@(inst:load-non-pointer temp 1108 (ucode-type manifest-closure) 1109 (-1+ total-words)) 1110 ,@(inst:store 'WORD temp (ea:indirect free)) 1111 1112 ;; entry count (little-endian short) 1113 ,@(inst:load-immediate temp (low-byte nentries)) 1114 ,@(inst:store 'BYTE temp (ea:offset free count-offset 'BYTE)) 1115 ,@(inst:load-immediate temp (high-byte nentries)) 1116 ,@(inst:store 'BYTE temp (ea:offset free (1+ count-offset) 'BYTE)) 1117 1118 ,@(inst:load-address target (ea:offset free first-entry-offset 'BYTE)) 1119 1120 ,@(generate-entries entries 0 first-entry-offset) 1121 1122 ,@(generate-targets entries first-target-woffset) 1123 1124 ,@(inst:load-address free (ea:offset free total-words 'WORD))))))) 1125 1126(define (generate/closure-header internal-label nentries index) 1127 index 1128 (let ((external-label (internal->external-label internal-label))) 1129 (LAP (EQUATE ,external-label ,internal-label) 1130 ,@(if (zero? nentries) 1131 (simple-procedure-header 1132 (make-internal-procedure-label internal-label) 1133 inst:interrupt-test-procedure) 1134 (make-internal-entry-label internal-label))))) 1135 1136(define-rule statement 1137 (CLOSURE-HEADER (? internal-label) (? nentries) (? entry)) 1138 (generate/closure-header internal-label nentries entry)) 1139 1140(define-rule statement 1141 (ASSIGN (REGISTER (? target)) 1142 (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) 1143 (? min) (? max) (? size))) 1144 (generate/cons-closure target procedure-label min max size)) 1145 1146(define-rule statement 1147 (ASSIGN (REGISTER (? target)) 1148 (CONS-MULTICLOSURE (? nentries) (? size) (? entries))) 1149 (case nentries 1150 ((0) 1151 (let ((target (word-target target)) 1152 (temp (word-temporary))) 1153 (LAP ,@(inst:load-pointer target 1154 (ucode-type compiled-entry) rref:free-pointer) 1155 1156 ,@(inst:load-non-pointer temp (ucode-type manifest-vector) size) 1157 ,@(inst:store 'WORD temp (ea:indirect rref:free-pointer)) 1158 1159 ,@(inst:load-address rref:free-pointer 1160 (ea:offset rref:free-pointer 1161 (1+ size) 'WORD))))) 1162 ((1) 1163 (let ((entry (vector-ref entries 0))) 1164 (generate/cons-closure target 1165 (car entry) (cadr entry) (caddr entry) 1166 size))) 1167 (else 1168 (generate/cons-multiclosure target nentries size 1169 (vector->list entries))))) 1170 1171;;;; Entry Header 1172;;; This is invoked by the top level of the LAP generator. 1173 1174(define (generate/quotation-header environment-label free-ref-label n-sections) 1175 (let ((rref:block-addr rref:word-0) 1176 (rref:constant-addr rref:word-1) 1177 (rref:n-sections rref:word-2)) 1178 (LAP ,@(inst:load 'WORD rref:word-0 (ea:environment)) 1179 ,@(inst:store 'WORD rref:word-0 (ea:address environment-label)) 1180 ,@(inst:load-address rref:block-addr (ea:address *block-label*)) 1181 ,@(inst:load-address rref:constant-addr (ea:address free-ref-label)) 1182 ,@(inst:load-immediate rref:n-sections n-sections) 1183 ,@(trap:link rref:block-addr rref:constant-addr rref:n-sections) 1184 ,@(make-continuation-label false (generate-label))))) 1185 1186(define (generate/remote-link code-block-label 1187 environment-offset 1188 free-ref-offset 1189 n-sections) 1190 (let ((rref:block-addr rref:word-0) 1191 (rref:constant-addr rref:word-1) 1192 (rref:n-sections rref:word-2) 1193 (rref:environment rref:word-3)) 1194 (LAP ,@(inst:load 'WORD rref:block-addr (ea:address code-block-label)) 1195 ,@(inst:object-address rref:block-addr rref:block-addr) 1196 ,@(inst:load 'WORD rref:environment (ea:environment)) 1197 ,@(inst:store 'WORD rref:environment 1198 (ea:offset rref:block-addr environment-offset 'BYTE)) 1199 ,@(inst:load-address rref:constant-addr 1200 (ea:offset rref:block-addr free-ref-offset 'BYTE)) 1201 ,@(inst:load-immediate rref:n-sections n-sections) 1202 ,@(trap:link rref:block-addr rref:constant-addr rref:n-sections) 1203 ,@(make-continuation-label false (generate-label))))) 1204 1205(define (generate/remote-links n-blocks vector-label n-sections) 1206 (if (> n-blocks 0) 1207 (let ((loop-label (generate-label)) 1208 (bytes-label (generate-label)) 1209 (end-label (generate-label)) 1210 1211 (rref:index rref:word-0) 1212 (rref:bytes rref:word-1) 1213 (rref:vector rref:word-2) 1214 (rref:block rref:word-3) 1215 (rref:n-sections rref:word-4) 1216 (rref:sections rref:word-5) 1217 (rref:length rref:word-6) 1218 (rref:environment rref:word-7)) 1219 (LAP 1220 ;; Init index. 1221 ,@(inst:load-immediate rref:index 0) 1222 1223 ,@(inst:label loop-label) 1224 ;; Re-init bytes, vector, environment. 1225 ,@(inst:load-address rref:bytes (ea:address bytes-label)) 1226 ,@(inst:load 'WORD rref:vector (ea:address vector-label)) 1227 ,@(inst:object-address rref:vector rref:vector) 1228 ,@(inst:load 'WORD rref:environment (ea:environment)) 1229 ;; Get n-sections for this cc-block. 1230 ,@(inst:load 'BYTE rref:n-sections 1231 (ea:indexed rref:bytes 0 'BYTE rref:index 'BYTE)) 1232 ;; Get cc-block. 1233 ,@(inst:load 'WORD rref:block 1234 (ea:indexed rref:vector 1 'WORD rref:index 'WORD)) 1235 ,@(inst:object-address rref:block rref:block) 1236 ;; Get cc-block length. 1237 ,@(inst:load 'WORD rref:length (ea:indirect rref:block)) 1238 ,@(inst:object-datum rref:length rref:length) 1239 ;; Store environment. 1240 ,@(inst:store 'WORD rref:environment 1241 (ea:indexed rref:block 0 'BYTE rref:length 'WORD)) 1242 ;; Get NMV length. 1243 ,@(inst:load 'WORD rref:length (ea:offset rref:block 1 'WORD)) 1244 ,@(inst:object-datum rref:length rref:length) 1245 ;; Address of first section. 1246 ,@(inst:load-address rref:sections 1247 (ea:indexed rref:block 2 'WORD rref:length 'WORD)) 1248 ;; Push index. 1249 ,@(inst:store 'WORD rref:index (ea:stack-push)) 1250 ;; Invoke linker 1251 ,@(trap:link rref:block rref:sections rref:n-sections) 1252 ,@(make-internal-continuation-label (generate-label)) 1253 ;; Pop index. 1254 ,@(inst:load 'WORD rref:index (ea:stack-pop)) 1255 ;; Increment index and loop. 1256 ,@(inst:increment rref:index rref:index) 1257 ,@(inst:load-immediate rref:length n-blocks) 1258 ,@(inst:conditional-jump 'LT rref:index rref:length 1259 (ea:address loop-label)) 1260 ,@(inst:jump (ea:address end-label)) 1261 1262 ,@(inst:label bytes-label) 1263 ,@(let walk ((bytes (vector->list n-sections))) 1264 (if (null? bytes) 1265 (LAP) 1266 (LAP ,@(inst:datum-u8 (car bytes)) 1267 ,@(walk (cdr bytes))))) 1268 1269 ,@(inst:label end-label))) 1270 (LAP))) 1271 1272(define-integrable linkage-type:operator 0) 1273(define-integrable linkage-type:reference 1) 1274(define-integrable linkage-type:assignment 2) 1275(define-integrable linkage-type:global-operator 3) 1276 1277(define (generate/constants-block constants references assignments 1278 uuo-links global-links static-vars) 1279 (receive (labels code) 1280 (generate/sections 1281 linkage-type:operator (generate/uuos uuo-links) 1282 linkage-type:reference references 1283 linkage-type:assignment assignments 1284 linkage-type:global-operator (generate/uuos global-links)) 1285 (let ((environment-label (allocate-constant-label))) 1286 (values (LAP ,@code 1287 ,@(generate/constants (map (lambda (pair) 1288 (cons #f (cdr pair))) 1289 static-vars)) 1290 ,@(generate/constants constants) 1291 ;; Placeholder for the debugging info filename 1292 (SCHEME-OBJECT ,(allocate-constant-label) DEBUGGING-INFO) 1293 ;; Placeholder for the load time environment if needed 1294 (SCHEME-OBJECT ,environment-label 1295 ,(if (pair? labels) 1296 'ENVIRONMENT 1297 0))) 1298 environment-label 1299 (if (pair? labels) (car labels) #f) 1300 (length labels))))) 1301 1302(define (generate/sections . groups) 1303 (let loop ((groups groups)) 1304 (if (pair? groups) 1305 (let ((linkage-type (car groups)) 1306 (entries (cadr groups))) 1307 (if (pair? entries) 1308 (receive (labels code) (loop (cddr groups)) 1309 (receive (label code*) 1310 (generate/section linkage-type entries) 1311 (values (cons label labels) 1312 (LAP ,@code* ,@code)))) 1313 (loop (cddr groups)))) 1314 (values '() (LAP))))) 1315 1316(define (generate/section linkage-type entries) 1317 (if (pair? entries) 1318 (let ((label (allocate-constant-label))) 1319 (values label 1320 (LAP (SCHEME-OBJECT 1321 ,label 1322 ,(make-linkage-type-marker linkage-type 1323 (length entries))) 1324 ,@(generate/constants entries)))) 1325 (values #f (LAP)))) 1326 1327(define (generate/constants entries) 1328 (let loop ((entries entries)) 1329 (if (pair? entries) 1330 (LAP (SCHEME-OBJECT ,(cdar entries) ,(caar entries)) 1331 ,@(loop (cdr entries))) 1332 (LAP)))) 1333 1334(define (generate/uuos name.caches-list) 1335 (append-map (lambda (name.caches) 1336 (append-map (let ((name (car name.caches))) 1337 (lambda (cache) 1338 (let ((frame-size (car cache)) 1339 (label (cdr cache))) 1340 `((,frame-size . ,label) 1341 (,name . ,(allocate-constant-label)))))) 1342 (cdr name.caches))) 1343 name.caches-list)) 1344 1345(define (make-linkage-type-marker linkage-type n-entries) 1346 (let ((type-offset #x10000)) 1347 (if (not (< n-entries type-offset)) 1348 (error "Linkage section too large:" n-entries)) 1349 (+ (* linkage-type type-offset) n-entries))) 1350 1351;;;; Variable cache trap handling. 1352 1353(define-rule statement 1354 (INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?)) 1355 (QUALIFIER (interpreter-call-argument? extension)) 1356 cont ; ignored 1357 (let ((cache (interpreter-call-temporary extension))) 1358 (LAP ,@(clear-map!) 1359 ,@(if safe? 1360 (trap:safe-lookup cache) 1361 (trap:lookup cache))))) 1362 1363(define-rule statement 1364 (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value)) 1365 (QUALIFIER (and (interpreter-call-argument? extension) 1366 (interpreter-call-argument? value))) 1367 cont ; ignored 1368 (let ((cache (interpreter-call-temporary extension)) 1369 (value (interpreter-call-temporary value))) 1370 (LAP ,@(clear-map!) 1371 ,@(trap:assignment cache value)))) 1372 1373(define-rule statement 1374 (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension)) 1375 (QUALIFIER (interpreter-call-argument? extension)) 1376 cont ; ignored 1377 (let ((cache (interpreter-call-temporary extension))) 1378 (LAP ,@(clear-map!) 1379 ,@(trap:unassigned? cache)))) 1380 1381;;;; Synthesized Data 1382 1383(define-rule rewriting 1384 (CONS-POINTER (REGISTER (? type register-known-value)) (? datum)) 1385 (QUALIFIER (rtl:machine-constant? type)) 1386 (rtl:make-cons-pointer type datum)) 1387 1388(define-rule rewriting 1389 (CONS-POINTER (REGISTER (? type register-known-value)) (? datum)) 1390 (QUALIFIER 1391 (and (rtl:object->type? type) 1392 (rtl:constant? (rtl:object->type-expression type)))) 1393 (rtl:make-cons-pointer 1394 (rtl:make-machine-constant 1395 (object-type (rtl:constant-value (rtl:object->type-expression type)))) 1396 datum)) 1397 1398(define-rule rewriting 1399 (CONS-POINTER (? type) (REGISTER (? datum register-known-value))) 1400 (QUALIFIER 1401 (and (rtl:object->datum? datum) 1402 (rtl:constant-non-pointer? (rtl:object->datum-expression datum)))) 1403 (rtl:make-cons-non-pointer 1404 type 1405 (rtl:make-machine-constant 1406 (object-datum (rtl:constant-value (rtl:object->datum-expression datum)))))) 1407 1408(define-rule rewriting 1409 (OBJECT->TYPE (REGISTER (? source register-known-value))) 1410 (QUALIFIER (rtl:constant? source)) 1411 (rtl:make-machine-constant (object-type (rtl:constant-value source)))) 1412 1413(define-rule rewriting 1414 (OBJECT->DATUM (REGISTER (? source register-known-value))) 1415 (QUALIFIER (rtl:constant-non-pointer? source)) 1416 (rtl:make-machine-constant (object-datum (rtl:constant-value source)))) 1417 1418(define (rtl:constant-non-pointer? expression) 1419 (and (rtl:constant? expression) 1420 (object-non-pointer? (rtl:constant-value expression)))) 1421 1422;;; These rules are losers because there's no abstract way to cons a 1423;;; statement or a predicate without also getting some CFG structure. 1424 1425(define-rule rewriting 1426 (ASSIGN (? target) (REGISTER (? comparand register-known-value))) 1427 (QUALIFIER (rtl:immediate-zero-constant? comparand)) 1428 (list 'ASSIGN target comparand)) 1429 1430(define-rule rewriting 1431 (ASSIGN (OFFSET (REGISTER (? address)) (MACHINE-CONSTANT (? offset))) 1432 (REGISTER (? source register-known-value))) 1433 (QUALIFIER 1434 (and (rtl:byte-offset-address? source) 1435 (rtl:machine-constant? (rtl:byte-offset-address-offset source)) 1436 (let ((base (let ((base (rtl:byte-offset-address-base source))) 1437 (if (rtl:register? base) 1438 (register-known-value (rtl:register-number base)) 1439 base)))) 1440 (and base 1441 (rtl:offset? base) 1442 (let ((base* (rtl:offset-base base)) 1443 (offset* (rtl:offset-offset base))) 1444 (and (rtl:machine-constant? offset*) 1445 (= (rtl:register-number base*) address) 1446 (= (rtl:machine-constant-value offset*) offset))))))) 1447 (let ((target (let ((base (rtl:byte-offset-address-base source))) 1448 (if (rtl:register? base) 1449 (register-known-value (rtl:register-number base)) 1450 base)))) 1451 (list 'ASSIGN 1452 target 1453 (rtl:make-byte-offset-address 1454 target 1455 (rtl:byte-offset-address-offset source))))) 1456 1457(define-rule rewriting 1458 (EQ-TEST (? source) (REGISTER (? comparand register-known-value))) 1459 (QUALIFIER (rtl:immediate-zero-constant? comparand)) 1460 (list 'EQ-TEST source comparand)) 1461 1462(define-rule rewriting 1463 (EQ-TEST (REGISTER (? comparand register-known-value)) (? source)) 1464 (QUALIFIER (rtl:immediate-zero-constant? comparand)) 1465 (list 'EQ-TEST source comparand)) 1466 1467(define (rtl:immediate-zero-constant? expression) 1468 (cond ((rtl:constant? expression) 1469 (let ((value (rtl:constant-value expression))) 1470 (and (object-non-pointer? value) 1471 (zero? (object-type value)) 1472 (zero? (object-datum value))))) 1473 ((rtl:cons-pointer? expression) 1474 (and (let ((expression (rtl:cons-pointer-type expression))) 1475 (and (rtl:machine-constant? expression) 1476 (zero? (rtl:machine-constant-value expression)))) 1477 (let ((expression (rtl:cons-pointer-datum expression))) 1478 (and (rtl:machine-constant? expression) 1479 (zero? (rtl:machine-constant-value expression)))))) 1480 (else #f))) 1481 1482;;;; Fixnum rewriting. 1483 1484(define-rule rewriting 1485 (OBJECT->FIXNUM (REGISTER (? source register-known-value))) 1486 (QUALIFIER (rtl:constant-fixnum? source)) 1487 (rtl:make-object->fixnum source)) 1488 1489(define-rule rewriting 1490 (OBJECT->FIXNUM (CONSTANT (? value))) 1491 (QUALIFIER (fix:fixnum? value)) 1492 (rtl:make-machine-constant value)) 1493 1494(define (rtl:constant-fixnum? expression) 1495 (and (rtl:constant? expression) 1496 (fix:fixnum? (rtl:constant-value expression)) 1497 (rtl:constant-value expression))) 1498 1499;;;; Flonum rewriting. 1500 1501(define-rule rewriting 1502 (OBJECT->FLOAT (REGISTER (? operand register-known-value))) 1503 (QUALIFIER 1504 (rtl:constant-flonum-test operand (lambda (v) v #T))) 1505 (rtl:make-object->float operand)) 1506 1507(define-rule rewriting 1508 (FLONUM-2-ARGS FLONUM-SUBTRACT 1509 (REGISTER (? operand-1 register-known-value)) 1510 (? operand-2) 1511 (? overflow?)) 1512 (QUALIFIER (rtl:constant-flonum-test operand-1 flo:zero?)) 1513 (rtl:make-flonum-2-args 'FLONUM-SUBTRACT operand-1 operand-2 overflow?)) 1514 1515(define-rule rewriting 1516 (FLONUM-2-ARGS (? operation) 1517 (REGISTER (? operand-1 register-known-value)) 1518 (? operand-2) 1519 (? overflow?)) 1520 (QUALIFIER 1521 (and (memq operation 1522 '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE)) 1523 (rtl:constant-flonum-test operand-1 flo:one?))) 1524 (rtl:make-flonum-2-args operation operand-1 operand-2 overflow?)) 1525 1526(define-rule rewriting 1527 (FLONUM-2-ARGS (? operation) 1528 (? operand-1) 1529 (REGISTER (? operand-2 register-known-value)) 1530 (? overflow?)) 1531 (QUALIFIER 1532 (and (memq operation 1533 '(FLONUM-ADD FLONUM-SUBTRACT FLONUM-MULTIPLY FLONUM-DIVIDE)) 1534 (rtl:constant-flonum-test operand-2 flo:one?))) 1535 (rtl:make-flonum-2-args operation operand-1 operand-2 overflow?)) 1536 1537(define-rule rewriting 1538 (FLONUM-PRED-2-ARGS (? predicate) 1539 (? operand-1) 1540 (REGISTER (? operand-2 register-known-value))) 1541 (QUALIFIER (rtl:constant-flonum-test operand-2 flo:zero?)) 1542 (list 'FLONUM-PRED-2-ARGS predicate operand-1 operand-2)) 1543 1544(define-rule rewriting 1545 (FLONUM-PRED-2-ARGS (? predicate) 1546 (REGISTER (? operand-1 register-known-value)) 1547 (? operand-2)) 1548 (QUALIFIER (rtl:constant-flonum-test operand-1 flo:zero?)) 1549 (list 'FLONUM-PRED-2-ARGS predicate operand-1 operand-2)) 1550 1551#| 1552;; These don't work as written. They are not simplified and are 1553;; therefore passed whole to the back end, and there is no way to 1554;; construct the graph at this level. 1555 1556;; acos (x) = atan ((sqrt (1 - x^2)) / x) 1557 1558(define-rule pre-cse-rewriting 1559 (FLONUM-1-ARG FLONUM-ACOS (? operand) #f) 1560 (rtl:make-flonum-2-args 1561 'FLONUM-ATAN2 1562 (rtl:make-flonum-1-arg 1563 'FLONUM-SQRT 1564 (rtl:make-flonum-2-args 1565 'FLONUM-SUBTRACT 1566 (rtl:make-object->float (rtl:make-constant 1.)) 1567 (rtl:make-flonum-2-args 'FLONUM-MULTIPLY operand operand #f) 1568 #f) 1569 #f) 1570 operand 1571 #f)) 1572 1573;; asin (x) = atan (x / (sqrt (1 - x^2))) 1574 1575(define-rule pre-cse-rewriting 1576 (FLONUM-1-ARG FLONUM-ASIN (? operand) #f) 1577 (rtl:make-flonum-2-args 1578 'FLONUM-ATAN2 1579 operand 1580 (rtl:make-flonum-1-arg 1581 'FLONUM-SQRT 1582 (rtl:make-flonum-2-args 1583 'FLONUM-SUBTRACT 1584 (rtl:make-object->float (rtl:make-constant 1.)) 1585 (rtl:make-flonum-2-args 'FLONUM-MULTIPLY operand operand #f) 1586 #f) 1587 #f) 1588 #f)) 1589 1590|# 1591 1592(define (rtl:constant-flonum-test expression predicate) 1593 (and (rtl:object->float? expression) 1594 (let ((expression (rtl:object->float-expression expression))) 1595 (and (rtl:constant? expression) 1596 (let ((n (rtl:constant-value expression))) 1597 (and (flo:flonum? n) 1598 (predicate n))))))) 1599 1600(define (flo:one? value) 1601 (flo:= value 1.)) 1602 1603;;;; Indexed addressing modes 1604 1605(define-rule rewriting 1606 (OFFSET (REGISTER (? base register-known-value)) 1607 (MACHINE-CONSTANT (? value))) 1608 (QUALIFIER (and (rtl:offset-address? base) 1609 (rtl:simple-subexpressions? base))) 1610 (if (= value 0) 1611 (rtl:make-offset (rtl:offset-address-base base) 1612 (rtl:offset-address-offset base)) 1613 (rtl:make-offset base (rtl:make-machine-constant value)))) 1614 1615(define-rule rewriting 1616 (BYTE-OFFSET (REGISTER (? base register-known-value)) 1617 (MACHINE-CONSTANT (? value))) 1618 (QUALIFIER (and (rtl:byte-offset-address? base) 1619 (rtl:simple-subexpressions? base))) 1620 (if (= value 0) 1621 (rtl:make-byte-offset (rtl:byte-offset-address-base base) 1622 (rtl:byte-offset-address-offset base)) 1623 (rtl:make-byte-offset base (rtl:make-machine-constant value)))) 1624 1625(define-rule rewriting 1626 (FLOAT-OFFSET (REGISTER (? base register-known-value)) 1627 (MACHINE-CONSTANT (? value))) 1628 (QUALIFIER (and (rtl:float-offset-address? base) 1629 (rtl:simple-subexpressions? base))) 1630 (if (= value 0) 1631 (rtl:make-float-offset (rtl:float-offset-address-base base) 1632 (rtl:float-offset-address-offset base)) 1633 (rtl:make-float-offset base (rtl:make-machine-constant value)))) 1634 1635;; This is here to avoid generating things like 1636;; 1637;; (offset (offset-address (object->address (constant #(foo bar baz gack))) 1638;; (register 29)) 1639;; (machine-constant 1)) 1640;; 1641;; since the offset-address subexpression is constant, and therefore 1642;; known! 1643 1644(define (rtl:simple-subexpressions? expr) 1645 (for-all? (cdr expr) 1646 (lambda (sub) 1647 (or (rtl:machine-constant? sub) 1648 (rtl:register? sub)))))