/[cmucl]/src/code/purify.lisp
ViewVC logotype

Diff of /src/code/purify.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12 by wlott, Fri Feb 14 23:45:24 1992 UTC revision 1.12.1.1 by wlott, Tue Mar 3 08:20:46 1992 UTC
# Line 16  Line 16 
16  ;;;  ;;;
17  ;;; Rewritten in C by William Lott.  ;;; Rewritten in C by William Lott.
18  ;;;  ;;;
19    ;;; Reduced to almost nothing with the advent of the generational garbage
20    ;;; collector by William Lott.
21    ;;;
22  (in-package 'lisp)  (in-package 'lisp)
23    
 (alien:def-alien-routine ("purify" %purify) c-call:void  
   (static-roots c-call:unsigned-long)  
   (read-only-roots c-call:unsigned-long))  
   
24  (defun purify (&key root-structures constants)  (defun purify (&key root-structures constants)
25    (write-string "[Doing purification: ")    (declare (ignore root-structures constants))
26    (force-output)    (let* ((generations (num-generations))
27    (without-gcing           (thresholds (make-array generations)))
28     (clear-auto-gc-trigger)      (do ((gen 1 (1+ gen)))
29     (%purify (get-lisp-obj-address root-structures)          ((= gen generations))
30              (get-lisp-obj-address constants))        (setf (aref thresholds gen)
31     (when *gc-trigger*              (cons (bytes-allocated-between-flips gen)
32       (setf *gc-trigger* *bytes-consed-between-gcs*)                    (tenure-threshold gen))))
33       (set-auto-gc-trigger *gc-trigger*)))      (set-num-generations 1)
34    (write-line "Done.]")      (set-num-generations generations)
35    (force-output)      (do ((gen 1 (1+ gen)))
36            ((= gen generations))
37          (let ((noise (aref thresholds gen)))
38            (set-bytes-allocated-between-flips gen (car noise))
39            (set-tenure-threshold gen (cdr noise)))))
40    nil)    nil)
   

Legend:
Removed from v.1.12  
changed lines
  Added in v.1.12.1.1

  ViewVC Help
Powered by ViewVC 1.1.5