← Back to branch summary

~ubuntu-branches/ubuntu/trusty/mit-scheme/trusty-proposed

« back to all changes in this revision

Viewing changes to src/runtime/gc.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2006-09-20 21:59:42 UTC
  • mfrom: (1.1.4 upstream) (3.1.1 etch)
  • Revision ID: james.westby@ubuntu.com-20060920215942-o3erry1wowyk1ezz
Tags: 7.7.90+20060906-3
No changes; rebuild with downgraded openssl in order to permit
transition into testing.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/runtime/gc.scm
1
1
#| -*-Scheme-*-
2
2
 
3
 
$Id: gc.scm,v 14.20 2005/07/31 02:58:35 cph Exp $
 
3
$Id: gc.scm,v 14.23 2006/09/06 04:59:30 cph Exp $
4
4
 
5
5
Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
6
 
Copyright 1992,1993,2005 Massachusetts Institute of Technology
 
6
Copyright 1992,1993,2005,2006 Massachusetts Institute of Technology
7
7
 
8
8
This file is part of MIT/GNU Scheme.
9
9
 
30
30
(declare (usual-integrations))
31
31
 
32
32
(define (initialize-package!)
33
 
  (set! gc-boot-loading? true)
 
33
  (set! gc-boot-loading? #t)
34
34
  (set! hook/gc-flip default/gc-flip)
35
35
  (set! hook/purify default/purify)
36
36
  (set! hook/stack-overflow default/stack-overflow)
37
37
  (set! hook/hardware-trap default/hardware-trap)
38
38
  (set! default-safety-margin 4500)
39
 
  (set! pure-space-queue '())
40
 
  (set! constant-space-queue '())
 
39
  (set! pure-space-queue (list 'PURE-SPACE-QUEUE))
 
40
  (set! constant-space-queue (list 'CONSTANT-SPACE-QUEUE))
41
41
  (set! hook/gc-start default/gc-start)
42
42
  (set! hook/gc-finish default/gc-finish)
43
43
  (let ((fixed-objects (get-fixed-objects-vector)))
68
68
(define default-safety-margin)
69
69
 
70
70
(define (default/gc-flip safety-margin)
71
 
  (define (real-default)
72
 
    (gc-flip-internal safety-margin))
73
 
 
74
 
  (cond ((not (null? pure-space-queue))
75
 
         (let ((result (purify-internal pure-space-queue true safety-margin)))
76
 
           (cond ((not (pair? result))
77
 
                  ;; Wrong phase -- wait until next time.
78
 
                  (real-default))
79
 
                 ((not (car result))
80
 
                  (set! pure-space-queue (cdr pure-space-queue))
81
 
                  (queued-purification-failure)
82
 
                  (cdr result))
83
 
                 (else
84
 
                  (set! pure-space-queue '())
85
 
                  (cdr result)))))
86
 
        ((not (null? constant-space-queue))
87
 
         (let ((result
88
 
                (purify-internal constant-space-queue false safety-margin)))
89
 
           (cond ((not (pair? result))
90
 
                  ;; Wrong phase -- wait until next time.
91
 
                  (real-default))
92
 
                 ((not (car result))
93
 
                  (set! constant-space-queue (cdr constant-space-queue))
94
 
                  (queued-purification-failure)
95
 
                  (cdr result))
96
 
                 (else
97
 
                  (set! constant-space-queue '())
98
 
                  (cdr result)))))
99
 
        (else
100
 
         (real-default))))
 
71
  (let ((try-queue
 
72
         (lambda (queue pure?)
 
73
           (let ((items (cdr queue)))
 
74
             (and (pair? items)
 
75
                  (let ((result
 
76
                         (purify-internal (if (pair? (cdr items))
 
77
                                              items
 
78
                                              (car items))
 
79
                                          pure?
 
80
                                          safety-margin)))
 
81
                    (and (pair? result)
 
82
                         (begin
 
83
                           (if (car result)
 
84
                               (set-cdr! queue '())
 
85
                               (begin
 
86
                                 (set-cdr! queue (cdr items))
 
87
                                 (queued-purification-failure)))
 
88
                           (cdr result)))))))))
 
89
    (or (try-queue pure-space-queue #t)
 
90
        (try-queue constant-space-queue #f)
 
91
        (gc-flip-internal safety-margin))))
101
92
 
102
93
(define (queued-purification-failure)
103
 
  (warn "Unable to purify all queued items; dequeuing one"))
 
94
  (warn "Unable to purify all queued items; dequeuing one."))
104
95
 
105
96
(define (default/purify item pure-space? queue?)
106
97
  (if (not (if pure-space? (object-pure? item) (object-constant? item)))
107
 
      (cond ((not queue?)
108
 
             (let loop ()
109
 
               (let ((result
110
 
                      (purify-internal item
111
 
                                       pure-space?
112
 
                                       default-safety-margin)))
113
 
                 (cond ((not (pair? result))
114
 
                        ;; Wrong phase -- try again.
115
 
                        (gc-flip)
116
 
                        (loop))
117
 
                       ((not (car result))
118
 
                        (error "PURIFY: not enough room in constant space"
119
 
                               item))
120
 
                       (else
121
 
                        unspecific)))))
122
 
            (pure-space?
123
 
             (with-absolutely-no-interrupts
 
98
      (if queue?
 
99
          (let ((queue (if pure-space? pure-space-queue constant-space-queue)))
 
100
            (with-absolutely-no-interrupts
124
101
              (lambda ()
125
 
                (set! pure-space-queue (cons item pure-space-queue))
 
102
                (set-cdr! queue (cons item (cdr queue)))
126
103
                unspecific)))
127
 
            (else
128
 
             (with-absolutely-no-interrupts
129
 
              (lambda ()
130
 
                (set! constant-space-queue (cons item constant-space-queue))
131
 
                unspecific))))))
 
104
          (let loop ()
 
105
            (let ((result
 
106
                   (purify-internal item
 
107
                                    pure-space?
 
108
                                    default-safety-margin)))
 
109
              (cond ((not (pair? result))
 
110
                     ;; Wrong phase -- try again.
 
111
                     (gc-flip)
 
112
                     (loop))
 
113
                    ((not (car result))
 
114
                     (error "PURIFY: not enough room in constant space"
 
115
                            item))))))))
132
116
 
133
117
(define (default/stack-overflow)
134
118
  (abort->nearest "Aborting!: maximum recursion depth exceeded"))
159
143
      result)))
160
144
 
161
145
(define (default/gc-start)
162
 
  false)
 
146
  #f)
163
147
 
164
148
(define (default/gc-finish start-value space-remaining)
165
149
  start-value space-remaining
166
 
  false)
 
150
  #f)
167
151
 
168
152
(define (gc-finish start-value space-remaining)
169
153
  (if (< space-remaining 4096)
182
166
            (cmdl-message/active
183
167
             (lambda (port)
184
168
               port
185
 
               (with-gc-notification! true gc-clean)))))))
 
169
               (with-gc-notification! #t gc-clean)))))))
186
170
  ((ucode-primitive request-interrupts! 1) interrupt-bit/after-gc)
187
171
  (hook/gc-finish start-value space-remaining))
188
172
 
209
193
                       safety-margin)))))
210
194
 
211
195
(define (flush-purification-queue!)
212
 
  (if (or (not (null? pure-space-queue))
213
 
          (not (null? constant-space-queue)))
 
196
  (if (or (pair? (cdr pure-space-queue))
 
197
          (pair? (cdr constant-space-queue)))
214
198
      (begin
215
199
        (gc-flip)
216
200
        (flush-purification-queue!))))
219
203
  ;; Purify an item -- move it into pure space and clean everything by
220
204
  ;; doing a gc-flip.
221
205
  (hook/purify item
222
 
               (if (default-object? pure-space?) true pure-space?)
223
 
               (if (default-object? queue?) true queue?))
 
206
               (if (default-object? pure-space?) #t pure-space?)
 
207
               (if (default-object? queue?) #t queue?))
224
208
  item)
225
209
 
226
210
(define (constant-space/in-use)