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 Allocator 28;;; package: (compiler lap-syntaxer) 29 30(declare (usual-integrations)) 31 32#| 33 34The register allocator provides a mechanism for allocating and 35deallocating machine registers. It manages the available machine 36registers as a cache, by maintaining a "map" that records two kinds of 37information: (1) a list of the machine registers that are not in use; 38and (2) a mapping that is the association between the allocated 39machine registers and the "pseudo registers" that they represent. 40 41An "alias" is a machine register that also holds the contents of a 42pseudo register. Usually an alias is used for a short period of time, 43as a store-in cache, and then eventually the contents of the alias is 44written back out to the home it is associated with. Because of the 45lifetime analysis, it is possible to identify those registers that 46will no longer be referenced; these are deleted from the map when they 47die, and thus do not need to be saved. 48 49A "temporary" is a machine register with no associated home. It is 50used during the code generation of a single RTL instruction to hold 51intermediate results. 52 53Each pseudo register that has at least one alias has an entry in the 54map. While a home is entered in the map, it may have one or more 55aliases added or deleted to its entry, but if the number of aliases 56ever drops to zero, the entry is removed from the map. 57 58Each temporary has an entry in the map, with the difference being that 59the entry has no pseudo register associated with it. Thus it need 60never be written out. 61 62All registers, both machine and pseudo, are represented by 63non-negative integers. Machine registers start at zero (inclusive) 64and stop at `number-of-machine-registers' (exclusive). All others are 65pseudo registers. Because they are integers, we can use `eqv?' to 66compare register numbers. 67 68`available-machine-registers' should be a list of the registers that 69the allocator is allowed to allocate, in the preferred order of 70allocation. 71 72`(sort-machine-registers registers)' should reorder a list of machine 73registers into some interesting sorting order. 74 75|# 76 77(define (register-type? register type) 78 (if type 79 (eq? type (register-type register)) 80 (register-value-class=word? register))) 81 82(define ((register-type-predicate type) register) 83 (register-type? register type)) 84 85;;;; Register Map 86 87(define-integrable make-register-map cons) 88(define-integrable map-entries car) 89(define-integrable map-registers cdr) 90 91(define (empty-register-map) 92 (make-register-map '() available-machine-registers)) 93 94(define (map-entries:search map procedure) 95 ;; This procedure is used only when attempting to free up an 96 ;; existing register. Because of this, it must find an LRU 97 ;; register. Since we order the map entries starting with the MRU 98 ;; registers and working towards the LRU, search the entries 99 ;; starting from the end of the list and working forward. 100 (let loop ((entries (map-entries map))) 101 (and (not (null? entries)) 102 (or (loop (cdr entries)) 103 (procedure (car entries)))))) 104 105(define (map-entries:find-home map pseudo-register) 106 (let loop ((entries (map-entries map))) 107 (and (not (null? entries)) 108 (or (and (map-entry-home (car entries)) 109 (eqv? (map-entry-home (car entries)) pseudo-register) 110 (car entries)) 111 (loop (cdr entries)))))) 112 113(define (map-entries:find-alias map register) 114 (let loop ((entries (map-entries map))) 115 (and (not (null? entries)) 116 ;; **** Kludge -- depends on fact that machine registers are 117 ;; fixnums, and thus EQ? works on them. 118 (or (and (memq register (map-entry-aliases (car entries))) 119 (car entries)) 120 (loop (cdr entries)))))) 121 122(define-integrable (map-entries:add map entry) 123 (cons entry (map-entries map))) 124 125(define-integrable (map-entries:delete map entry) 126 (eq-set-delete (map-entries map) entry)) 127 128(define-integrable (map-entries:delete* map entries) 129 (eq-set-difference (map-entries map) entries)) 130 131(define (map-entries:replace map old new) 132 (let loop ((entries (map-entries map))) 133 (if (null? entries) 134 '() 135 (cons (if (eq? (car entries) old) new (car entries)) 136 (loop (cdr entries)))))) 137 138(define (map-entries:replace&touch map old new) 139 (cons new (map-entries:delete map old))) 140 141(define-integrable (map-registers:add map register) 142 (sort-machine-registers (cons register (map-registers map)))) 143 144(define-integrable (map-registers:add* map registers) 145 (sort-machine-registers (append registers (map-registers map)))) 146 147(define-integrable (map-registers:delete map register) 148 (eqv-set-delete (map-registers map) register)) 149 150(define-integrable (map-registers:replace map old new) 151 (eqv-set-substitute (map-registers map) old new)) 152 153;;;; Map Entry 154 155;; A map entry has four parts: 156;; HOME is either a pseudo-register (which has a physical address in 157;; memory associated with it) or #F indicating that the value 158;; can be flushed when the last alias is reused 159;; SAVED-INTO-HOME? is a boolean that tells whether the value in the 160;; live register can be dropped rather than pushed to the home 161;; if the last live register is needed for other purposes 162;; ALIASES is a list of machine registers that contain the quantity 163;; being mapped (pseudo-register, cached value, etc.) 164;; LABEL is a tag to associate with the computed contents of the live 165;; registers holding this value. This allows individual back 166;; ends to remember labels or other hard-to-generate constant 167;; values and avoid regenerating them. 168 169(define-integrable (make-map-entry home saved-into-home? aliases label) 170 ;; HOME may be false, indicating that this is a temporary register. 171 ;; SAVED-INTO-HOME? must be true when HOME is false. ALIASES must 172 ;; be a non-null list of registers. 173 (vector home saved-into-home? aliases label)) 174 175(define-integrable (map-entry-home entry) 176 (vector-ref entry 0)) 177 178(define-integrable (map-entry-saved-into-home? entry) 179 (vector-ref entry 1)) 180 181(define-integrable (map-entry-aliases entry) 182 (vector-ref entry 2)) 183 184(define-integrable (map-entry-label entry) 185 (vector-ref entry 3)) 186 187(define-integrable (map-entry:any-alias entry) 188 (car (map-entry-aliases entry))) 189 190(define (map-entry:find-alias entry type needed-registers) 191 (list-search-positive (map-entry-aliases entry) 192 (lambda (alias) 193 (and (register-type? alias type) 194 (not (memv alias needed-registers)))))) 195 196(define (map-entry:aliases entry type needed-registers) 197 (list-transform-positive (map-entry-aliases entry) 198 (lambda (alias) 199 (and (register-type? alias type) 200 (not (memv alias needed-registers)))))) 201 202(define (map-entry:add-alias entry alias) 203 (make-map-entry (map-entry-home entry) 204 (map-entry-saved-into-home? entry) 205 (cons alias (map-entry-aliases entry)) 206 (map-entry-label entry))) 207 208(define (map-entry:delete-alias entry alias) 209 (make-map-entry (map-entry-home entry) 210 (map-entry-saved-into-home? entry) 211 (eq-set-delete (map-entry-aliases entry) alias) 212 (map-entry-label entry))) 213 214(define (map-entry:replace-alias entry old new) 215 (make-map-entry (map-entry-home entry) 216 (map-entry-saved-into-home? entry) 217 (eq-set-substitute (map-entry-aliases entry) old new) 218 (map-entry-label entry))) 219 220(define-integrable (map-entry=? entry entry*) 221 (eqv? (map-entry-home entry) (map-entry-home entry*))) 222 223;;;; Map Constructors 224 225;;; These constructors are responsible for maintaining consistency 226;;; between the map entries and available registers. 227 228(define (register-map:add-home map home alias saved-into-home?) 229 (make-register-map (map-entries:add map 230 (make-map-entry home 231 saved-into-home? 232 (list alias) 233 false)) 234 (map-registers:delete map alias))) 235 236(define (register-map:add-alias map entry alias) 237 (make-register-map 238 (map-entries:replace&touch map 239 entry 240 (map-entry:add-alias entry alias)) 241 (map-registers:delete map alias))) 242 243(define (register-map:replace-alias map entry old new) 244 (make-register-map 245 (map-entries:replace&touch map 246 entry 247 (map-entry:replace-alias entry old new)) 248 (map-registers:delete map new))) 249 250(define (register-map:save-entry map entry) 251 (make-register-map 252 (map-entries:replace&touch map 253 entry 254 (make-map-entry (map-entry-home entry) 255 true 256 (map-entry-aliases entry) 257 (map-entry-label entry))) 258 (map-registers map))) 259 260(define-integrable (pseudo-register-entry->temporary-entry entry) 261 (make-map-entry false 262 true 263 (map-entry-aliases entry) 264 (map-entry-label entry))) 265 266(define (register-map:entry->temporary map entry) 267 (make-register-map 268 (map-entries:replace&touch map 269 entry 270 (pseudo-register-entry->temporary-entry entry)) 271 (map-registers map))) 272 273(define (register-map:delete-entry map entry) 274 (make-register-map (map-entries:delete map entry) 275 (map-registers:add* map (map-entry-aliases entry)))) 276 277(define (register-map:delete-entries regmap entries) 278 (if (null? entries) 279 regmap 280 (make-register-map (map-entries:delete* regmap entries) 281 (map-registers:add* regmap 282 (apply append 283 (map map-entry-aliases 284 entries)))))) 285 286(define (register-map:delete-alias map entry alias) 287 (make-register-map (if (null? (cdr (map-entry-aliases entry))) 288 (map-entries:delete map entry) 289 (map-entries:replace map 290 entry 291 (map-entry:delete-alias entry 292 alias))) 293 (map-registers:add map alias))) 294 295(define (register-map:delete-other-aliases map entry alias) 296 (make-register-map 297 (map-entries:replace map 298 entry 299 (let ((home (map-entry-home entry))) 300 (make-map-entry home 301 (not home) 302 (list alias) 303 (map-entry-label entry)))) 304 (map-registers:add* map 305 ;; **** Kludge -- again, EQ? is 306 ;; assumed to work on machine regs. 307 (delq alias 308 (map-entry-aliases entry))))) 309 310(define (register-map:entries->temporaries regmap entries) 311 (if (null? entries) 312 regmap 313 (make-register-map 314 (map* (map-entries:delete* regmap entries) 315 pseudo-register-entry->temporary-entry 316 entries) 317 (map-registers regmap)))) 318 319(define (register-map:keep-live-entries map live-registers) 320 (let loop 321 ((entries (map-entries map)) 322 (registers (map-registers map)) 323 (entries* '())) 324 (cond ((null? entries) 325 (make-register-map (reverse! entries*) 326 (sort-machine-registers registers))) 327 ((let ((home (map-entry-home (car entries)))) 328 (and home 329 (regset-member? live-registers home))) 330 (loop (cdr entries) 331 registers 332 (cons (car entries) entries*))) 333 (else 334 (loop (cdr entries) 335 (append (map-entry-aliases (car entries)) registers) 336 entries*))))) 337 338(define (map-equal? x y) 339 (let loop 340 ((x-entries (map-entries x)) 341 (y-entries (list-transform-positive (map-entries y) map-entry-home))) 342 (cond ((null? x-entries) 343 (null? y-entries)) 344 ((not (map-entry-home (car x-entries))) 345 (loop (cdr x-entries) y-entries)) 346 (else 347 (and (not (null? y-entries)) 348 (let ((y-entry 349 (list-search-positive y-entries 350 (let ((home (map-entry-home (car x-entries)))) 351 (lambda (entry) 352 (eqv? (map-entry-home entry) home)))))) 353 (and y-entry 354 (boolean=? (map-entry-saved-into-home? (car x-entries)) 355 (map-entry-saved-into-home? y-entry)) 356 (eqv-set-same-set? (map-entry-aliases (car x-entries)) 357 (map-entry-aliases y-entry)) 358 (loop (cdr x-entries) (delq! y-entry y-entries))))))))) 359 360;;;; Register Allocator 361 362(define (make-free-register map type needed-registers) 363 (or 364 ;; First attempt to find a register that can be used without saving 365 ;; its value. 366 (find-free-register map type needed-registers) 367 ;; Then try to recycle a register by saving its value elsewhere. 368 (map-entries:search map 369 (lambda (entry) 370 (and 371 (map-entry-home entry) 372 (not (map-entry-saved-into-home? entry)) 373 (let ((alias (map-entry:find-alias entry type needed-registers))) 374 (and alias 375 (or 376 ;; If we are reallocating a register of a specific type, first 377 ;; see if there is an available register of some other 378 ;; assignment-compatible type that we can stash the value in. 379 (and type 380 (let ((values 381 (find-free-register 382 map 383 (if (register-types-compatible? type false) 384 false 385 type) 386 (cons alias needed-registers)))) 387 (and 388 values 389 (bind-allocator-values values 390 (lambda (alias* map instructions) 391 (allocator-values 392 alias 393 (register-map:replace-alias map 394 entry 395 alias 396 alias*) 397 (LAP ,@instructions 398 ,@(register->register-transfer alias 399 alias*)))))))) 400 ;; There is no other register that we can use, so we 401 ;; must save the value out into the home. 402 (allocator-values alias 403 (register-map:delete-alias map entry alias) 404 (save-into-home-instruction entry)))))))) 405 ;; Finally, see if there is a temporary label register that can be 406 ;; recycled. Label registers are considered after ordinary 407 ;; registers, because on the RISC machines that use them, it is 408 ;; more expensive to generate a new label register than it is to 409 ;; save an ordinary register. 410 (map-entries:search map 411 (lambda (entry) 412 (and (map-entry-label entry) 413 (not (map-entry-home entry)) 414 (let ((alias (map-entry:find-alias entry type needed-registers))) 415 (and alias 416 (allocator-values 417 alias 418 (register-map:delete-alias map entry alias) 419 (LAP))))))) 420 (error "MAKE-FREE-REGISTER: Unable to allocate register"))) 421 422(define (find-free-register map type needed-registers) 423 (define (reallocate-alias entry) 424 (let ((alias (map-entry:find-alias entry type needed-registers))) 425 (and alias 426 (allocator-values alias 427 (register-map:delete-alias map entry alias) 428 (LAP))))) 429 ;; First see if there is an unused register of the given type. 430 (or (let ((register 431 (list-search-positive (map-registers map) 432 (lambda (alias) 433 (and (register-type? alias type) 434 (not (memv alias needed-registers))))))) 435 (and register (allocator-values register map (LAP)))) 436 ;; There are no free registers available, so must reallocate 437 ;; one. First look for a temporary register that is no longer 438 ;; needed. 439 (map-entries:search map 440 (lambda (entry) 441 (and (not (map-entry-home entry)) 442 (not (map-entry-label entry)) 443 (reallocate-alias entry)))) 444 ;; Then look for a register that contains the same thing as 445 ;; another register. 446 (map-entries:search map 447 (lambda (entry) 448 (and (not (null? (cdr (map-entry-aliases entry)))) 449 (reallocate-alias entry)))) 450 ;; Look for a non-temporary that has been saved into its home. 451 (map-entries:search map 452 (lambda (entry) 453 (and (map-entry-home entry) 454 (map-entry-saved-into-home? entry) 455 (reallocate-alias entry)))))) 456 457(define (allocate-register-without-spill? map type needed-registers) 458 ;; True iff a register of `type' can be allocated without saving any 459 ;; registers into their homes. 460 (or (free-register-exists? map type needed-registers) 461 (map-entries:search map 462 (lambda (entry) 463 (let ((alias (map-entry:find-alias entry type needed-registers))) 464 (and alias 465 (free-register-exists? 466 map 467 (if (register-types-compatible? type false) false type) 468 (cons alias needed-registers)))))))) 469 470(define (free-register-exists? map type needed-registers) 471 ;; True iff a register of `type' can be allocated without first 472 ;; saving its contents. 473 (or (allocate-register-without-unload? map type needed-registers) 474 (map-entries:search map 475 (lambda (entry) 476 (and (map-entry-home entry) 477 (map-entry-saved-into-home? entry) 478 (map-entry:find-alias entry type needed-registers)))))) 479 480(define (allocate-register-without-unload? map type needed-registers) 481 ;; True iff a register of `type' can be allocated without displacing 482 ;; any pseudo-registers from the register map. 483 (or (list-search-positive (map-registers map) 484 (lambda (alias) 485 (and (register-type? alias type) 486 (not (memv alias needed-registers))))) 487 (map-entries:search map 488 (lambda (entry) 489 (and (map-entry:find-alias entry type needed-registers) 490 (or (not (map-entry-home entry)) 491 (not (null? (cdr (map-entry-aliases entry)))))))))) 492 493;;;; Allocator Operations 494 495(define (load-alias-register map type needed-registers home) 496 ;; Finds or makes an alias register for HOME, and loads HOME's 497 ;; contents into that register. 498 (or (let ((entry (map-entries:find-home map home))) 499 (and entry 500 (let ((alias (list-search-positive (map-entry-aliases entry) 501 (register-type-predicate type)))) 502 (and alias 503 (allocator-values alias map (LAP)))))) 504 (bind-allocator-values (make-free-register map type needed-registers) 505 (lambda (alias map instructions) 506 (let ((entry (map-entries:find-home map home))) 507 (if entry 508 (allocator-values 509 alias 510 (register-map:add-alias map entry alias) 511 (LAP ,@instructions 512 ,@(register->register-transfer 513 (map-entry:any-alias entry) 514 alias))) 515 (allocator-values 516 alias 517 (register-map:add-home map home alias true) 518 (LAP ,@instructions 519 ,@(home->register-transfer home alias))))))))) 520 521(define (allocate-alias-register map type needed-registers home) 522 ;; Makes an alias register for `home'. Used when about to modify 523 ;; `home's contents. It is assumed that no entry exists for `home'. 524 (bind-allocator-values (make-free-register map type needed-registers) 525 (lambda (alias map instructions) 526 (allocator-values alias 527 (register-map:add-home map home alias false) 528 instructions)))) 529 530(define (allocate-temporary-register map type needed-registers) 531 (bind-allocator-values (make-free-register map type needed-registers) 532 (lambda (alias map instructions) 533 (allocator-values alias 534 (register-map:add-home map false alias true) 535 instructions)))) 536 537(define (add-pseudo-register-alias map register alias saved-into-home?) 538 (let ((map (delete-machine-register map alias))) 539 (let ((entry (map-entries:find-home map register))) 540 (if entry 541 (register-map:add-alias map entry alias) 542 (register-map:add-home map register alias saved-into-home?))))) 543 544(define (machine-register-contents map register) 545 (let ((entry (map-entries:find-alias map register))) 546 (and entry 547 (map-entry-home entry)))) 548 549(define (pseudo-register-aliases map register) 550 (let ((entry (map-entries:find-home map register))) 551 (and entry 552 (map-entry-aliases entry)))) 553 554(define (machine-register-alias map type register) 555 "Returns another machine register, of the given TYPE, which holds 556the same value as REGISTER. If no such register exists, returns #F." 557 (let ((entry (map-entries:find-alias map register))) 558 (and entry 559 (list-search-positive (map-entry-aliases entry) 560 (lambda (register*) 561 (and (not (eq? register register*)) 562 (register-type? type register*))))))) 563 564(define (pseudo-register-alias map type register) 565 "Returns a machine register, of the given TYPE, which is an alias 566for REGISTER. If no such register exists, returns #F." 567 (let ((entry (map-entries:find-home map register))) 568 (and entry 569 (list-search-positive (map-entry-aliases entry) 570 (register-type-predicate type))))) 571 572(define (machine-register-is-unique? map register) 573 "True if REGISTER has no other aliases." 574 (let ((entry (map-entries:find-alias map register))) 575 (or (not entry) 576 (null? (cdr (map-entry-aliases entry)))))) 577 578(define (machine-register-holds-unique-value? map register) 579 "True if the contents of REGISTER is not saved anywhere else." 580 (let ((entry (map-entries:find-alias map register))) 581 (or (not entry) 582 (and (null? (cdr (map-entry-aliases entry))) 583 (not (map-entry-saved-into-home? entry)))))) 584 585(define (is-pseudo-register-alias? map maybe-alias register) 586 (let ((entry (map-entries:find-home map register))) 587 (and entry 588 (list-search-positive (map-entry-aliases entry) 589 (lambda (alias) 590 (eqv? maybe-alias alias)))))) 591 592(define (save-machine-register map register receiver) 593 (let ((entry (map-entries:find-alias map register))) 594 (if (and entry 595 (not (map-entry-saved-into-home? entry)) 596 (null? (cdr (map-entry-aliases entry)))) 597 (receiver (register-map:save-entry map entry) 598 (save-into-home-instruction entry)) 599 (receiver map (LAP))))) 600 601(define (save-pseudo-register map register receiver) 602 (let ((entry (map-entries:find-home map register))) 603 (if (and entry 604 (not (map-entry-saved-into-home? entry))) 605 (receiver (register-map:save-entry map entry) 606 (save-into-home-instruction entry)) 607 (receiver map (LAP))))) 608 609(define (register-map-label map type) 610 (let loop ((entries (map-entries map))) 611 (if (null? entries) 612 (values false false) 613 (let ((alias 614 (and (map-entry-label (car entries)) 615 (map-entry:find-alias (car entries) type '())))) 616 (if alias 617 (values (map-entry-label (car entries)) alias) 618 (loop (cdr entries))))))) 619 620(define (register-map-labels map type) 621 (let loop ((entries (map-entries map))) 622 (if (null? entries) 623 '() 624 (let ((label (map-entry-label (car entries)))) 625 (if label 626 (let ((aliases (map-entry:aliases (car entries) type '()))) 627 (if (not (null? aliases)) 628 (cons (cons label aliases) 629 (loop (cdr entries))) 630 (loop (cdr entries)))) 631 (loop (cdr entries))))))) 632 633(define (set-machine-register-label map register label) 634 (let ((entry (map-entries:find-alias map register))) 635 (if entry 636 (make-register-map (map-entries:replace 637 map 638 entry 639 (make-map-entry (map-entry-home entry) 640 (map-entry-saved-into-home? entry) 641 (map-entry-aliases entry) 642 label)) 643 (map-registers map)) 644 (make-register-map (map-entries:add map 645 (make-map-entry false 646 true 647 (list register) 648 label)) 649 (map-registers:delete map register))))) 650 651(define (pseudo-register-saved-into-home? map register) 652 (let ((entry (map-entries:find-home map register))) 653 (or (not entry) 654 (map-entry-saved-into-home? entry)))) 655 656(define (delete-machine-register map register) 657 (let ((entry (map-entries:find-alias map register))) 658 (if entry 659 (register-map:delete-alias map entry register) 660 map))) 661 662(define (delete-pseudo-register map register receiver) 663 ;; If the pseudo-register has any alias with a cached value -- 664 ;; indicated by a labelled entry -- then we convert the map entry to 665 ;; represent a temporary register rather than a pseudo register. 666 ;; 667 ;; receiver gets the new map and the aliases that are no longer 668 ;; needed (even if it is convenient to keep them around) 669 (let ((entry (map-entries:find-home map register))) 670 (cond ((not entry) (receiver map '())) 671 ((not (map-entry-label entry)) 672 (receiver (register-map:delete-entry map entry) 673 (map-entry-aliases entry))) 674 (else ; Pseudo -> temporary 675 (receiver (register-map:entry->temporary map entry) 676 (map-entry-aliases entry)))))) 677 678(define (delete-pseudo-registers map registers) 679 ;; Used to remove dead registers from the map. 680 ;; See comments to delete-pseudo-register, above. 681 682 (define (create-new-map delete transform) 683 (register-map:entries->temporaries (register-map:delete-entries map delete) 684 transform)) 685 686 687 (let loop ((registers registers) 688 (entries-to-delete '()) 689 (entries-to-transform '())) 690 (if (null? registers) 691 (create-new-map entries-to-delete entries-to-transform) 692 (let ((entry (map-entries:find-home map (car registers)))) 693 (loop (cdr registers) 694 (if (and entry (not (map-entry-label entry))) 695 (cons entry entries-to-delete) 696 entries-to-delete) 697 (if (and entry (map-entry-label entry)) 698 (cons entry entries-to-transform) 699 entries-to-transform)))))) 700 701(define (delete-other-locations map register) 702 ;; Used in assignments to indicate that other locations containing 703 ;; the same value no longer contain the value for a given home. 704 (register-map:delete-other-aliases 705 map 706 (or (map-entries:find-alias map register) 707 (error "DELETE-OTHER-LOCATIONS: Missing entry" register)) 708 register)) 709 710(define-integrable (allocator-values alias map instructions) 711 (vector alias map instructions)) 712 713(define (bind-allocator-values values receiver) 714 (receiver (vector-ref values 0) 715 (vector-ref values 1) 716 (vector-ref values 2))) 717 718(define (save-into-home-instruction entry) 719 (register->home-transfer (map-entry:any-alias entry) 720 (map-entry-home entry))) 721 722(define (register-map-live-homes map) 723 (let loop ((entries (map-entries map))) 724 (if (null? entries) 725 '() 726 (let ((home (map-entry-home (car entries)))) 727 (if home 728 (cons home (loop (cdr entries))) 729 (loop (cdr entries))))))) 730 731(define (register-map-clear? map) 732 (for-all? (map-entries map) map-entry-saved-into-home?)) 733 734;;;; Map Coercion 735 736;;; These operations generate the instructions to coerce one map into 737;;; another. They are used when joining two branches of a control 738;;; flow graph that have different maps (e.g. in a loop.) 739 740(package (coerce-map-instructions clear-map-instructions) 741 742(define-export (coerce-map-instructions input-map output-map) 743 (three-way-sort map-entry=? 744 (map-entries input-map) 745 (map-entries output-map) 746 (lambda (input-entries shared-entries output-entries) 747 (input-loop input-entries 748 (shared-loop shared-entries 749 (output-loop output-entries)))))) 750 751(define-export (clear-map-instructions input-map) 752 (input-loop (map-entries input-map) (LAP))) 753 754(define (input-loop entries tail) 755 (let loop ((entries entries)) 756 (cond ((null? entries) 757 tail) 758 ((map-entry-saved-into-home? (car entries)) 759 (loop (cdr entries))) 760 (else 761 (LAP ,@(save-into-home-instruction (car entries)) 762 ,@(loop (cdr entries))))))) 763 764(define (shared-loop entries tail) 765 (let entries-loop ((entries entries)) 766 (if (null? entries) 767 tail 768 (let ((input-aliases (map-entry-aliases (caar entries)))) 769 (let aliases-loop 770 ((output-aliases 771 (eqv-set-difference (map-entry-aliases (cdar entries)) 772 input-aliases))) 773 (if (null? output-aliases) 774 (entries-loop (cdr entries)) 775 (LAP ,@(register->register-transfer (car input-aliases) 776 (car output-aliases)) 777 ,@(aliases-loop (cdr output-aliases))))))))) 778 779(define (output-loop entries) 780 (if (null? entries) 781 (LAP) 782 (let ((home (map-entry-home (car entries)))) 783 (if home 784 (let ((aliases (map-entry-aliases (car entries)))) 785 (LAP ,@(home->register-transfer home (car aliases)) 786 ,@(let registers-loop ((registers (cdr aliases))) 787 (if (null? registers) 788 (output-loop (cdr entries)) 789 (LAP ,@(register->register-transfer 790 (car aliases) 791 (car registers)) 792 ,@(registers-loop (cdr registers))))))) 793 (output-loop (cdr entries)))))) 794 795)