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 / runtime / gcnote.scm < prev    next >
Text File  |  2000-03-24  |  5KB  |  139 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: gcnote.scm,v 14.14 2000/03/25 03:26:30 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 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. ;;;; GC Notification
  23. ;;; package: (runtime gc-notification)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (toggle-gc-notification!)
  28.   (set! hook/record-statistic!
  29.     (let ((current hook/record-statistic!))
  30.       (cond ((eq? current gc-notification) default/record-statistic!)
  31.         ((eq? current default/record-statistic!) gc-notification)
  32.         (else (error "Can't grab GC statistics hook")))))
  33.   unspecific)
  34.  
  35. (define (set-gc-notification! #!optional on?)
  36.   (let ((on? (if (default-object? on?) #T on?)))
  37.     (set! hook/record-statistic!
  38.       (let ((current hook/record-statistic!))
  39.         (if (or (eq? current gc-notification)
  40.             (eq? current default/record-statistic!))
  41.         (if on?
  42.             gc-notification
  43.             default/record-statistic!)
  44.         (error "Can't grab GC statistics hook"))))
  45.     unspecific))
  46.     
  47. (define (with-gc-notification! notify? thunk)
  48.   (fluid-let ((hook/record-statistic!
  49.            (if notify? gc-notification default/record-statistic!)))
  50.     (thunk)))
  51.  
  52. (define (gc-notification statistic)
  53.   (print-statistic statistic (notification-output-port)))
  54.  
  55. (define (print-gc-statistics)
  56.   (let ((status ((ucode-primitive gc-space-status))))
  57.     (let ((granularity (vector-ref status 0))
  58.       (write-number
  59.        (lambda (n c)
  60.          (write-string (string-pad-left (number->string n) c)))))
  61.       (let ((report-one
  62.          (lambda (label low high)
  63.            (let ((n-words (quotient (- high low) granularity)))
  64.          (newline)
  65.          (write-string
  66.           (string-pad-right (string-append label ": ") 17))
  67.          (write-number n-words 8)
  68.          (write-string " words = ")
  69.          (write-number (quotient n-words 1024) 5)
  70.          (write-string " blocks")
  71.          (let ((n-words (remainder n-words 1024)))
  72.            (write-string " + ")
  73.            (write-number n-words 4)
  74.            (write-string " words"))))))
  75.     (let ((report-two
  76.            (lambda (label low free high)
  77.          (report-one (string-append label " in use") low free)
  78.          (report-one (string-append label " free") free high))))
  79.       (report-two "constant"
  80.               (vector-ref status 1)
  81.               (vector-ref status 2)
  82.               (vector-ref status 3))
  83.       (report-two "heap"
  84.               (vector-ref status 4)
  85.               (vector-ref status 5)
  86.               (vector-ref status 6))))))
  87.   (for-each (let ((port (current-output-port)))
  88.           (lambda (statistic)
  89.         (print-statistic statistic port)))
  90.         (gc-statistics)))
  91.  
  92. (define (print-statistic statistic port)
  93.   (fresh-line port)
  94.   (write-string (gc-statistic->string statistic) port)
  95.   (newline port))
  96.  
  97. (define (gc-statistic->string statistic)
  98.   (let* ((ticks/second 1000)
  99.      (intervals->string
  100.      (lambda (start end last-end)
  101.        (let ((gc-length (- end start))
  102.          (period (- end last-end)))
  103.          (string-append
  104.           (string-pad-left
  105.            (number->string (quotient gc-length ticks/second))
  106.            3)
  107.           "."
  108.           (string-pad-right
  109.            (number->string
  110.         (round->exact (/ (remainder gc-length ticks/second)
  111.                  10))
  112.         #d10)
  113.            2
  114.            #\0)
  115.           (string-pad-left
  116.            (string-append
  117.         "("
  118.         (if (zero? period)
  119.             "100"
  120.             (number->string
  121.              (round->exact (* (/ gc-length period) 100))
  122.              #d10))
  123.         "%)")
  124.            7))))))
  125.          
  126.     (string-append ";GC #"
  127.            (number->string (gc-statistic/meter statistic))
  128.            ": took: "
  129.            (intervals->string
  130.             (gc-statistic/this-gc-start statistic)
  131.             (gc-statistic/this-gc-end statistic)
  132.             (gc-statistic/last-gc-end statistic))
  133.            " CPU time, "
  134.            (intervals->string
  135.             (gc-statistic/this-gc-start-clock statistic)
  136.             (gc-statistic/this-gc-end-clock statistic)
  137.             (gc-statistic/last-gc-end-clock statistic))
  138.            " real time; free: "
  139.            (number->string (gc-statistic/heap-left statistic)))))