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 / rdebug.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  2.5 KB  |  74 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rdebug.scm,v 1.3 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987, 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 Optimizer Debugging Output
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (dump-register-info rgraph)
  27.   (fluid-let ((*current-rgraph* rgraph))
  28.     (for-each-pseudo-register
  29.      (lambda (register)
  30.        (if (positive? (register-n-refs register))
  31.        (begin (newline)
  32.           (write register)
  33.           (write-string ": renumber ")
  34.           (write (register-renumber register))
  35.           (write-string "; nrefs ")
  36.           (write (register-n-refs register))
  37.           (write-string "; length ")
  38.           (write (register-live-length register))
  39.           (write-string "; ndeaths ")
  40.           (write (register-n-deaths register))
  41.           (let ((bblock (register-bblock register)))
  42.             (cond ((eq? bblock 'NON-LOCAL)
  43.                (if (register-crosses-call? register)
  44.                    (write-string "; crosses calls")
  45.                    (write-string "; multiple blocks")))
  46.               (bblock
  47.                (write-string "; block ")
  48.                (write (unhash bblock)))
  49.               (else
  50.                (write-string "; no block!"))))))))))
  51.  
  52. (define (dump-block-info rgraph)
  53.   (fluid-let ((*current-rgraph* rgraph))
  54.     (let ((machine-regs (make-regset (rgraph-n-registers rgraph))))
  55.       (for-each-machine-register
  56.        (lambda (register)
  57.      (regset-adjoin! machine-regs register)))
  58.       (for-each (lambda (bblock)
  59.           (newline)
  60.           (newline)
  61.           (write bblock)
  62.           (bblock-walk-forward bblock
  63.             (lambda (rinst)
  64.               (pp (rinst-rtl rinst))))
  65.           (let ((live-at-exit (bblock-live-at-exit bblock)))
  66.             (regset-difference! live-at-exit machine-regs)
  67.             (if (not (regset-null? live-at-exit))
  68.             (begin (newline)
  69.                    (write-string "Registers live at end:")
  70.                    (for-each-regset-member live-at-exit
  71.                  (lambda (register)
  72.                    (write-string " ")
  73.                    (write register)))))))
  74.         (rgraph-bblocks rgraph)))))