/[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.1 by ram, Tue Feb 6 17:26:28 1990 UTC revision 1.2 by ram, Fri Feb 9 16:44:35 1990 UTC
# Line 31  Line 31 
31    (setq *already-maybe-gcing* t)    (setq *already-maybe-gcing* t)
32    ;;    ;;
33    ;; Move symbols to static space, constants to read-only space.    ;; Move symbols to static space, constants to read-only space.
   #| But don't until it works...  
34    (localify root-structures)    (localify root-structures)
   |#  
35    ;;    ;;
36    ;; Move everything else to either static or read-only space, depending    ;; Move everything else to either static or read-only space, depending
37    ;; on type.    ;; on type.
# Line 111  Line 109 
109  ;;;  ;;;
110  (defmacro inlinep (sym)  (defmacro inlinep (sym)
111    `(or (info function source-transform ,sym)    `(or (info function source-transform ,sym)
112         (and (boundp 'c::*function-info*)         (let ((info (info function info ,sym)))
113              (let ((info (gethash ,sym c::*function-info*)))           (and info
114                (and info                (or (c::function-info-templates info)
115                     (or (c::function-info-templates info)                    (c::function-info-ir2-convert info))))))
                        (c::function-info-ir2-convert info)))))))  
116    
117    
118  ;;; Next-Symbol, Next-Cons  --  Internal  ;;; Next-Symbol, Next-Cons  --  Internal
# Line 272  Line 269 
269    (unless (purep fun)    (unless (purep fun)
270      (let ((def (ecase (%primitive get-vector-subtype fun)      (let ((def (ecase (%primitive get-vector-subtype fun)
271                   (#.%function-entry-subtype                   (#.%function-entry-subtype
272                      (transport-function-object fun)
273                    (%primitive header-ref fun %function-entry-constants-slot))                    (%primitive header-ref fun %function-entry-constants-slot))
274                   (#.%function-closure-subtype                   (#.%function-closure-subtype
275                    (%primitive header-ref                    (let ((entry (%primitive header-ref fun
276                                (%primitive header-ref fun %function-name-slot)                                             %function-name-slot)))
277                                %function-entry-constants-slot))                      (transport-function-object entry)
278                        (%primitive header-ref entry
279                                    %function-entry-constants-slot)))
280                   (#.%function-funcallable-instance-subtype                   (#.%function-funcallable-instance-subtype
281                    nil))))                    nil))))
282        (when def        (when (and def (not (purep def)))
283          (do ((i %function-constants-constants-offset (1+ i))          (let ((length (%primitive header-length def)))
284               (length (%primitive header-length def)))            (transport-function-object def)
285              ((= i length))            (do ((i %function-constants-constants-offset (1+ i)))
286            (let ((const (%primitive header-ref def i)))                ((= i length))
287              (typecase const              (let ((const (%primitive header-ref def i)))
288                (symbol                (typecase const
289                 (unless (zerop (logand worthwhile-bit (symbol-bits const)))                  (symbol
290                   (transport-symbol const)))                   (unless (zerop (logand worthwhile-bit (symbol-bits const)))
291                (cons                     (transport-symbol const)))
292                 (transport-cons const))                  (cons
293                (compiled-function                   (transport-cons const))
294                 (transport-function const))                  (compiled-function
295                (simple-vector                   (transport-function const))
296                 (transport-g-vector const)))))))))                  (simple-vector
297                     (transport-g-vector const))))))))))
298    
299    
300    ;;; TRANSPORT-FUNCTION-OBJECT  --  Internal
301    ;;;
302    ;;;    Copy a function object into read-only space.  This only moves the
303    ;;; function (entry or constants) object itself, and lets GC scavenge.
304    ;;;
305    (defun transport-function-entry (fun)
306      (%primitive set-allocation-space %read-only-space)
307      (let* ((len (%primitive header-length fun))
308             (res (%primitive alloc-function len)))
309        (%primitive set-vector-subtype res (%primitive get-vector-subtype fun))
310        (dotimes (i len)
311          (%primitive header-set res i (%primitive header-ref fun i)))
312        (poke fun (%primitive make-immediate-type res %gc-forward-type)))
313      (%primitive set-allocation-space %static-space))
314    
315    
316  ;;; Transport-Cons  --  Internal  ;;; Transport-Cons  --  Internal
317  ;;;  ;;;
# Line 307  Line 324 
324      (let* ((free-ptr-loc (free-pointer-location %list-type %read-only-space))      (let* ((free-ptr-loc (free-pointer-location %list-type %read-only-space))
325             (clean-ptr (peek free-ptr-loc)))             (clean-ptr (peek free-ptr-loc)))
326        (loop        (loop
327         (loop          (loop
328          (let ((new (cons (car cons) (cdr cons))))            (let ((new (cons (car cons) (cdr cons))))
329            (poke cons (%primitive make-immediate-type new %gc-forward-type))              (poke cons (%primitive make-immediate-type new %gc-forward-type))
330            (setq cons (cdr cons))              (setq cons (cdr cons))
331            (when (or (atom cons) (purep cons)) (return nil))))              (when (or (atom cons) (purep cons)) (return nil))))
332         (let ((free-ptr (peek free-ptr-loc)))          (let ((free-ptr (peek free-ptr-loc)))
333           (loop            (loop
334            (when (eq clean-ptr free-ptr)              (when (eq clean-ptr free-ptr)
335              (%primitive set-allocation-space %static-space)                (%primitive set-allocation-space %static-space)
336              (return-from transport-cons nil))                (return-from transport-cons nil))
337            (setq cons (car clean-ptr))              (setq cons (car clean-ptr))
338            (setq clean-ptr (next-cons clean-ptr))              (setq clean-ptr (next-cons clean-ptr))
339            (unless (or (atom cons) (purep cons)) (return nil))))))))              (unless (or (atom cons) (purep cons)) (return nil))))))))
340    
341  ;;; Transport-G-Vector  --  Internal  ;;; Transport-G-Vector  --  Internal
342  ;;;  ;;;
# Line 394  Line 411 
411    ;; Do anything else that wants to be done...    ;; Do anything else that wants to be done...
412    (do-allocated-symbols (sym %dynamic-space)    (do-allocated-symbols (sym %dynamic-space)
413      ;;      ;;
     ;; 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))  
     ;;  
