diff --git a/code/purify.lisp b/code/purify.lisp
index 24f322e4341809fed8de1be896fa66292003edbb..4fa9149ba339ee6aeaf7599da5e3c8e66cdc2889 100644
--- a/code/purify.lisp
+++ b/code/purify.lisp
@@ -31,9 +31,7 @@
   (setq *already-maybe-gcing* t)
   ;;
   ;; Move symbols to static space, constants to read-only space.
-  #| But don't until it works...
   (localify root-structures)
-  |#
   ;;
   ;; Move everything else to either static or read-only space, depending
   ;; on type.
@@ -111,11 +109,10 @@
 ;;;
 (defmacro inlinep (sym)
   `(or (info function source-transform ,sym)
-       (and (boundp 'c::*function-info*)
-	    (let ((info (gethash ,sym c::*function-info*)))
-	      (and info
-		   (or (c::function-info-templates info)
-		       (c::function-info-ir2-convert info)))))))
+       (let ((info (info function info ,sym)))
+	 (and info
+	      (or (c::function-info-templates info)
+		  (c::function-info-ir2-convert info))))))
 
 
 ;;; Next-Symbol, Next-Cons  --  Internal
@@ -272,29 +269,49 @@
   (unless (purep fun)
     (let ((def (ecase (%primitive get-vector-subtype fun)
 		 (#.%function-entry-subtype
+		  (transport-function-object fun)
 		  (%primitive header-ref fun %function-entry-constants-slot))
 		 (#.%function-closure-subtype
-		  (%primitive header-ref
-			      (%primitive header-ref fun %function-name-slot)
-			      %function-entry-constants-slot))
+		  (let ((entry (%primitive header-ref fun
+					   %function-name-slot)))
+		    (transport-function-object entry)
+		    (%primitive header-ref entry
+				%function-entry-constants-slot)))
 		 (#.%function-funcallable-instance-subtype
 		  nil))))
-      (when def
-	(do ((i %function-constants-constants-offset (1+ i))
-	     (length (%primitive header-length def)))
-	    ((= i length))
-	  (let ((const (%primitive header-ref def i)))
-	    (typecase const
-	      (symbol
-	       (unless (zerop (logand worthwhile-bit (symbol-bits const)))
-		 (transport-symbol const)))
-	      (cons
-	       (transport-cons const))
-	      (compiled-function
-	       (transport-function const))
-	      (simple-vector
-	       (transport-g-vector const)))))))))
-
+      (when (and def (not (purep def)))
+	(let ((length (%primitive header-length def)))
+	  (transport-function-object def)
+	  (do ((i %function-constants-constants-offset (1+ i)))
+	      ((= i length))
+	    (let ((const (%primitive header-ref def i)))
+	      (typecase const
+		(symbol
+		 (unless (zerop (logand worthwhile-bit (symbol-bits const)))
+		   (transport-symbol const)))
+		(cons
+		 (transport-cons const))
+		(compiled-function
+		 (transport-function const))
+		(simple-vector
+		 (transport-g-vector const))))))))))
+
+
+;;; TRANSPORT-FUNCTION-OBJECT  --  Internal
+;;;
+;;;    Copy a function object into read-only space.  This only moves the
+;;; function (entry or constants) object itself, and lets GC scavenge.
+;;;
+(defun transport-function-entry (fun)
+  (%primitive set-allocation-space %read-only-space)
+  (let* ((len (%primitive header-length fun))
+	 (res (%primitive alloc-function len)))
+    (%primitive set-vector-subtype res (%primitive get-vector-subtype fun))
+    (dotimes (i len)
+      (%primitive header-set res i (%primitive header-ref fun i)))
+    (poke fun (%primitive make-immediate-type res %gc-forward-type)))
+  (%primitive set-allocation-space %static-space))
+ 
 
 ;;; Transport-Cons  --  Internal
 ;;;
@@ -307,19 +324,19 @@
     (let* ((free-ptr-loc (free-pointer-location %list-type %read-only-space))
 	   (clean-ptr (peek free-ptr-loc)))
       (loop
-       (loop
-	(let ((new (cons (car cons) (cdr cons))))
-	  (poke cons (%primitive make-immediate-type new %gc-forward-type))
-	  (setq cons (cdr cons))
-	  (when (or (atom cons) (purep cons)) (return nil))))
-       (let ((free-ptr (peek free-ptr-loc)))
-	 (loop
-	  (when (eq clean-ptr free-ptr)
-	    (%primitive set-allocation-space %static-space)
-	    (return-from transport-cons nil))
-	  (setq cons (car clean-ptr))
-	  (setq clean-ptr (next-cons clean-ptr))
-	  (unless (or (atom cons) (purep cons)) (return nil))))))))
+	(loop
+	  (let ((new (cons (car cons) (cdr cons))))
+	    (poke cons (%primitive make-immediate-type new %gc-forward-type))
+	    (setq cons (cdr cons))
+	    (when (or (atom cons) (purep cons)) (return nil))))
+	(let ((free-ptr (peek free-ptr-loc)))
+	  (loop
+	    (when (eq clean-ptr free-ptr)
+	      (%primitive set-allocation-space %static-space)
+	      (return-from transport-cons nil))
+	    (setq cons (car clean-ptr))
+	    (setq clean-ptr (next-cons clean-ptr))
+	    (unless (or (atom cons) (purep cons)) (return nil))))))))
 
 ;;; Transport-G-Vector  --  Internal
 ;;;
@@ -394,33 +411,14 @@
   ;; Do anything else that wants to be done...
   (do-allocated-symbols (sym %dynamic-space)
     ;;
-    ;; Move some selected property values into read-only space.
-    (macrolet ((movec (prop)
-		 `(let ((val (get sym ',prop)))
-		    (when val (transport-cons val))))
-	       (movev (prop)
-		 `(let ((val (get sym ',prop)))
-		    (when val (transport-g-vector val t)))))
-      (movec inline-expansion)
-      (movec clc::clc-transforms)
-      (movec clc::clc-args)
-      (movev %structure-definition)
-      (movev alien-variable)
-      (movev alien-stack-info)
-      (movev alien-operator-info)
-      (movev enumeration-info))
-    ;;
     ;; Move some types of variable value...
     (when (boundp sym)
       (let ((val (symbol-value sym)))
 	(cond ((purep val))
-	      ((get sym '%constant)
+	      ((eq (info variable kind sym) :constant)
 	       (typecase val
 		 (cons (transport-cons val))
-		 (simple-vector (transport-g-vector val t))))
-	      ((and (structurep val)
-		    (memq (svref val 0) '(clc::%instruction alien-value)))
-	       (transport-g-vector val t)))))
+		 (simple-vector (transport-g-vector val t)))))))
     ;;
     ;; Move any interned symbol that's left...
     (unless (or (purep sym) (not (symbol-package sym)))
@@ -448,12 +446,6 @@
 ;;; referenced and doing a GC.  We also blow away random debug info.
 
 
-(defparameter garbage-properties
-  '(%constant globally-special %constant %fun-documentation %var-documentation
-	      %struct-documentation %type-documentation
-	      %setf-documentation %documentation
-	      setf-method-expander setf-inverse))
-
 ;;; Save-Stand-Alone-Lisp  --  Public
 ;;;
 (defun save-stand-alone-lisp (file root-function)
@@ -467,7 +459,6 @@
     (force-output)
     ;;
     ;; Mark all external symbols so that we can find them later...
-    ;; We could do this with a property, but this is more fun.
     (dolist (p all-packages)
       (do-external-symbols (s p)
 	(setf (symbol-bits s) 1)))
@@ -476,6 +467,7 @@
     (dolist (p all-packages)
       (make-package-hashtable 10 (package-internal-symbols p))
       (make-package-hashtable 10 (package-external-symbols p)))
+    #|
     ;;
     ;; Nuke random garbage on all symbols...
     (do-allocated-symbols (s %dynamic-space)
@@ -486,24 +478,24 @@
 	  (cond ((compiled-function-p fun)
 		 (%primitive header-set fun %function-arg-names-slot ()))
 		((and (consp fun) (compiled-function-p (cdr fun)))
-		 (%primitive header-set (cdr fun) %function-arg-names-slot ())))))
+		 (%primitive header-set (cdr fun) %function-arg-names-slot
+			     ()))))
+    
       ;;
       ;; Nuke unnecessary properties...
       (when (symbol-plist s)
 	(dolist (p garbage-properties)
 	  (when (get s p)
-	    (remprop s p)))))
+	    (remprop s p))))))
+    |#
+      
     (write-string "]
 [GC'ing it away")
     (force-output)
     ;;
     ;; GC it away....
     (gc nil)
-    (sleep 30)
-    (write-string "]
-[Snoozing for a minute to let dirty pages get written")
-    (force-output)
-    (sleep 60)
+    (write-string "]")
     ;;
     ;; Rebuild packages...
     (write-string "]
@@ -529,10 +521,6 @@
 	(remprop s 'purify-symbol-bits)))
     (write-line "]")
     (purify :root-structures (list root-function))
-    (write-string "[Snoozing for two minutes to let dirty pages get written")
-    (force-output)
-    (sleep 120)
-    (write-line "]")
     (if (save file)
 	(quit)
 	(funcall root-function))))