1.0.3.11: Fix deportation gc safety bug

[sbcl.git] / src / code / purify.lisp

diff --git a/src/code/purify.lisp b/src/code/purify.lisp
index caf6991..d869342 100644 (file)
--- a/src/code/purify.lisp
+++ b/src/code/purify.lisp
@@ -21,17 +21,17 @@
    ((zerop n)
     (let ((old-ie (car *info-environment*)))
       (setq *info-environment*
-           (list* (make-info-environment :name "Working")
-                  (compact-info-environment (first *info-environment*)
-                                            :name name)
-                  (rest *info-environment*)))
-      (shrink-vector (sb!c::volatile-info-env-table old-ie) 0)))
+            (list* (make-info-environment :name "Working")
+                   (compact-info-environment (first *info-environment*)
+                                             :name name)
+                   (rest *info-environment*)))
+      (%shrink-vector (sb!c::volatile-info-env-table old-ie) 0)))
    (t
     (compact-environment-aux name (1- n))
     n)))
 
 (defun purify (&key root-structures (environment-name "Auxiliary"))
-  #!+sb-doc
+  ;; #!+sb-doc
   "This function optimizes garbage collection by moving all currently live
    objects into non-collected storage. ROOT-STRUCTURES is an optional list of
    objects which should be copied first to maximize locality.
@@ -45,19 +45,5 @@
    supplied, then environment compaction is inhibited."
 
   (when environment-name (compact-environment-aux environment-name 200))
-
-  (let ((*gc-notify-before*
-        (lambda (notify-stream bytes-in-use)
-          (declare (ignore bytes-in-use))
-          (write-string "[doing purification: " notify-stream)
-          (force-output notify-stream)))
-       (*internal-gc*
-        (lambda ()
-          (%purify (get-lisp-obj-address root-structures)
-                   (get-lisp-obj-address nil))))
-       (*gc-notify-after*
-        (lambda (notify-stream &rest ignore)
-          (declare (ignore ignore))
-          (write-line "done]" notify-stream))))
-    (gc))
-  nil)
+  (%purify (get-lisp-obj-address root-structures)
+           (get-lisp-obj-address nil)))