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