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)