414      ;; Move some types of variable value...      ;; Move some types of variable value...
415      (when (boundp sym)      (when (boundp sym)
416        (let ((val (symbol-value sym)))        (let ((val (symbol-value sym)))
417          (cond ((purep val))          (cond ((purep val))
418                ((get sym '%constant)                ((eq (info variable kind sym) :constant)
419                 (typecase val                 (typecase val
420                   (cons (transport-cons val))                   (cons (transport-cons val))
421                   (simple-vector (transport-g-vector val t))))                   (simple-vector (transport-g-vector val t)))))))
               ((and (structurep val)  
                     (memq (svref val 0) '(clc::%instruction alien-value)))  
                (transport-g-vector val t)))))  
422      ;;      ;;
423      ;; Move any interned symbol that's left...      ;; Move any interned symbol that's left...
424      (unless (or (purep sym) (not (symbol-package sym)))      (unless (or (purep sym) (not (symbol-package sym)))
# Line 448  Line 446 
446  ;;; referenced and doing a GC.  We also blow away random debug info.  ;;; referenced and doing a GC.  We also blow away random debug info.
447    
448    
 (defparameter garbage-properties  
   '(%constant globally-special %constant %fun-documentation %var-documentation  
               %struct-documentation %type-documentation  
               %setf-documentation %documentation  
               setf-method-expander setf-inverse))  
   
449  ;;; Save-Stand-Alone-Lisp  --  Public  ;;; Save-Stand-Alone-Lisp  --  Public
450  ;;;  ;;;
451  (defun save-stand-alone-lisp (file root-function)  (defun save-stand-alone-lisp (file root-function)
# Line 467  Line 459 
459      (force-output)      (force-output)
460      ;;      ;;
461      ;; Mark all external symbols so that we can find them later...      ;; Mark all external symbols so that we can find them later...
     ;; We could do this with a property, but this is more fun.  
462      (dolist (p all-packages)      (dolist (p all-packages)
463        (do-external-symbols (s p)        (do-external-symbols (s p)
464          (setf (symbol-bits s) 1)))          (setf (symbol-bits s) 1)))
# Line 476  Line 467 
467      (dolist (p all-packages)      (dolist (p all-packages)
468        (make-package-hashtable 10 (package-internal-symbols p))        (make-package-hashtable 10 (package-internal-symbols p))
469        (make-package-hashtable 10 (package-external-symbols p)))        (make-package-hashtable 10 (package-external-symbols p)))
470        #|
471      ;;      ;;
472      ;; Nuke random garbage on all symbols...      ;; Nuke random garbage on all symbols...
473      (do-allocated-symbols (s %dynamic-space)      (do-allocated-symbols (s %dynamic-space)
# Line 486  Line 478 
478            (cond ((compiled-function-p fun)            (cond ((compiled-function-p fun)
479                   (%primitive header-set fun %function-arg-names-slot ()))                   (%primitive header-set fun %function-arg-names-slot ()))
480                  ((and (consp fun) (compiled-function-p (cdr fun)))                  ((and (consp fun) (compiled-function-p (cdr fun)))
481                   (%primitive header-set (cdr fun) %function-arg-names-slot ())))))                   (%primitive header-set (cdr fun) %function-arg-names-slot
482                                 ()))))
483    
484        ;;        ;;
485        ;; Nuke unnecessary properties...        ;; Nuke unnecessary properties...
486        (when (symbol-plist s)        (when (symbol-plist s)
487          (dolist (p garbage-properties)          (dolist (p garbage-properties)
488            (when (get s p)            (when (get s p)
489              (remprop s p)))))              (remprop s p))))))
490        |#
491    
492      (write-string "]      (write-string "]
493  [GC'ing it away")  [GC'ing it away")
494      (force-output)      (force-output)
495      ;;      ;;
496      ;; GC it away....      ;; GC it away....
497      (gc nil)      (gc nil)
498      (sleep 30)      (write-string "]")
     (write-string "]  
 [Snoozing for a minute to let dirty pages get written")  
     (force-output)  
     (sleep 60)  
499      ;;      ;;
500      ;; Rebuild packages...      ;; Rebuild packages...
501      (write-string "]      (write-string "]
# Line 529  Line 521 
521          (remprop s 'purify-symbol-bits)))          (remprop s 'purify-symbol-bits)))
522      (write-line "]")      (write-line "]")
523      (purify :root-structures (list root-function))      (purify :root-structures (list root-function))
     (write-string "[Snoozing for two minutes to let dirty pages get written")  
     (force-output)  
     (sleep 120)  
     (write-line "]")  
524      (if (save file)      (if (save file)
525          (quit)          (quit)
526          (funcall root-function))))          (funcall root-function))))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5