/[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.11.2.1 by wlott, Fri Jan 24 04:34:19 1992 UTC revision 1.22 by rtoy, Tue Apr 20 17:57:45 2010 UTC
# Line 3  Line 3 
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
5  ;;; Carnegie Mellon University, and has been placed in the public domain.  ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact  
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.  
6  ;;;  ;;;
7  (ext:file-comment  (ext:file-comment
8    "$Header$")    "$Header$")
# Line 16  Line 14 
14  ;;;  ;;;
15  ;;; Rewritten in C by William Lott.  ;;; Rewritten in C by William Lott.
16  ;;;  ;;;
17  (in-package 'lisp)  (in-package "LISP")
18    (intl:textdomain "cmucl")
19    
20    (export 'ext::purify "EXT")
21    
22  (alien:def-alien-routine ("purify" %purify) c-call:void  (alien:def-alien-routine ("purify" %purify) c-call:void
23    (static-roots c-call:unsigned-long)    (static-roots c-call:unsigned-long)
24    (read-only-roots c-call:unsigned-long))    (read-only-roots c-call:unsigned-long))
25    
 (defun purify (&key root-structures constants)  
   (write-string "[Doing purification: ")  
   (force-output)  
   (without-gcing  
    (clear-auto-gc-trigger)  
    (%purify (get-lisp-obj-address root-structures)  
             (get-lisp-obj-address constants))  
    (when *gc-trigger*  
      (setf *gc-trigger* *bytes-consed-between-gcs*)  
      (set-auto-gc-trigger *gc-trigger*)))  
   (write-line "Done.]")  
   (force-output)  
   nil)  
26    
27    ;;; COMPACT-ENVIRONMENT-AUX  --  Internal
28    ;;;
29    ;;;    Compact the info environment.  Written with gratuitous recursion to
30    ;;; make sure that our (and compact-info-environment's) local variables are
31    ;;; above the stack top when purify runs.
32    ;;;
33    (defun compact-environment-aux (name n)
34      (cond
35       ((zerop n)
36        (let ((old-ie (car *info-environment*)))
37          (setq *info-environment*
38                (list* (make-info-environment :name "Working")
39                       (compact-info-environment (first *info-environment*)
40                                                 :name name)
41                       (rest *info-environment*)))
42          (shrink-vector (c::volatile-info-env-table old-ie) 0)))
43       (t
44        (compact-environment-aux name (1- n))
45        n)))
46    
47    
48    (defun purify (&key root-structures (environment-name "Auxiliary"))
49      "This function optimizes garbage collection by moving all currently live
50       objects into non-collected storage.  ROOT-STRUCTURES is an optional list of
51       objects which should be copied first to maximize locality.
52    
53       DEFSTRUCT structures defined with the (:PURE T) option are moved into
54       read-only storage, further reducing GC cost.  List and vector slots of pure
55       structures are also moved into read-only storage.
56    
57       ENVIRONMENT-NAME is gratuitous documentation for compacted version of the
58       current global environment (as seen in C::*INFO-ENVIRONMENT*.)  If NIL is
59       supplied, then environment compaction is inhibited."
60    
61      (when environment-name (compact-environment-aux environment-name 200))
62    
63      (let ((*gc-notify-before*
64             #'(lambda (bytes-in-use)
65                 (declare (ignore bytes-in-use))
66                 (write-string (intl:gettext "[Doing purification: "))
67                 (force-output)))
68            (*internal-gc*
69             #'(lambda ()
70                 (%purify (get-lisp-obj-address root-structures)
71                          (get-lisp-obj-address nil))))
72            (*gc-notify-after*
73             #'(lambda (&rest ignore)
74                 (declare (ignore ignore))
75                 (write-line (intl:gettext "Done.]")))))
76        #-gencgc (gc t)
77        #+gencgc (gc :verbose t))
78      nil)

Legend:
Removed from v.1.11.2.1  
changed lines
  Added in v.1.22

  ViewVC Help
Powered by ViewVC 1.1.5