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 / rtlopt / rtlcsm.scm < prev   
Encoding:
Text File  |  1999-01-02  |  10.2 KB  |  306 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rtlcsm.scm,v 1.2 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1989, 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. ;;;; RTL Common Suffix Merging
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (merge-common-suffixes! rgraphs)
  27.   (for-each merge-suffixes-of-rgraph! rgraphs))
  28.  
  29. (define (merge-suffixes-of-rgraph! rgraph)
  30.   (let loop ()
  31.     (let ((suffix-classes (rgraph-matching-suffixes rgraph)))
  32.       (if (not (null? suffix-classes))
  33.       (begin
  34.         ;; Because many of the original bblocks can be discarded
  35.         ;; by the merging process, processing of one suffix class
  36.         ;; can make the information in the subsequent suffix
  37.         ;; classes incorrect.  However, reanalysis will still
  38.         ;; reproduce the remaining suffix classes.  So, process
  39.         ;; one class and reanalyze before continuing.
  40.         (merge-suffixes! rgraph (car suffix-classes))
  41.         (loop))))))
  42.  
  43. (define (merge-suffixes! rgraph suffixes)
  44.   (with-values
  45.       (lambda ()
  46.     (discriminate-items suffixes
  47.       (lambda (suffix)
  48.         (eq? (cdr suffix) (bblock-instructions (car suffix))))))
  49.     (lambda (total-suffixes partial-suffixes)
  50.       (if (not (null? total-suffixes))
  51.       (let ((new-bblock (caar total-suffixes)))
  52.         (for-each (lambda (suffix)
  53.             (replace-suffix-block! rgraph suffix new-bblock))
  54.               (cdr total-suffixes))
  55.         (replace-suffixes! rgraph new-bblock partial-suffixes))
  56.       (let ((suffix (car partial-suffixes)))
  57.         (split-suffix-block! rgraph suffix)
  58.         (replace-suffixes! rgraph (car suffix) (cdr partial-suffixes)))))))
  59.  
  60. (define (replace-suffixes! rgraph new-bblock partial-suffixes)
  61.   (for-each (lambda (suffix)
  62.           (split-suffix-block! rgraph suffix)
  63.           (replace-suffix-block! rgraph suffix new-bblock))
  64.         partial-suffixes))
  65.  
  66. (define (split-suffix-block! rgraph suffix)
  67.   (let ((old-bblock (car suffix))
  68.     (instructions (cdr suffix)))
  69.     (rinst-disconnect-previous! old-bblock instructions)
  70.     (let ((sblock (make-sblock (bblock-instructions old-bblock))))
  71.       (node-insert-snode! old-bblock sblock)
  72.       (add-rgraph-bblock! rgraph sblock))
  73.     (set-bblock-instructions! old-bblock instructions)))
  74.  
  75. (define (replace-suffix-block! rgraph suffix new-bblock)
  76.   (let ((old-bblock (car suffix)))
  77.     (node-replace-on-right! old-bblock new-bblock)
  78.     (node-disconnect-on-left! old-bblock)
  79.     (delete-rgraph-bblock! rgraph old-bblock)))
  80.  
  81. (define (rgraph-matching-suffixes rgraph)
  82.   (append-map (lambda (bblock-class)
  83.         (suffix-classes (initial-bblock-matches bblock-class)))
  84.           (rgraph/bblock-classes rgraph)))
  85.  
  86. (define (rgraph/bblock-classes rgraph)
  87.   (let ((sblock-classes (list false))
  88.     (pblock-classes (list false)))
  89.     (for-each (lambda (bblock)
  90.         (if (sblock? bblock)
  91.             (add-sblock-to-classes! sblock-classes bblock)
  92.             (add-pblock-to-classes! pblock-classes bblock)))
  93.           (rgraph-bblocks rgraph))
  94.     (let ((singleton? (lambda (x) (null? (cdr x)))))
  95.       (append! (list-transform-negative (cdr sblock-classes) singleton?)
  96.            (list-transform-negative (cdr pblock-classes) singleton?)))))
  97.  
  98. (define (add-sblock-to-classes! classes sblock)
  99.   (let ((next (snode-next sblock)))
  100.     (let loop ((previous classes) (classes (cdr classes)))
  101.       (if (null? classes)
  102.       (set-cdr! previous (list (list sblock)))
  103.       (if (eq? next (snode-next (caar classes)))
  104.           (set-car! classes (cons sblock (car classes)))
  105.           (loop classes (cdr classes)))))))
  106.  
  107. (define (add-pblock-to-classes! classes pblock)
  108.   (let ((consequent (pnode-consequent pblock))
  109.     (alternative (pnode-alternative pblock)))
  110.     (let loop ((previous classes) (classes (cdr classes)))
  111.       (if (null? classes)
  112.       (set-cdr! previous (list (list pblock)))
  113.       (if (let ((pblock* (caar classes)))
  114.         (and (eq? consequent (pnode-consequent pblock*))
  115.              (eq? alternative (pnode-alternative pblock*))))
  116.           (set-car! classes (cons pblock (car classes)))
  117.           (loop classes (cdr classes)))))))
  118.  
  119. (define (initial-bblock-matches bblocks)
  120.   (let loop ((bblocks bblocks))
  121.     (if (null? bblocks)
  122.     '()
  123.     (let ((entries (find-matching-bblocks (car bblocks) (cdr bblocks))))
  124.       (if (null? entries)
  125.           (loop (cdr bblocks))
  126.           (append! entries (loop (cdr bblocks))))))))
  127.  
  128. (define (suffix-classes entries)
  129.   (let ((classes '())
  130.     (class-member?
  131.      (lambda (class suffix)
  132.        (list-search-positive class
  133.          (lambda (suffix*)
  134.            (and (eq? (car suffix) (car suffix*))
  135.             (eq? (cdr suffix) (cdr suffix*))))))))
  136.     (for-each (lambda (entry)
  137.         (let ((class
  138.                (list-search-positive classes
  139.              (lambda (class)
  140.                (class-member? class (car entry))))))
  141.           (if class
  142.               (if (not (class-member? class (cdr entry)))
  143.               (set-cdr! class (cons (cdr entry) (cdr class))))
  144.               (let ((class
  145.                  (list-search-positive classes
  146.                    (lambda (class)
  147.                  (class-member? class (cdr entry))))))
  148.             (if class
  149.                 (set-cdr! class (cons (car entry) (cdr class)))
  150.                 (set! classes
  151.                   (cons (list (car entry) (cdr entry))
  152.                     classes))))))
  153.         unspecific)
  154.           entries)
  155.     (map cdr
  156.      (sort (map (lambda (class) (cons (rinst-length (cdar class)) class))
  157.             classes)
  158.            (lambda (x y)
  159.          (< (car x) (car y)))))))
  160.  
  161. ;;;; Basic Block Matching
  162.  
  163. (define (find-matching-bblocks bblock bblocks)
  164.   (let loop ((bblocks bblocks))
  165.     (if (null? bblocks)
  166.     '()
  167.     (with-values (lambda () (matching-suffixes bblock (car bblocks)))
  168.       (lambda (sx sy adjustments)
  169.         (if (or (interesting-suffix? bblock sx)
  170.             (interesting-suffix? (car bblocks) sy))
  171.         (begin
  172.           (for-each (lambda (adjustment) (adjustment)) adjustments)
  173.           (cons (cons (cons bblock sx) (cons (car bblocks) sy))
  174.             (loop (cdr bblocks))))
  175.         (loop (cdr bblocks))))))))
  176.  
  177. (define (interesting-suffix? bblock rinst)
  178.   (and rinst
  179.        (or (rinst-next rinst)
  180.        (eq? rinst (bblock-instructions bblock))
  181.        (and (sblock? bblock)
  182.         (snode-next bblock))
  183.        (let ((rtl (rinst-rtl rinst)))
  184.          (let ((type (rtl:expression-type rtl)))
  185.            (if (eq? type 'INVOCATION:PRIMITIVE)
  186.            (let ((procedure (rtl:invocation:primitive-procedure rtl)))
  187.              (and (not (eq? compiled-error-procedure procedure))
  188.               (negative? (primitive-procedure-arity procedure))))
  189.            (memq type
  190.              '(INTERPRETER-CALL:ACCESS
  191.                INTERPRETER-CALL:DEFINE
  192.                INTERPRETER-CALL:LOOKUP
  193.                INTERPRETER-CALL:SET!
  194.                INTERPRETER-CALL:UNASSIGNED?
  195.                INTERPRETER-CALL:UNBOUND
  196.                INTERPRETER-CALL:CACHE-ASSIGNMENT
  197.                INTERPRETER-CALL:CACHE-REFERENCE
  198.                INTERPRETER-CALL:CACHE-UNASSIGNED?
  199.                INVOCATION:COMPUTED-LEXPR
  200.                INVOCATION:CACHE-REFERENCE
  201.                INVOCATION:LOOKUP))))))))
  202.  
  203. (define (matching-suffixes x y)
  204.   (let loop
  205.       ((rx (bblock-reversed-instructions x))
  206.        (ry (bblock-reversed-instructions y))
  207.        (wx false)
  208.        (wy false)
  209.        (e '())
  210.        (adjustments '()))
  211.     (if (or (null? rx) (null? ry))
  212.     (values wx wy adjustments)
  213.     (with-values
  214.         (lambda ()
  215.           (match-rtl (rinst-rtl (car rx)) (rinst-rtl (car ry)) e))
  216.       (lambda (e adjustment)
  217.         (if (eq? e 'FAILURE)
  218.         (values wx wy adjustments)
  219.         (let ((adjustments
  220.                (if adjustment
  221.                (cons adjustment adjustments)
  222.                adjustments)))
  223.           (if (for-all? e (lambda (b) (eqv? (car b) (cdr b))))
  224.               (loop (cdr rx) (cdr ry)
  225.                 (car rx) (car ry)
  226.                 e adjustments)
  227.               (loop (cdr rx) (cdr ry)
  228.                 wx wy
  229.                 e adjustments)))))))))
  230.  
  231. ;;;; RTL Instruction Matching
  232.  
  233. (define (match-rtl x y e)
  234.   (cond ((not (eq? (rtl:expression-type x) (rtl:expression-type y)))
  235.      (values 'FAILURE false))
  236.     ((rtl:assign? x)
  237.      (values
  238.       (let ((ax (rtl:assign-address x)))
  239.         (let ((e (match ax (rtl:assign-address y) e)))
  240.           (if (eq? e 'FAILURE)
  241.           'FAILURE
  242.           (match (rtl:assign-expression x)
  243.              (rtl:assign-expression y)
  244.              (remove-from-environment!
  245.               e
  246.               (if (rtl:pseudo-register-expression? ax)
  247.                   (list (rtl:register-number ax))
  248.                   '()))))))
  249.       false))
  250.     ((and (rtl:invocation? x)
  251.           (not (eqv? (rtl:invocation-continuation x)
  252.              (rtl:invocation-continuation y))))
  253.      (let ((x* (rtl:map-subexpressions x identity-procedure))
  254.            (y* (rtl:map-subexpressions y identity-procedure)))
  255.        (rtl:set-invocation-continuation! x* false)
  256.        (rtl:set-invocation-continuation! y* false)
  257.        (values (match x* y* e)
  258.            (lambda ()
  259.              (rtl:set-invocation-continuation! x false)
  260.              (rtl:set-invocation-continuation! y false)))))
  261.     (else
  262.      (values (match x y e) false))))
  263.  
  264. (define (remove-from-environment! e keys)
  265.   (if (null? keys)
  266.       e
  267.       (remove-from-environment! (del-assv! (car keys) e) (cdr keys))))
  268.  
  269. (define (match x y e)
  270.   (cond ((pair? x)
  271.      (let ((type (car x)))
  272.        (if (and (pair? y) (eq? type (car y)))
  273.            (case type
  274.          ((CONSTANT)
  275.           (if (eqv? (cadr x) (cadr y))
  276.               e
  277.               'FAILURE))
  278.          ((REGISTER)
  279.           (let ((rx (cadr x))
  280.             (ry (cadr y)))
  281.             (if (pseudo-register? rx)
  282.             (if (pseudo-register? ry)
  283.                 (let ((entry (assv rx e)))
  284.                   (cond ((not entry) (cons (cons rx ry) e))
  285.                     ((eqv? (cdr entry) ry) e)
  286.                     (else 'FAILURE)))
  287.                 'FAILURE)
  288.             (if (pseudo-register? ry)
  289.                 'FAILURE
  290.                 (if (eqv? rx ry)
  291.                 e
  292.                 'FAILURE)))))
  293.          (else
  294.           (let loop ((x (cdr x)) (y (cdr y)) (e e))
  295.             (cond ((pair? x)
  296.                (if (pair? y)
  297.                    (let ((e (match (car x) (car y) e)))
  298.                  (if (eq? e 'FAILURE)
  299.                      'FAILURE
  300.                      (loop (cdr x) (cdr y) e)))
  301.                    'FAILURE))
  302.               ((eqv? x y) e)
  303.               (else 'FAILURE)))))
  304.            'FAILURE)))
  305.     ((eqv? x y) e)
  306.     (else 'FAILURE)))