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 / base / debug.scm < prev    next >
Text File  |  1999-12-20  |  7KB  |  225 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: debug.scm,v 4.15 1999/12/20 23:07:24 cph Exp $
  4.  
  5. Copyright (c) 1988, 1989, 1990, 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. ;;;; Compiler Debugging Support
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define (po object)
  27.   (let ((object (->tagged-vector object)))
  28.     (newline)
  29.     (write object)
  30.     (for-each pp ((tagged-vector/description object) object))))
  31.  
  32. (define (debug/find-procedure name)
  33.   (let loop ((procedures *procedures*))
  34.     (and (not (null? procedures))
  35.      (if (and (not (procedure-continuation? (car procedures)))
  36.           (or (eq? name (procedure-name (car procedures)))
  37.               (eq? name (procedure-label (car procedures)))))
  38.          (car procedures)
  39.          (loop (cdr procedures))))))
  40.  
  41. (define (debug/find-continuation number)
  42.   (let ((label
  43.      (intern (string-append "continuation-" (number->string number)))))
  44.     (let loop ((procedures *procedures*))
  45.       (and (not (null? procedures))
  46.        (if (and (procedure-continuation? (car procedures))
  47.             (eq? label (procedure-label (car procedures))))
  48.            (car procedures)
  49.            (loop (cdr procedures)))))))
  50.  
  51. (define (debug/find-entry-node node)
  52.   (let ((node (->tagged-vector node)))
  53.     (if (eq? (expression-entry-node *root-expression*) node)
  54.     (begin
  55.       (newline)
  56.       (write *root-expression*)))
  57.     (for-each (lambda (procedure)
  58.         (if (eq? (procedure-entry-node procedure) node)
  59.             (begin
  60.               (newline)
  61.               (write procedure))))
  62.           *procedures*)))
  63.  
  64. (define (debug/where object)
  65.   (cond ((compiled-code-block? object)
  66.      (newline)
  67.      (write (compiled-code-block/debugging-info object)))
  68.     ((compiled-code-address? object)
  69.      (newline)
  70.      (write
  71.       (compiled-code-block/debugging-info
  72.        (compiled-code-address->block object)))
  73.      (write-string "\nOffset: ")
  74.      (write-string
  75.       (number->string (compiled-code-address->offset object) 16)))
  76.     (else
  77.      (error "debug/where -- what?" object))))
  78.  
  79. (define (write-rtl-instructions rtl port)
  80.   (write-instructions
  81.    (lambda ()
  82.      (with-output-to-port port
  83.        (lambda ()
  84.      (for-each show-rtl-instruction rtl))))))
  85.  
  86. (define (dump-rtl filename)
  87.   (write-instructions
  88.    (lambda ()
  89.      (with-output-to-file (pathname-new-type (->pathname filename) "rtl")
  90.        (lambda ()
  91.      (for-each show-rtl-instruction (linearize-rtl *rtl-graphs*)))))))
  92.  
  93. (define (show-rtl rtl)
  94.   (newline)
  95.   (pp-instructions
  96.    (lambda ()
  97.      (for-each show-rtl-instruction rtl))))
  98.  
  99. (define (show-bblock-rtl bblock)
  100.   (newline)
  101.   (pp-instructions
  102.    (lambda ()
  103.      (bblock-walk-forward (->tagged-vector bblock)
  104.        (lambda (rinst)
  105.      (show-rtl-instruction (rinst-rtl rinst)))))))
  106.  
  107. (define (write-instructions thunk)
  108.   (fluid-let ((*show-instruction* write)
  109.           (*unparser-radix* 16)
  110.           (*unparse-uninterned-symbols-by-name?* true))
  111.     (thunk)))
  112.  
  113. (define (pp-instructions thunk)
  114.   (fluid-let ((*show-instruction* pretty-print)
  115.           (*pp-primitives-by-name* false)
  116.           (*unparser-radix* 16)
  117.           (*unparse-uninterned-symbols-by-name?* true))
  118.     (thunk)))
  119.  
  120. (define *show-instruction*)
  121.  
  122. (define (show-rtl-instruction rtl)
  123.   (if (memq (car rtl)
  124.         '(LABEL CONTINUATION-ENTRY CONTINUATION-HEADER IC-PROCEDURE-HEADER
  125.             OPEN-PROCEDURE-HEADER PROCEDURE-HEADER CLOSURE-HEADER))
  126.       (newline))
  127.   (*show-instruction* rtl)
  128.   (newline))
  129.  
  130. (define procedure-queue)
  131. (define procedures-located)
  132.  
  133. (define (show-fg)
  134.   (fluid-let ((procedure-queue (make-queue))
  135.           (procedures-located '()))
  136.     (write-string "\n---------- Expression ----------")
  137.     (fg/print-object *root-expression*)
  138.     (with-new-node-marks
  139.      (lambda ()
  140.        (fg/print-entry-node (expression-entry-node *root-expression*))
  141.        (queue-map!/unsafe procedure-queue
  142.      (lambda (procedure)
  143.        (if (procedure-continuation? procedure)
  144.            (write-string "\n\n---------- Continuation ----------")
  145.            (write-string "\n\n---------- Procedure ----------"))
  146.        (fg/print-object procedure)
  147.        (fg/print-entry-node (procedure-entry-node procedure))))))
  148.     (write-string "\n\n---------- Blocks ----------")
  149.     (fg/print-blocks (expression-block *root-expression*))))
  150.  
  151. (define (show-fg-node node)
  152.   (fluid-let ((procedure-queue false))
  153.     (with-new-node-marks
  154.      (lambda ()
  155.        (fg/print-entry-node
  156.     (let ((node (->tagged-vector node)))
  157.       (if (procedure? node)
  158.           (procedure-entry-node node)
  159.           node)))))))
  160.  
  161. (define (fg/print-entry-node node)
  162.   (if node
  163.       (fg/print-node node)))
  164.  
  165. (define (fg/print-object object)
  166.   (newline)
  167.   (po object))
  168.  
  169. (define (fg/print-blocks block)
  170.   (fg/print-object block)
  171.   (for-each fg/print-object (block-bound-variables block))
  172.   (if (not (block-parent block))
  173.       (for-each fg/print-object (block-free-variables block)))
  174.   (for-each fg/print-blocks (block-children block))
  175.   (for-each fg/print-blocks (block-disowned-children block)))
  176.  
  177. (define (fg/print-node node)
  178.   (if (and node
  179.        (not (node-marked? node)))
  180.       (begin
  181.     (node-mark! node)
  182.     (fg/print-object node)
  183.     (cfg-node-case (tagged-vector/tag node)
  184.       ((PARALLEL)
  185.        (for-each fg/print-subproblem (parallel-subproblems node))
  186.        (fg/print-node (snode-next node)))
  187.       ((APPLICATION)
  188.        (fg/print-rvalue (application-operator node))
  189.        (for-each fg/print-rvalue (application-operands node)))
  190.       ((VIRTUAL-RETURN)
  191.        (fg/print-rvalue (virtual-return-operand node))
  192.        (fg/print-node (snode-next node)))
  193.       ((POP)
  194.        (fg/print-rvalue (pop-continuation node))
  195.        (fg/print-node (snode-next node)))
  196.       ((ASSIGNMENT)
  197.        (fg/print-rvalue (assignment-rvalue node))
  198.        (fg/print-node (snode-next node)))
  199.       ((DEFINITION)
  200.        (fg/print-rvalue (definition-rvalue node))
  201.        (fg/print-node (snode-next node)))
  202.       ((TRUE-TEST)
  203.        (fg/print-rvalue (true-test-rvalue node))
  204.        (fg/print-node (pnode-consequent node))
  205.        (fg/print-node (pnode-alternative node)))
  206.       ((STACK-OVERWRITE FG-NOOP)
  207.        (fg/print-node (snode-next node)))))))
  208.  
  209. (define (fg/print-rvalue rvalue)
  210.   (if procedure-queue
  211.       (let ((rvalue (rvalue-known-value rvalue)))
  212.     (if (and rvalue
  213.          (rvalue/procedure? rvalue)
  214.          (not (memq rvalue procedures-located)))
  215.         (begin
  216.           (set! procedures-located (cons rvalue procedures-located))
  217.           (enqueue!/unsafe procedure-queue rvalue))))))
  218.  
  219. (define (fg/print-subproblem subproblem)
  220.   (fg/print-object subproblem)
  221.   (if (subproblem-canonical? subproblem)
  222.       (fg/print-rvalue (subproblem-continuation subproblem)))
  223.   (let ((prefix (subproblem-prefix subproblem)))
  224.     (if (not (cfg-null? prefix))
  225.     (fg/print-node (cfg-entry-node prefix)))))