home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / TRAVERSE.SCM < prev    next >
Text File  |  1992-06-18  |  4KB  |  169 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Utility for tracking down storage leaks.
  5. ;
  6. ; Just do (traverse-depth-first obj1) or (traverse-breadth-first obj1),
  7. ; and then (trail obj2) to find out via what path obj1 points to obj2.
  8. ;
  9. ; Breadth first traversal needs misc/queue.scm.
  10.  
  11.  
  12. (define *mark-table* #f)
  13.  
  14. (define *traverse-count* 0)
  15.  
  16. (define (start-over)        
  17.   (set! *mark-table* (make-table hash))
  18.   (set! *traverse-count* 0))
  19.  
  20. (define (traverse-depth-first obj)
  21.   (start-over)
  22.   (let recur ((obj obj) (parent 'root) (parent-tag 'root))
  23.     (if (stored? obj)
  24.     (if (not (table-ref *mark-table* obj))
  25.         (let ((tag (visit obj parent parent-tag)))
  26.           (for-each (lambda (child)
  27.               (recur child obj tag))
  28.             (subobjects obj)))))))
  29.  
  30. (define (traverse-breadth-first obj)
  31.   (start-over)
  32.   (let ((queue (make-queue)))
  33.     (define (deal-with obj parent parent-tag)
  34.       (if (stored? obj)
  35.       (if (not (table-ref *mark-table* obj))
  36.           (enqueue queue
  37.                (cons obj
  38.                  (visit obj parent parent-tag))))))
  39.     (deal-with obj 'root 'root)
  40.     (let loop ()
  41.       (if (not (queue-empty? queue))
  42.       (let* ((parent+tag (dequeue queue))
  43.          (parent (car parent+tag))
  44.          (parent-tag (cdr parent+tag)))
  45.         (for-each (lambda (obj)
  46.             (deal-with obj parent parent-tag))
  47.               (subobjects parent))
  48.         (loop))))))
  49.  
  50. (define (visit obj parent parent-tag)
  51.   (table-set! *mark-table* obj parent)
  52.   (if (interesting? obj)
  53.       (let ((tag *traverse-count*))
  54.     (set! *traverse-count* (+ *traverse-count* 1))
  55.     (write tag) (display " ")
  56.     (write (list parent-tag))
  57.     (display ": ") (write obj) (newline)
  58.     tag)
  59.       parent-tag))
  60.  
  61. (define (trail obj)
  62.   (let ((probe (table-ref *mark-table* obj)))
  63.     (if probe
  64.     (trail probe))
  65.     (if (not (vector? obj))
  66.     (begin (write obj)
  67.            (newline)))))
  68.  
  69. (define interesting? procedure?)
  70. ;(define (interesting? obj)
  71. ;  (if (pair? obj)
  72. ;      #f
  73. ;      (if (vector? obj)
  74. ;          #f
  75. ;          #t)))
  76.       
  77.     
  78. (define (subobjects obj)
  79.   (cond ((pair? obj) (list (car obj) (cdr obj)))
  80.     ((symbol? obj) (list (symbol->string obj)))
  81.     ((vector? obj) (vector->list obj))
  82.     ((closure? obj) (list (closure-template obj) (closure-env obj)))
  83.     ((location? obj) (list (location-id obj) (contents obj)))
  84.     ((record? obj) (record->list obj))
  85.     ((continuation? obj) (continuation->list obj))
  86.     ((extended-number? obj) (extended-number->list obj))
  87.     (else '())))
  88.  
  89.  
  90. (define (record->list v)
  91.   (let ((z (record-length v)))
  92.     (do ((i (- z 1) (- i 1))
  93.          (l '() (cons (record-ref v i) l)))
  94.         ((< i 0) l))))
  95.  
  96. (define (continuation->list v)
  97.   (let ((z (continuation-length v)))
  98.     (do ((i (- z 1) (- i 1))
  99.          (l '() (cons (continuation-ref v i) l)))
  100.         ((< i 0) l))))
  101.  
  102. (define (extended-number->list v)
  103.   (let ((z (extended-number-length v)))
  104.     (do ((i (- z 1) (- i 1))
  105.          (l '() (cons (extended-number-ref v i) l)))
  106.         ((< i 0) l))))
  107.  
  108.  
  109.  
  110. (define (quick-hash obj n)
  111.   (cond ((symbol? obj) (string-hash (symbol->string obj)))
  112.     ((location? obj) (+ 3 (quick-hash (location-id obj) n)))
  113.     ((string? obj) (+ 33 (string-hash obj)))
  114.     ((integer? obj) (if (and (>= obj 0)
  115.                  (< obj hash-mask))
  116.                 obj
  117.                 (modulo obj hash-mask)))
  118.     ((char? obj) (+ 333 (char->integer obj)))
  119.     ((eq? obj #f) 3001)
  120.     ((eq? obj #t) 3003)
  121.     ((null? obj) 3005)
  122.     ((pair? obj) (if (= n 0)
  123.              30007
  124.              (+ (quick-hash (car obj) (- n 1))
  125.                 (quick-hash (cdr obj) (- n 1)))))
  126.     ((vector? obj) (if (= n 0)
  127.                30009
  128.                (if (> (vector-length obj) 1)
  129.                    (+ 30011 (quick-hash (vector-ref obj 1)
  130.                             (- n 1)))
  131.                    30017)))
  132.     ((number? obj) 4000)
  133.     ((closure? obj) 4004)
  134.     ((output-port? obj) 4006)
  135.     ((input-port? obj) 4007)
  136.     ((record? obj) 4008)
  137.     ((continuation? obj) 4009)
  138.     ((number? obj) 40010)
  139.     ((string? obj) 40011)
  140.     ((code-vector? obj) 40012)
  141.     ((eq? obj (unspecified)) 40013)
  142.     (else 50007)))
  143.  
  144. (define hash-mask (- (arithmetic-shift 1 26) 1))
  145.  
  146. (define (hash obj) (quick-hash obj 1))
  147.  
  148. (define (leaf? obj)
  149.   (or (and (number? obj)
  150.        (not (extended-number? obj)))
  151.       ;; (symbol? obj)
  152.       (string? obj)
  153.       (code-vector? obj)
  154.       (char? obj)
  155.       (eq? obj #f)
  156.       (eq? obj #t)
  157.       (eq? obj '())
  158.       (eq? obj (unspecified))))
  159.  
  160. (define usual-leaf-predicate leaf?)
  161.  
  162. (define (set-leaf-predicate! proc) (set! leaf? proc))
  163.  
  164. (define (stored? obj) (not (leaf? obj)))
  165.  
  166. (define least-fixnum (arithmetic-shift -1 29))
  167. (define greatest-fixnum (- -1 least-fixnum))
  168.  
  169.