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 / gcdemn.scm < prev    next >
Text File  |  1999-01-02  |  3KB  |  89 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: gcdemn.scm,v 14.8 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. ;;;; Garbage Collector Daemons
  23. ;;; package: (runtime gc-daemons)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (set! primitive-gc-daemons (make-queue))
  29.   (set! trigger-primitive-gc-daemons! (make-trigger primitive-gc-daemons))
  30.   (set! add-primitive-gc-daemon! (make-adder primitive-gc-daemons))
  31.   (set! gc-daemons (make-queue))
  32.   (set! trigger-gc-daemons! (make-trigger gc-daemons))
  33.   (set! add-gc-daemon! (make-adder gc-daemons))
  34.   (set! secondary-gc-daemons (make-queue))
  35.   (set! trigger-secondary-gc-daemons! (make-trigger secondary-gc-daemons))
  36.   (set! add-secondary-gc-daemon! (make-adder secondary-gc-daemons))
  37.   (let ((fixed-objects (get-fixed-objects-vector)))
  38.     (vector-set! fixed-objects #x0B trigger-primitive-gc-daemons!)
  39.     ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))
  40.  
  41. ;;; PRIMITIVE-GC-DAEMONS are executed during the GC.  They must not
  42. ;;; allocate any storage and they must be prepared to run at times
  43. ;;; when many data structures are not consistent.
  44. (define primitive-gc-daemons)
  45. (define trigger-primitive-gc-daemons!)
  46. (define add-primitive-gc-daemon!)
  47.  
  48. ;;; GC-DAEMONS are executed after each GC from an interrupt handler.
  49. ;;; This interrupt handler has lower priority than the GC interrupt,
  50. ;;; which guarantees that these daemons will not be run inside of
  51. ;;; critical sections.  As a result, the daemons may allocate storage
  52. ;;; and use most of the runtime facilities.
  53. (define gc-daemons)
  54. (define trigger-gc-daemons!)
  55. (define add-gc-daemon!)
  56. (define (add-gc-daemon!/no-restore daemon)
  57.   (add-gc-daemon!
  58.    (lambda ()
  59.      (if (not *within-restore-window?*)
  60.      (daemon)))))  
  61.  
  62. ;;; SECONDARY-GC-DAEMONS are executed rarely.  Their purpose is to
  63. ;;; reclaim storage that is either unlikely to be reclaimed or
  64. ;;; expensive to reclaim.
  65. (define secondary-gc-daemons)
  66. (define trigger-secondary-gc-daemons!)
  67. (define add-secondary-gc-daemon!)
  68.  
  69. (define (make-trigger daemons)
  70.   (lambda ()
  71.     (for-each (lambda (thunk) (thunk))
  72.           (queue->list/unsafe daemons))))
  73.  
  74. (define (make-adder daemons)
  75.   (lambda (daemon)
  76.     (enqueue! daemons daemon)))
  77.  
  78. (define (gc-clean #!optional threshold)
  79.   (let ((threshold
  80.      (cond ((default-object? threshold) 100)
  81.            ((not (negative? threshold)) threshold)
  82.            (else (error "threshold must be non-negative" threshold)))))
  83.     (let loop ((previous-free (gc-flip)))
  84.       (trigger-secondary-gc-daemons!)
  85.       (let ((this-free (gc-flip)))
  86.     ;; Don't bother to continue if the savings starts getting small.
  87.     (if (<= (- this-free previous-free) threshold)
  88.         this-free
  89.         (loop this-free))))))