1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!KERNEL")
12 (sb!alien
:define-alien-routine
("purify" %purify
) sb
!alien
:void
13 (static-roots sb
!alien
:unsigned-long
)
14 (read-only-roots sb
!alien
:unsigned-long
))
16 ;;; Compact the info environment. This is written with gratuitous
17 ;;; recursion to make sure that our (and compact-info-environment's)
18 ;;; local variables are above the stack top when purify runs.
19 (defun compact-environment-aux (name n
)
22 (let ((old-ie (car *info-environment
*)))
23 (setq *info-environment
*
24 (list* (make-info-environment :name
"Working")
25 (compact-info-environment (first *info-environment
*)
27 (rest *info-environment
*)))
28 (shrink-vector (sb!c
::volatile-info-env-table old-ie
) 0)))
30 (compact-environment-aux name
(1- n
))
33 (defun purify (&key root-structures
(environment-name "Auxiliary"))
35 "This function optimizes garbage collection by moving all currently live
36 objects into non-collected storage. ROOT-STRUCTURES is an optional list of
37 objects which should be copied first to maximize locality.
39 DEFSTRUCT structures defined with the (:PURE T) option are moved into
40 read-only storage, further reducing GC cost. List and vector slots of pure
41 structures are also moved into read-only storage.
43 ENVIRONMENT-NAME is gratuitous documentation for compacted version of the
44 current global environment (as seen in SB!C::*INFO-ENVIRONMENT*.) If NIL is
45 supplied, then environment compaction is inhibited."
47 (when environment-name
(compact-environment-aux environment-name
200))
49 (let ((*gc-notify-before
*
50 (lambda (notify-stream bytes-in-use
)
51 (declare (ignore bytes-in-use
))
52 (write-string "[doing purification: " notify-stream
)
53 (force-output notify-stream
)))
55 (lambda (ignored-generation-arg)
56 (%purify
(get-lisp-obj-address root-structures
)
57 (get-lisp-obj-address nil
))))
59 (lambda (notify-stream &rest ignore
)
60 (declare (ignore ignore
))
61 (write-line "done]" notify-stream
))))