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 / gc.scm < prev    next >
Text File  |  1999-01-02  |  7KB  |  225 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: gc.scm,v 14.16 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
  23. ;;; package: (runtime garbage-collector)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (set! gc-boot-loading? true)
  29.   (set! hook/gc-flip default/gc-flip)
  30.   (set! hook/purify default/purify)
  31.   (set! hook/stack-overflow default/stack-overflow)
  32.   (set! hook/hardware-trap default/hardware-trap)
  33.   (set! default-safety-margin 4500)
  34.   (set! pure-space-queue '())
  35.   (set! constant-space-queue '())
  36.   (set! hook/gc-start default/gc-start)
  37.   (set! hook/gc-finish default/gc-finish)
  38.   (let ((fixed-objects (get-fixed-objects-vector)))
  39.     (let ((interrupt-vector (vector-ref fixed-objects 1)))
  40.       (vector-set! interrupt-vector 0 condition-handler/stack-overflow)
  41.       (vector-set! interrupt-vector 2 condition-handler/gc))
  42.     (vector-set! fixed-objects #x0C condition-handler/hardware-trap)
  43.     ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))
  44.  
  45. (define (condition-handler/gc interrupt-code interrupt-enables)
  46.   interrupt-code interrupt-enables
  47.   (hook/gc-flip default-safety-margin))
  48.  
  49. (define (condition-handler/stack-overflow interrupt-code interrupt-enables)
  50.   interrupt-code
  51.   (hook/stack-overflow)
  52.   (set-interrupt-enables! interrupt-enables))
  53.  
  54. (define (condition-handler/hardware-trap escape-code)
  55.   ((ucode-primitive set-trap-state!)
  56.    ((ucode-primitive set-trap-state!) 2)) ; Ask.
  57.   (hook/hardware-trap escape-code))
  58.  
  59. (define hook/gc-flip)
  60. (define hook/purify)
  61. (define hook/stack-overflow)
  62. (define hook/hardware-trap)
  63. (define default-safety-margin)
  64.  
  65. (define (default/gc-flip safety-margin)
  66.   (define (real-default)
  67.     (gc-flip-internal safety-margin))
  68.  
  69.   (cond ((not (null? pure-space-queue))
  70.      (let ((result (purify-internal pure-space-queue true safety-margin)))
  71.        (cond ((not (pair? result))
  72.           ;; Wrong phase -- wait until next time.
  73.           (real-default))
  74.          ((not (car result))
  75.           (set! pure-space-queue (cdr pure-space-queue))
  76.           (queued-purification-failure)
  77.           (cdr result))
  78.          (else
  79.           (set! pure-space-queue '())
  80.           (cdr result)))))
  81.     ((not (null? constant-space-queue))
  82.      (let ((result
  83.         (purify-internal constant-space-queue false safety-margin)))
  84.        (cond ((not (pair? result))
  85.           ;; Wrong phase -- wait until next time.
  86.           (real-default))
  87.          ((not (car result))
  88.           (set! constant-space-queue (cdr constant-space-queue))
  89.           (queued-purification-failure)
  90.           (cdr result))
  91.          (else
  92.           (set! constant-space-queue '())
  93.           (cdr result)))))
  94.     (else
  95.      (real-default))))
  96.  
  97. (define (queued-purification-failure)
  98.   (warn "Unable to purify all queued items; dequeuing one"))
  99.  
  100. (define (default/purify item pure-space? queue?)
  101.   (if (not (if pure-space? (object-pure? item) (object-constant? item)))
  102.       (cond ((not queue?)
  103.          (let loop ()
  104.            (let ((result
  105.               (purify-internal item
  106.                        pure-space?
  107.                        default-safety-margin)))
  108.          (cond ((not (pair? result))
  109.             ;; Wrong phase -- try again.
  110.             (gc-flip)
  111.             (loop))
  112.                ((not (car result))
  113.             (error "PURIFY: not enough room in constant space"
  114.                    item))
  115.                (else
  116.             unspecific)))))
  117.         (pure-space?
  118.          (with-absolutely-no-interrupts
  119.           (lambda ()
  120.         (set! pure-space-queue (cons item pure-space-queue))
  121.         unspecific)))
  122.         (else
  123.          (with-absolutely-no-interrupts
  124.           (lambda ()
  125.         (set! constant-space-queue (cons item constant-space-queue))
  126.         unspecific))))))
  127.  
  128. (define (default/stack-overflow)
  129.   (abort->nearest "Aborting!: maximum recursion depth exceeded"))
  130.  
  131. (define (default/hardware-trap escape-code)
  132.   escape-code
  133.   (abort->nearest "Aborting!: the hardware trapped"))
  134.  
  135. (define pure-space-queue)
  136. (define constant-space-queue)
  137. (define hook/gc-start)
  138. (define hook/gc-finish)
  139.  
  140. (define (gc-flip-internal safety-margin)
  141.   (let ((start-value (hook/gc-start)))
  142.     (let ((space-remaining ((ucode-primitive garbage-collect) safety-margin)))
  143.       (gc-finish start-value space-remaining)
  144.       space-remaining)))
  145.  
  146. (define (purify-internal item pure-space? safety-margin)
  147.   (let ((start-value (hook/gc-start)))
  148.     (let ((result
  149.        ((ucode-primitive primitive-purify) item
  150.                            pure-space?
  151.                            safety-margin)))
  152.       (if result
  153.       (gc-finish start-value (cdr result)))
  154.       result)))
  155.  
  156. (define (default/gc-start)
  157.   false)
  158.  
  159. (define (default/gc-finish start-value space-remaining)
  160.   start-value space-remaining
  161.   false)
  162.  
  163. (define (gc-finish start-value space-remaining)
  164.   (if (< space-remaining 4096)
  165.       (if gc-boot-loading?
  166.       (let ((console ((ucode-primitive tty-output-channel 0))))
  167.         ((ucode-primitive channel-write 4)
  168.          console
  169.          gc-boot-death-message
  170.          0
  171.          ((ucode-primitive string-length 1) gc-boot-death-message))
  172.         ((ucode-primitive exit-with-value 1) #x14))
  173.       (abort->nearest
  174.        (cmdl-message/append
  175.         (cmdl-message/strings "Aborting!: out of memory")
  176.         ;; Clean up whatever possible to avoid a reoccurrence.
  177.         (cmdl-message/active
  178.          (lambda (port)
  179.            port
  180.            (with-gc-notification! true gc-clean)))))))
  181.   ((ucode-primitive request-interrupts! 1) interrupt-bit/after-gc)
  182.   (hook/gc-finish start-value space-remaining))
  183.  
  184. (define gc-boot-loading?)
  185.   
  186. (define gc-boot-death-message
  187.   "\n;; Aborting boot-load: Not enough memory to load -- Use -large option.\n")
  188.  
  189. ;;;; User Primitives
  190.  
  191. (define (set-gc-safety-margin! #!optional safety-margin)
  192.   (if (not (or (default-object? safety-margin) (not safety-margin)))
  193.       (begin
  194.     (set! default-safety-margin safety-margin)
  195.     (gc-flip safety-margin)))
  196.   default-safety-margin)
  197.  
  198. (define (gc-flip #!optional safety-margin)
  199.   ;; Optionally overrides the GC safety margin for this flip only.
  200.   (with-absolutely-no-interrupts
  201.    (lambda ()
  202.      (hook/gc-flip (if (default-object? safety-margin)
  203.                default-safety-margin
  204.                safety-margin)))))
  205.  
  206. (define (flush-purification-queue!)
  207.   (if (or (not (null? pure-space-queue))
  208.       (not (null? constant-space-queue)))
  209.       (begin
  210.     (gc-flip)
  211.     (flush-purification-queue!))))
  212.  
  213. (define (purify item #!optional pure-space? queue?)
  214.   ;; Purify an item -- move it into pure space and clean everything by
  215.   ;; doing a gc-flip.
  216.   (hook/purify item
  217.            (if (default-object? pure-space?) true pure-space?)
  218.            (if (default-object? queue?) true queue?))
  219.   item)
  220.  
  221. (define (constant-space/in-use)
  222.   (- (get-next-constant) constant-space/base))
  223.  
  224. ;; This is set to the correct value during the cold load.
  225. (define constant-space/base)