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 / gcstat.scm < prev    next >
Text File  |  1999-01-02  |  6KB  |  224 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: gcstat.scm,v 14.6 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-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. ;;;; GC Statistics
  23. ;;; package: (runtime gc-statistics)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (set! hook/record-statistic! default/record-statistic!)
  29.   (set! history-modes
  30.     `((NONE . ,none:install-history!)
  31.       (BOUNDED . ,bounded:install-history!)
  32.       (UNBOUNDED . ,unbounded:install-history!)))
  33.   (set-history-mode! 'BOUNDED)
  34.   (set! timestamp (cons 0 0))
  35.   (statistics-reset!)
  36.   (add-event-receiver! event:after-restore statistics-reset!)
  37.   (set! hook/gc-start recorder/gc-start)
  38.   (set! hook/gc-finish recorder/gc-finish)
  39.   unspecific)
  40.  
  41. (define (recorder/gc-start)
  42.   (port/gc-start (nearest-cmdl/port))
  43.   (set! this-gc-start-clock (real-time-clock))
  44.   (set! this-gc-start (process-time-clock))
  45.   unspecific)
  46.  
  47. (define (recorder/gc-finish ignored space-remaining)
  48.   ignored
  49.   (let* ((end-time (process-time-clock))
  50.      (end-time-clock (real-time-clock)))
  51.     (increment-non-runtime! (- end-time this-gc-start))
  52.     (statistics-flip this-gc-start end-time
  53.              space-remaining
  54.              this-gc-start-clock end-time-clock))
  55.   (port/gc-finish (nearest-cmdl/port)))
  56.  
  57. (define timestamp)
  58. (define total-gc-time)
  59. (define last-gc-start)
  60. (define last-gc-end)
  61. (define this-gc-start)
  62. (define this-gc-start-clock)
  63. (define last-gc-start-clock)
  64. (define last-gc-end-clock)
  65.  
  66. (define (gc-timestamp)
  67.   timestamp)
  68.  
  69. (define (statistics-reset!)
  70.   (set! timestamp (cons 1 (1+ (cdr timestamp))))
  71.   (set! total-gc-time 0)
  72.   (set! last-gc-start-clock false)
  73.   (set! last-gc-end-clock (real-time-clock))
  74.   (set! last-gc-start false)
  75.   (set! last-gc-end (process-time-clock))
  76.   (reset-recorder! '()))
  77.  
  78. (define-structure (gc-statistic (conc-name gc-statistic/))
  79.   (timestamp false read-only true)
  80.   (heap-left false read-only true)
  81.   (this-gc-start false read-only true)
  82.   (this-gc-end false read-only true)
  83.   (last-gc-start false read-only true)
  84.   (last-gc-end false read-only true)
  85.   (this-gc-start-clock false read-only true)
  86.   (this-gc-end-clock false read-only true)
  87.   (last-gc-start-clock false read-only true)
  88.   (last-gc-end-clock false read-only true))
  89.  
  90. (define (statistics-flip start-time end-time heap-left start-clock end-clock)
  91.   (let ((statistic
  92.      (make-gc-statistic timestamp heap-left
  93.                 start-time end-time
  94.                 last-gc-start last-gc-end
  95.                 start-clock end-clock
  96.                 last-gc-start-clock last-gc-end-clock)))
  97.     (set! timestamp (cons (1+ (car timestamp)) (cdr timestamp)))
  98.     (set! total-gc-time (+ (- end-time start-time) total-gc-time))
  99.     (set! last-gc-start start-time)
  100.     (set! last-gc-end end-time)
  101.     (set! last-gc-start-clock start-clock)
  102.     (set! last-gc-end-clock end-clock)
  103.     (record-statistic! statistic)
  104.     (hook/record-statistic! statistic)))
  105.  
  106. (define (gc-statistic/meter stat)
  107.   (car (gc-statistic/timestamp stat)))
  108.  
  109. (define hook/record-statistic!)
  110.  
  111. (define (default/record-statistic! statistic)
  112.   statistic
  113.   false)
  114.  
  115. (define (gctime)
  116.   (internal-time/ticks->seconds total-gc-time))
  117.  
  118. ;;;; Statistics Recorder
  119.  
  120. (define last-statistic)
  121. (define history)
  122.  
  123. (define (reset-recorder! old)
  124.   (set! last-statistic false)
  125.   (reset-history! old))
  126.  
  127. (define (record-statistic! statistic)
  128.   (set! last-statistic statistic)
  129.   (record-in-history! statistic))
  130.  
  131. (define (gc-statistics)
  132.   (let ((history (get-history)))
  133.     (if (null? history)
  134.     (if last-statistic
  135.         (list last-statistic)
  136.         '())
  137.     history)))
  138.  
  139. ;;;; History Modes
  140.  
  141. (define reset-history!)
  142. (define record-in-history!)
  143. (define get-history)
  144. (define history-mode)
  145.  
  146. (define (gc-history-mode #!optional new-mode)
  147.   (let ((old-mode history-mode))
  148.     (if (not (default-object? new-mode))
  149.     (let ((old-history (get-history)))
  150.       (set-history-mode! new-mode)
  151.       (reset-history! old-history)))
  152.     old-mode))
  153.  
  154. (define (set-history-mode! mode)
  155.   (let ((entry (assq mode history-modes)))
  156.     (if (not entry)
  157.     (error "Bad mode name" 'SET-HISTORY-MODE! mode))
  158.     ((cdr entry))
  159.     (set! history-mode (car entry))))
  160.  
  161. (define history-modes)
  162.  
  163. ;;; NONE
  164.  
  165. (define (none:install-history!)
  166.   (set! reset-history! none:reset-history!)
  167.   (set! record-in-history! none:record-in-history!)
  168.   (set! get-history none:get-history))
  169.  
  170. (define (none:reset-history! old)
  171.   old
  172.   (set! history '()))
  173.  
  174. (define (none:record-in-history! item)
  175.   item
  176.   'DONE)
  177.  
  178. (define (none:get-history)
  179.   '())
  180.  
  181. ;;; BOUNDED
  182.  
  183. (define history-size 8)
  184.  
  185. (define (copy-to-size l size)
  186.   (let ((max (length l)))
  187.     (if (>= max size)
  188.     (list-head l size)
  189.     (append (list-head l max)
  190.         (make-list (- size max) '())))))
  191.  
  192. (define (bounded:install-history!)
  193.   (set! reset-history! bounded:reset-history!)
  194.   (set! record-in-history! bounded:record-in-history!)
  195.   (set! get-history bounded:get-history))
  196.  
  197. (define (bounded:reset-history! old)
  198.   (set! history (apply circular-list (copy-to-size old history-size))))
  199.  
  200. (define (bounded:record-in-history! item)
  201.   (set-car! history item)
  202.   (set! history (cdr history)))
  203.  
  204. (define (bounded:get-history)
  205.   (let loop ((scan (cdr history)))
  206.     (cond ((eq? scan history) '())
  207.       ((null? (car scan)) (loop (cdr scan)))
  208.       (else (cons (car scan) (loop (cdr scan)))))))
  209.  
  210. ;;; UNBOUNDED
  211.  
  212. (define (unbounded:install-history!)
  213.   (set! reset-history! unbounded:reset-history!)
  214.   (set! record-in-history! unbounded:record-in-history!)
  215.   (set! get-history unbounded:get-history))
  216.  
  217. (define (unbounded:reset-history! old)
  218.   (set! history old))
  219.  
  220. (define (unbounded:record-in-history! item)
  221.   (set! history (cons item history)))
  222.  
  223. (define (unbounded:get-history)
  224.   (reverse history))