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 / mermap.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  5.8 KB  |  165 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: mermap.scm,v 1.5 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. ;;;; LAP Generator: Merge Register Maps
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (merge-register-maps maps weights)
  27.   ;; This plays merry hell with the map entry order.  An attempt has
  28.   ;; been made to preserve the order in simple cases, but in general
  29.   ;; there isn't enough information to do a really good job.
  30.   (let ((entries
  31.      (reduce add-weighted-entries
  32.          '()
  33.          (if (not weights)
  34.              (map (lambda (map) (map->weighted-entries map 1)) maps)
  35.              (map map->weighted-entries maps weights)))))
  36.     (for-each eliminate-unlikely-aliases! entries)
  37.     (eliminate-conflicting-aliases! entries)
  38.     (weighted-entries->map entries)))
  39.  
  40. (define (eliminate-unlikely-aliases! entry)
  41.   (let ((home-weight (vector-ref entry 1))
  42.     (alias-weights (vector-ref entry 2)))
  43.     (let ((maximum (max home-weight (apply max (map cdr alias-weights)))))
  44.       (if (not (= home-weight maximum))
  45.       (vector-set! entry 1 0))
  46.       ;; Keep only the aliases with the maximum weights.  Furthermore,
  47.       ;; keep only one alias of a given type.
  48.       (vector-set! entry 2
  49.            (list-transform-positive alias-weights
  50.              (let ((types '()))
  51.                (lambda (alias-weight)
  52.              (and (= (cdr alias-weight) maximum)
  53.                   (let ((type (register-type (car alias-weight))))
  54.                 (and (not (memq type types))
  55.                      (begin (set! types (cons type types))
  56.                         true)))))))))))
  57.  
  58. (define (eliminate-conflicting-aliases! entries)
  59.   (for-each (lambda (conflicting-alias)
  60.           (let ((homes (cdr conflicting-alias)))
  61.         (let ((maximum (apply max (map cdr homes))))
  62.           (let ((winner
  63.              (list-search-positive homes
  64.                (lambda (home)
  65.                  (= (cdr home) maximum)))))
  66.             (for-each
  67.              (lambda (home)
  68.                (if (not (eq? home winner))
  69.                (let ((entry
  70.                   (find-weighted-entry (car home) entries)))
  71.                  (vector-set! entry 2
  72.                       (del-assv! (car conflicting-alias)
  73.                              (vector-ref entry 2))))))
  74.              homes)))))
  75.         (conflicting-aliases entries)))
  76.  
  77. (define (conflicting-aliases entries)
  78.   (let ((alist '()))
  79.     (for-each
  80.      (lambda (entry)
  81.        (let ((home (vector-ref entry 0)))
  82.      (for-each
  83.       (lambda (alias-weight)
  84.         (let ((alist-entry (assv (car alias-weight) alist))
  85.           (element (cons home (cdr alias-weight))))
  86.           (if alist-entry
  87.           (set-cdr! alist-entry (cons element (cdr alist-entry)))
  88.           (set! alist
  89.             (cons (list (car alias-weight) element) alist)))))
  90.       (vector-ref entry 2))))
  91.      entries)
  92.     (list-transform-negative alist
  93.       (lambda (alist-entry)
  94.     (null? (cddr alist-entry))))))
  95.  
  96. (define (map->weighted-entries register-map weight)
  97.   (map (lambda (entry)
  98.      (vector (map-entry-home entry)
  99.          (if (map-entry-saved-into-home? entry) weight 0)
  100.          (map (lambda (alias) (cons alias weight))
  101.               (map-entry-aliases entry))
  102.          (map-entry-label entry)))
  103.        (map-entries register-map)))
  104.  
  105. (define (add-weighted-entries x-entries y-entries)
  106.   (merge-entries x-entries y-entries
  107.     (lambda (entry entries)
  108.       (list-search-positive entries
  109.     (let ((home (vector-ref entry 0)))
  110.       (lambda (entry)
  111.         (eqv? home (vector-ref entry 0))))))
  112.     (lambda (x-entry y-entry)
  113.       (vector (vector-ref x-entry 0)
  114.           (+ (vector-ref x-entry 1) (vector-ref y-entry 1))
  115.           (merge-entries (vector-ref x-entry 2) (vector-ref y-entry 2)
  116.         (lambda (entry entries)
  117.           (assq (car entry) entries))
  118.         (lambda (x-entry y-entry)
  119.           (cons (car x-entry) (+ (cdr x-entry) (cdr y-entry)))))
  120.           ;; If the labels don't match, or only one entry has a
  121.           ;; label, then the result shouldn't have a label.
  122.           (and (eqv? (vector-ref x-entry 3) (vector-ref y-entry 3))
  123.            (vector-ref x-entry 3))))))
  124.  
  125. (define (merge-entries x-entries y-entries find-entry merge-entry)
  126.   (let loop
  127.       ((x-entries x-entries)
  128.        (y-entries (list-copy y-entries))
  129.        (result '()))
  130.     (if (null? x-entries)
  131.     ;; This (feebly) attempts to preserve the entry order.
  132.     (append! (reverse! result) y-entries)
  133.     (let ((x-entry (car x-entries))
  134.           (x-entries (cdr x-entries)))
  135.       (let ((y-entry (find-entry x-entry y-entries)))
  136.         (if y-entry
  137.         (loop x-entries
  138.               (delq! y-entry y-entries)
  139.               (cons (merge-entry x-entry y-entry) result))
  140.         (loop x-entries
  141.               y-entries
  142.               (cons x-entry result))))))))
  143.  
  144. (define find-weighted-entry
  145.   (association-procedure eqv? (lambda (entry) (vector-ref entry 0))))
  146.  
  147. (define (weighted-entries->map entries)
  148.   (let loop
  149.       ((entries entries)
  150.        (map-entries '())
  151.        (map-registers available-machine-registers))
  152.     (if (null? entries)
  153.     (make-register-map (reverse! map-entries)
  154.                (sort-machine-registers map-registers))
  155.     (let ((aliases (map car (vector-ref (car entries) 2))))
  156.       (if (null? aliases)
  157.           (loop (cdr entries) map-entries map-registers)
  158.           (loop (cdr entries)
  159.             (cons (make-map-entry
  160.                (vector-ref (car entries) 0)
  161.                (positive? (vector-ref (car entries) 1))
  162.                aliases
  163.                (vector-ref (car entries) 3))
  164.               map-entries)
  165.             (eqv-set-difference map-registers aliases)))))))