src/runtime/gcstat.scm

   1 #| -*-Scheme-*-
   2
   3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
   4     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
   5     2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
   6     Institute of Technology
   7
   8 This file is part of MIT/GNU Scheme.
   9
  10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
  11 it under the terms of the GNU General Public License as published by
  12 the Free Software Foundation; either version 2 of the License, or (at
  13 your option) any later version.
  14
  15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
  16 WITHOUT ANY WARRANTY; without even the implied warranty of
  17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 General Public License for more details.
  19
  20 You should have received a copy of the GNU General Public License
  21 along with MIT/GNU Scheme; if not, write to the Free Software
  22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
  23 USA.
  24
  25 |#
  26
  27 ;;;; GC Statistics
  28 ;;; package: (runtime gc-statistics)
  29
  30 (declare (usual-integrations))
  31
  32 (define (initialize-package!)
  33   (set! hook/record-statistic! default/record-statistic!)
  34   (set! history-modes
  35         `((NONE . ,none:install-history!)
  36           (BOUNDED . ,bounded:install-history!)
  37           (UNBOUNDED . ,unbounded:install-history!)))
  38   (set-history-mode! 'BOUNDED)
  39   (set! timestamp (cons 0 0))
  40   (statistics-reset!)
  41   (add-event-receiver! event:after-restore statistics-reset!)
  42   (set! hook/gc-start recorder/gc-start)
  43   (set! hook/gc-finish recorder/gc-finish)
  44   unspecific)
  45
  46 (define (recorder/gc-start)
  47   (port/gc-start (nearest-cmdl/port))
  48   (set! this-gc-start-clock (real-time-clock))
  49   (set! this-gc-start (process-time-clock))
  50   unspecific)
  51
  52 (define (recorder/gc-finish ignored space-remaining)
  53   ignored
  54   (let* ((end-time (process-time-clock))
  55          (end-time-clock (real-time-clock)))
  56     (increment-non-runtime! (- end-time this-gc-start))
  57     (statistics-flip this-gc-start end-time
  58                      space-remaining
  59                      this-gc-start-clock end-time-clock))
  60   (port/gc-finish (nearest-cmdl/port)))
  61 \f
  62 (define timestamp)
  63 (define total-gc-time)
  64 (define last-gc-start)
  65 (define last-gc-end)
  66 (define this-gc-start)
  67 (define this-gc-start-clock)
  68 (define last-gc-start-clock)
  69 (define last-gc-end-clock)
  70
  71 (define (gc-timestamp)
  72   timestamp)
  73
  74 (define (statistics-reset!)
  75   (set! timestamp (cons 1 (1+ (cdr timestamp))))
  76   (set! total-gc-time 0)
  77   (set! last-gc-start-clock false)
  78   (set! last-gc-end-clock (real-time-clock))
  79   (set! last-gc-start false)
  80   (set! last-gc-end (process-time-clock))
  81   (reset-recorder! '()))
  82
  83 (define-structure (gc-statistic (conc-name gc-statistic/))
  84   (timestamp false read-only true)
  85   (heap-left false read-only true)
  86   (this-gc-start false read-only true)
  87   (this-gc-end false read-only true)
  88   (last-gc-start false read-only true)
  89   (last-gc-end false read-only true)
  90   (this-gc-start-clock false read-only true)
  91   (this-gc-end-clock false read-only true)
  92   (last-gc-start-clock false read-only true)
  93   (last-gc-end-clock false read-only true))
  94
  95 (define (statistics-flip start-time end-time heap-left start-clock end-clock)
  96   (let ((statistic
  97          (make-gc-statistic timestamp heap-left
  98                             start-time end-time
  99                             last-gc-start last-gc-end
 100                             start-clock end-clock
 101                             last-gc-start-clock last-gc-end-clock)))
 102     (set! timestamp (cons (1+ (car timestamp)) (cdr timestamp)))
 103     (set! total-gc-time (+ (- end-time start-time) total-gc-time))
 104     (set! last-gc-start start-time)
 105     (set! last-gc-end end-time)
 106     (set! last-gc-start-clock start-clock)
 107     (set! last-gc-end-clock end-clock)
 108     (record-statistic! statistic)
 109     (hook/record-statistic! statistic)))
 110
 111 (define (gc-statistic/meter stat)
 112   (car (gc-statistic/timestamp stat)))
 113
 114 (define hook/record-statistic!)
 115
 116 (define (default/record-statistic! statistic)
 117   statistic
 118   false)
 119
 120 (define (gctime)
 121   (internal-time/ticks->seconds total-gc-time))
 122 \f
 123 ;;;; Statistics Recorder
 124
 125 (define last-statistic)
 126 (define history)
 127
 128 (define (reset-recorder! old)
 129   (set! last-statistic false)
 130   (reset-history! old))
 131
 132 (define (record-statistic! statistic)
 133   (set! last-statistic statistic)
 134   (record-in-history! statistic))
 135
 136 (define (gc-statistics)
 137   (let ((history (get-history)))
 138     (if (null? history)
 139         (if last-statistic
 140             (list last-statistic)
 141             '())
 142         history)))
 143 \f
 144 ;;;; History Modes
 145
 146 (define reset-history!)
 147 (define record-in-history!)
 148 (define get-history)
 149 (define history-mode)
 150
 151 (define (gc-history-mode #!optional new-mode)
 152   (let ((old-mode history-mode))
 153     (if (not (default-object? new-mode))
 154         (let ((old-history (get-history)))
 155           (set-history-mode! new-mode)
 156           (reset-history! old-history)))
 157     old-mode))
 158
 159 (define (set-history-mode! mode)
 160   (let ((entry (assq mode history-modes)))
 161     (if (not entry)
 162         (error "Bad mode name" 'SET-HISTORY-MODE! mode))
 163     ((cdr entry))
 164     (set! history-mode (car entry))))
 165
 166 (define history-modes)
 167 \f
 168 ;;; NONE
 169
 170 (define (none:install-history!)
 171   (set! reset-history! none:reset-history!)
 172   (set! record-in-history! none:record-in-history!)
 173   (set! get-history none:get-history))
 174
 175 (define (none:reset-history! old)
 176   old
 177   (set! history '()))
 178
 179 (define (none:record-in-history! item)
 180   item
 181   'DONE)
 182
 183 (define (none:get-history)
 184   '())
 185 \f
 186 ;;; BOUNDED
 187
 188 (define history-size 8)
 189
 190 (define (copy-to-size l size)
 191   (let ((max (length l)))
 192     (if (>= max size)
 193         (list-head l size)
 194         (append (list-head l max)
 195                 (make-list (- size max) '())))))
 196
 197 (define (bounded:install-history!)
 198   (set! reset-history! bounded:reset-history!)
 199   (set! record-in-history! bounded:record-in-history!)
 200   (set! get-history bounded:get-history))
 201
 202 (define (bounded:reset-history! old)
 203   (set! history (apply circular-list (copy-to-size old history-size))))
 204
 205 (define (bounded:record-in-history! item)
 206   (set-car! history item)
 207   (set! history (cdr history)))
 208
 209 (define (bounded:get-history)
 210   (let loop ((scan (cdr history)))
 211     (cond ((eq? scan history) '())
 212           ((null? (car scan)) (loop (cdr scan)))
 213           (else (cons (car scan) (loop (cdr scan)))))))
 214 \f
 215 ;;; UNBOUNDED
 216
 217 (define (unbounded:install-history!)
 218   (set! reset-history! unbounded:reset-history!)
 219   (set! record-in-history! unbounded:record-in-history!)
 220   (set! get-history unbounded:get-history))
 221
 222 (define (unbounded:reset-history! old)
 223   (set! history old))
 224
 225 (define (unbounded:record-in-history! item)
 226   (set! history (cons item history)))
 227
 228 (define (unbounded:get-history)
 229   (reverse history))