/[cmucl]/src/code/purify.lisp
ViewVC logotype

Contents of /src/code/purify.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6.1.2 - (hide annotations) (vendor branch)
Mon Jul 2 04:36:22 1990 UTC (23 years, 9 months ago) by wlott
Changes since 1.6.1.1: +6 -3 lines
Added the root structures argument to purify.
1 ram 1.1 ;;; -*- Log: code.log; Package: Lisp -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice Lisp project at
5     ;;; Carnegie-Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of Spice Lisp, please contact
7     ;;; Scott Fahlman (FAHLMAN@CMUC).
8     ;;; **********************************************************************
9     ;;;
10     ;;; Storage purifier for Spice Lisp.
11     ;;; Written by Rob MacLachlan and Skef Wholey.
12     ;;;
13     ;;; The function Purify, defined herein, puts as much of the Lisp system as
14     ;;; possible into Read-Only and Static spaces so that subsequent garbage
15     ;;; collections are quicker. This is done by frobbing the free-pointers for
16     ;;; spaces so that new objects are put in static or read-only space as
17     ;;; appropiate, then doing a GC.
18     ;;;
19     ;;; We also transport all of the dynamic symbols in Lisp code so we
20     ;;; can do clever things that improve locality in the resulting Lisp.
21     ;;; Some constant conses and g-vectors are also transported in macrocode
22     ;;; so that we can put them in read-only space.
23     ;;;
24     (in-package 'lisp)
25    
26 wlott 1.6.1.1
27 wlott 1.6.1.2 (def-c-routine ("purify" %purify) (int)
28     (roots unsigned-long))
29 wlott 1.6.1.1
30 ram 1.1 (defun purify (&key root-structures)
31 wlott 1.6.1.1 (write-string "[Doing purification: ")
32 wlott 1.6.1.2 (force-output)
33     (without-gcing
34     (%purify (di::get-lisp-obj-address root-structures)))
35 wlott 1.6.1.1 (write-line "Done.]")
36 wlott 1.6.1.2 (force-output)
37 wlott 1.6.1.1 nil)
38    
39    
40     #|
41    
42     (defun purify (&key root-structures)
43 ram 1.1 (declare (special lisp-environment-list))
44     (setq lisp-environment-list NIL)
45     (write-string "[Doing purification: ")
46     (force-output)
47     (setq *already-maybe-gcing* t)
48     ;;
49 ram 1.5 ;; Find GC stack fixups before we go around trashing vector headers.
50 ram 1.1 (let ((fixups (gc-grovel-stack)))
51 ram 1.5 ;;
52     ;; Move symbols to static space, constants to read-only space.
53     (localify root-structures)
54     ;;
55     ;; Move everything else to either static or read-only space, depending
56     ;; on type.
57 ram 1.1 (%primitive clear-registers)
58     (%primitive purify)
59     (gc-fixup-stack fixups))
60    
61     (setq *already-maybe-gcing* nil)
62     (setq *need-to-collect-garbage* nil)
63     (write-line "done]")
64     nil)
65    
66     ;;;; Localify
67    
68 ram 1.6 (defconstant marked-bit #b001)
69     (defconstant worthwhile-bit #b010)
70     (defconstant referenced-bit #b100)
71    
72 ram 1.1 (eval-when (compile eval)
73     ;;; Peek, Poke -- Internal
74     ;;;
75     ;;; Read or write the cell at a location without doing any type-checking or
76     ;;; anything silly like that.
77     ;;;
78     (defmacro peek (x)
79     `(%primitive read-control-stack ,x))
80     (defmacro poke (x val)
81     `(%primitive write-control-stack ,x ,val))
82    
83     ;;; Symbol-Bits -- Internal
84     ;;;
85     ;;; There is a whole 32 bits at the end of every symbol, which until
86     ;;; now, was unused. We will use the low 16 to annotate some stuff about
87     ;;; how symbols are referenced.
88     ;;;
89     (defmacro symbol-bits (sym)
90     `(get ,sym 'purify-symbol-bits 0))
91    
92     (defsetf symbol-bits (sym) (val)
93     `(let ((space (%primitive get-allocation-space)))
94     (%primitive set-allocation-space %dynamic-space)
95     (prog1 (setf (get ,sym 'purify-symbol-bits) ,val)
96     (%primitive set-allocation-space space))))
97    
98     ;;; Do-Allocated-Symbols -- Internal
99     ;;;
100     ;;; Iterate over all the symbols allocated in some space.
101     ;;;
102     (defmacro do-allocated-symbols ((symbol space) &body forms)
103     `(let* ((old-alloc-space (%primitive get-allocation-space)))
104     (%primitive set-allocation-space %dynamic-space)
105     (let* ((index (+ (ash %symbol-type %alloc-ref-type-shift)
106     (ash ,space %alloc-ref-space-shift)))
107     (alloc-table (int-sap %fixnum-alloctable-address))
108     (end (+ (logior (%primitive 16bit-system-ref alloc-table (1+ index))
109     (ash (logand %type-space-mask
110     (%primitive 16bit-system-ref alloc-table index))
111     16))
112     (ash ,space %space-shift))))
113     (declare (fixnum end))
114     (do ((base (ash ,space %space-shift) (+ base %symbol-length)))
115     ((= base end))
116     (declare (fixnum base))
117     (let ((,symbol (%primitive make-immediate-type base %symbol-type)))
118     (%primitive set-allocation-space old-alloc-space)
119     ,@forms
120     (%primitive set-allocation-space %dynamic-space))))
121     (%primitive set-allocation-space old-alloc-space)))
122    
123     ;;; Inlinep -- Internal
124     ;;;
125     ;;; Return true if symbol appears to be the name of a function likely
126     ;;; to be coded inline.
127     ;;;
128     (defmacro inlinep (sym)
129 ram 1.5 #|Accesses global vars, so can't work....
130 ram 1.1 `(or (info function source-transform ,sym)
131 ram 1.2 (let ((info (info function info ,sym)))
132     (and info
133     (or (c::function-info-templates info)
134 ram 1.5 (c::function-info-ir2-convert info)))))
135     |#
136     nil)
137 ram 1.1
138    
139     ;;; Next-Symbol, Next-Cons -- Internal
140     ;;;
141     ;;; Return the object allocated after the supplied one.
142     ;;;
143     (defmacro next-symbol (sym)
144     `(%primitive make-immediate-type (+ (%primitive make-fixnum ,sym) %symbol-length)
145     %symbol-type))
146     (defmacro next-cons (cons)
147     `(%primitive make-immediate-type (+ (%primitive make-fixnum ,cons) %cons-length)
148     %list-type))
149    
150     ;;; Purep -- Internal
151     ;;;
152     ;;; True if Obj is either not dynamic or has already been transported.
153     ;;;
154     (defmacro purep (obj)
155     `(or (>= (%primitive get-space ,obj) %static-space)
156     (let ((type (%primitive get-type ,obj)))
157     (declare (fixnum type))
158     (or (< type %first-pointer-type)
159     (> type %last-pointer-type)
160     (= (%primitive get-type (peek ,obj)) %gc-forward-type)))))
161    
162     ;;; Free-Pointer-Location -- Internal
163     ;;;
164     ;;; Return the SAP which points to the location of the free-pointer
165     ;;; for the specifed type and space in the alloc table.
166     ;;;
167     (defmacro free-pointer-location (type space)
168     `(+ %fixnum-alloctable-address
169     (%primitive lsh ,type (1+ %alloc-ref-type-shift))
170     (%primitive lsh ,space (1+ %alloc-ref-space-shift))))
171    
172     ;;; Transport-Symbol -- Internal
173     ;;;
174     ;;; If Sym is impure, copy it into static space and put a GC forward in the
175     ;;; old symbol. Return True only if we actually did something.
176     ;;;
177     (defmacro transport-symbol (sym)
178     `(unless (purep ,sym)
179     (let ((new-sym (%primitive alloc-symbol (symbol-name ,sym))))
180     (when (boundp ,sym)
181     (setf (symbol-value new-sym) (symbol-value ,sym)))
182     (when (fboundp ,sym)
183     (setf (symbol-function new-sym) (symbol-function ,sym)))
184     (setf (symbol-plist new-sym) (symbol-plist ,sym))
185     (%primitive set-package new-sym (symbol-package ,sym))
186     (poke ,sym (%primitive make-immediate-type new-sym %gc-forward-type))
187     t)))
188    
189     ;;; Copy-G-Vector -- Internal
190     ;;;
191     ;;; Copy a G-Vector into the current allocation space, and forward
192     ;;; the old object. Return the new object. If an EQ hashtable,
193     ;;; change the subtype, otherwise preserve it.
194     ;;;
195     (defmacro copy-g-vector (object)
196     `(let* ((len (length ,object))
197     (new (%primitive alloc-g-vector len nil))
198     (st (%primitive get-vector-subtype ,object)))
199     (dotimes (i len)
200     (setf (svref new i) (svref ,object i)))
201     (%primitive set-vector-subtype new
202     (case st
203     ((2 3) 4)
204     (t st)))
205     (poke ,object (%primitive make-immediate-type new %gc-forward-type))
206     new))
207    
208    
209     ;;; Scavenge-Symbols -- Internal
210     ;;;
211     ;;; Scan through static symbol space doing a Transport-Function on
212     ;;; the definition of every Fbound symbol between the free pointer
213     ;;; and our clean pointer. The free pointer can move during the process
214     ;;; due to symbols being transported.
215     ;;;
216     (defmacro scavenge-symbols ()
217     `(do ((free-ptr (peek free-ptr-loc) (peek free-ptr-loc)))
218     ((eq clean-ptr free-ptr))
219     (when (fboundp clean-ptr)
220     (transport-function (symbol-function clean-ptr)))
221     (setq clean-ptr (next-symbol clean-ptr))))
222     ); eval-when (compile eval)
223    
224     ;;; Mark-Function -- Internal
225     ;;;
226     ;;; Set the referenced bit in any symbol constants, and call
227     ;;; Mark-If-Worthwhile on any which are not marked.
228     ;;;
229     (defun mark-function (fun)
230     (let ((len (%primitive header-length fun)))
231 ram 1.3 (do ((i %function-constants-constants-offset (1+ i)))
232 ram 1.1 ((= i len))
233     (let ((el (%primitive header-ref fun i)))
234     (when (symbolp el)
235     (let ((bits (symbol-bits el)))
236     (setf (symbol-bits el) (logior referenced-bit bits))
237     (when (zerop (logand marked-bit bits))
238     (mark-if-worthwhile el))))))))
239    
240    
241     ;;; Mark-If-Worthwhile -- Internal
242     ;;;
243     ;;; Mark the symbol if it is not already marked. If it is appears to
244     ;;; be a symbol likely to be used at runtime, we set the worthwhile
245     ;;; bit as well.
246     ;;;
247     (defun mark-if-worthwhile (sym)
248     (when (zerop (logand (symbol-bits sym) marked-bit))
249     ;;
250     ;; Mark it so we know we have been here...
251     (setf (symbol-bits sym) (logior marked-bit (symbol-bits sym)))
252     ;;
253     ;; If fbound and not an open-coded function, walk the function.
254     (when (and (fboundp sym) (not (inlinep sym)))
255     (setf (symbol-bits sym)
256     (logior worthwhile-bit (symbol-bits sym)))
257     (mark-function (symbol-function sym)))
258     ;;
259     ;; If bound and not a inline constant, or neither bound nor fbound,
260     ;; but has a plist, mark as worthwhile.
261     (when (if (boundp sym)
262     (not (and (constantp sym)
263     (let ((val (symbol-value sym)))
264     (or (characterp val) (numberp val) (eq sym val)))))
265     (and (not (fboundp sym))
266     (not (null (cddr (symbol-plist sym))))))
267     (setf (symbol-bits sym)
268     (logior worthwhile-bit (symbol-bits sym))))))
269    
270    
271     ;;; Transport-And-Scavenge -- Internal
272     ;;;
273     ;;; Transport a symbol and then scavenge to completion.
274     ;;;
275     (defun transport-and-scavenge (symbol)
276     (let* ((free-ptr-loc (free-pointer-location %symbol-type %static-space))
277     (clean-ptr (peek free-ptr-loc)))
278     (transport-symbol symbol)
279     (scavenge-symbols)))
280    
281    
282     ;;; Transport-Function -- Internal
283     ;;;
284     ;;; Grovel the constants of a function object, transporting things
285     ;;; that look useful. If a symbol has the worthwhile bit set, we move it. We
286     ;;; transport conses and g-vectors here so that they can go into read-only
287     ;;; space. If a constant is a compiled function, we recurse on it.
288     ;;;
289     (defun transport-function (fun)
290     (unless (purep fun)
291     (let ((def (ecase (%primitive get-vector-subtype fun)
292 ram 1.5 ((#.%function-entry-subtype #.%function-closure-entry-subtype)
293 ram 1.2 (transport-function-object fun)
294 ram 1.1 (%primitive header-ref fun %function-entry-constants-slot))
295     (#.%function-closure-subtype
296 ram 1.2 (let ((entry (%primitive header-ref fun
297     %function-name-slot)))
298 ram 1.5 (unless (purep entry)
299     (transport-function-object entry)
300     (%primitive header-ref entry
301     %function-entry-constants-slot))))
302 ram 1.1 (#.%function-funcallable-instance-subtype
303     nil))))
304 ram 1.2 (when (and def (not (purep def)))
305     (let ((length (%primitive header-length def)))
306     (transport-function-object def)
307 ram 1.6 (do ((i 0 ;%function-constants-constants-offset
308     (1+ i)))
309 ram 1.2 ((= i length))
310     (let ((const (%primitive header-ref def i)))
311     (typecase const
312     (symbol
313     (unless (zerop (logand worthwhile-bit (symbol-bits const)))
314     (transport-symbol const)))
315     (cons
316     (transport-cons const))
317     (compiled-function
318     (transport-function const))
319     (simple-vector
320 ram 1.6 (transport-g-vector const t))))))))))
321 ram 1.1
322    
323 ram 1.2 ;;; TRANSPORT-FUNCTION-OBJECT -- Internal
324     ;;;
325     ;;; Copy a function object into read-only space. This only moves the
326     ;;; function (entry or constants) object itself, and lets GC scavenge.
327     ;;;
328 ram 1.4 (defun transport-function-object (fun)
329 ram 1.2 (%primitive set-allocation-space %read-only-space)
330     (let* ((len (%primitive header-length fun))
331     (res (%primitive alloc-function len)))
332     (%primitive set-vector-subtype res (%primitive get-vector-subtype fun))
333     (dotimes (i len)
334     (%primitive header-set res i (%primitive header-ref fun i)))
335     (poke fun (%primitive make-immediate-type res %gc-forward-type)))
336     (%primitive set-allocation-space %static-space))
337    
338    
339 ram 1.1 ;;; Transport-Cons -- Internal
340     ;;;
341     ;;; Transport a cons and any list structure attached to it into read-only
342     ;;; space and scavenge to completion.
343     ;;;
344     (defun transport-cons (cons)
345     (unless (purep cons)
346     (%primitive set-allocation-space %read-only-space)
347     (let* ((free-ptr-loc (free-pointer-location %list-type %read-only-space))
348     (clean-ptr (peek free-ptr-loc)))
349     (loop
350 ram 1.2 (loop
351     (let ((new (cons (car cons) (cdr cons))))
352     (poke cons (%primitive make-immediate-type new %gc-forward-type))
353     (setq cons (cdr cons))
354     (when (or (atom cons) (purep cons)) (return nil))))
355     (let ((free-ptr (peek free-ptr-loc)))
356     (loop
357     (when (eq clean-ptr free-ptr)
358     (%primitive set-allocation-space %static-space)
359     (return-from transport-cons nil))
360     (setq cons (car clean-ptr))
361     (setq clean-ptr (next-cons clean-ptr))
362     (unless (or (atom cons) (purep cons)) (return nil))))))))
363 ram 1.1
364     ;;; Transport-G-Vector -- Internal
365     ;;;
366 ram 1.6 ;;; Transport a G-Vector into static or read-only space. We only bother
367     ;;; with the top level, and leave the rest to GC.
368 ram 1.1 ;;;
369     (defun transport-g-vector (vec &optional read-only)
370     (unless (purep vec)
371     (when read-only
372     (%primitive set-allocation-space %read-only-space))
373     (copy-g-vector vec)
374     (when read-only
375     (%primitive set-allocation-space %static-space))))
376    
377     ;;; Transport-Root -- Internal
378     ;;;
379     ;;; Descend into lists, simple-vectors and compiled functions, transporting
380     ;;; any useful symbols we run into, and scavenging to completion after each. We
381     ;;; transport simple-vectors now so that we don't lose on circular or highly
382     ;;; shared structures.
383     ;;;
384     (defun transport-root (object)
385     (unless (purep object)
386     (typecase object
387     (symbol
388     (unless (zerop (logand worthwhile-bit (symbol-bits object)))
389     (transport-and-scavenge object)))
390     (simple-vector
391     (let ((new (copy-g-vector object)))
392     (dotimes (i (length new))
393     (transport-root (svref new i)))))
394     (cons
395     (transport-root (car object))
396     (transport-root (cdr object)))
397     (compiled-function
398     (transport-function object)))))
399    
400     ;;; Localify -- Internal
401     ;;;
402     ;;; This function goes GC-Like stuff at lisp level to try to increase
403     ;;; the locality in a purified core image. The basic idea is to do a
404     ;;; breadth-first walk of the function objects, moving interesting symbols
405     ;;; into static space.
406     ;;;
407     (defun localify (root-structures)
408     (%primitive set-allocation-space %static-space)
409     ;;
410     ;; Mark interesting symbols, and those referenced by their definitions.
411     (do-allocated-symbols (sym %dynamic-space)
412     (setf (symbol-bits sym) 0))
413     (do-allocated-symbols (sym %dynamic-space)
414     (mark-if-worthwhile sym))
415     ;;
416     ;; Move interesting symbols referenced by the root structures.
417     (dolist (x root-structures)
418     (transport-root x))
419     ;;
420     ;; Treat interesting unreferenced symbols as roots...
421     (do-allocated-symbols (sym %dynamic-space)
422     (unless (purep sym)
423     (let ((bits (symbol-bits sym)))
424     (when (and (zerop (logand referenced-bit bits))
425     (not (zerop (logand worthwhile-bit bits))))
426     (transport-and-scavenge sym)))))
427     ;;
428     ;; Treat referenced symbols as roots...
429     (do-allocated-symbols (sym %dynamic-space)
430     (unless (or (purep sym)
431     (zerop (logand referenced-bit (symbol-bits sym))))
432     (transport-and-scavenge sym)))
433     ;;
434     ;; Do anything else that wants to be done...
435     (do-allocated-symbols (sym %dynamic-space)
436     ;;
437     ;; Move some types of variable value...
438     (when (boundp sym)
439     (let ((val (symbol-value sym)))
440     (cond ((purep val))
441 ram 1.5 #|Accesses global vars, so can't work...
442 ram 1.2 ((eq (info variable kind sym) :constant)
443 ram 1.1 (typecase val
444     (cons (transport-cons val))
445 ram 1.5 (simple-vector (transport-g-vector val t))))
446     |#
447     )))
448 ram 1.1 ;;
449     ;; Move any interned symbol that's left...
450     (unless (or (purep sym) (not (symbol-package sym)))
451     (transport-and-scavenge sym)))
452    
453     ;;
454     ;; Reset the bits...
455     (remprop nil 'purify-symbol-bits)
456    
457     (do-allocated-symbols (sym %static-space)
458     (remprop sym 'purify-symbol-bits))
459    
460     (do-allocated-symbols (sym %dynamic-space)
461     (remprop sym 'purify-symbol-bits))
462    
463     (%primitive set-allocation-space %dynamic-space))
464     ); Compiler-Let
465    
466     ;;;; Save-Stand-Alone-Lisp
467     ;;;
468     ;;; A stand-alone is a lisp that has had everything that doesn't pertain
469     ;;; to a particular application GC'ed away. This can result in a drastic
470     ;;; size reduction, but tends make the Lisp unusable for anything else and
471     ;;; hard to debug in. We do this by blowing away all symbols not directly
472     ;;; referenced and doing a GC. We also blow away random debug info.
473    
474    
475     ;;; Save-Stand-Alone-Lisp -- Public
476     ;;;
477     (defun save-stand-alone-lisp (file root-function)
478     "Write into File a core file which contains only objects referenced
479     by Root-Function or needed for the basic system. Root-Function
480     is called when the core file is resumed. Root-Function should be
481     a symbol rather than an actual function object."
482     (let ((all-packages (list-all-packages)))
483     (fresh-line)
484     (write-string "[Nuking useless stuff")
485     (force-output)
486     ;;
487     ;; Mark all external symbols so that we can find them later...
488     (dolist (p all-packages)
489     (do-external-symbols (s p)
490     (setf (symbol-bits s) 1)))
491     ;;
492     ;; Nuke all hashtables in packages...
493     (dolist (p all-packages)
494     (make-package-hashtable 10 (package-internal-symbols p))
495     (make-package-hashtable 10 (package-external-symbols p)))
496 ram 1.2 #|
497 ram 1.1 ;;
498     ;; Nuke random garbage on all symbols...
499     (do-allocated-symbols (s %dynamic-space)
500     ;;
501     ;; Nuke arglists on functions...
502     (when (fboundp s)
503     (let ((fun (symbol-function s)))
504     (cond ((compiled-function-p fun)
505     (%primitive header-set fun %function-arg-names-slot ()))
506     ((and (consp fun) (compiled-function-p (cdr fun)))
507 ram 1.2 (%primitive header-set (cdr fun) %function-arg-names-slot
508     ()))))
509    
510 ram 1.1 ;;
511     ;; Nuke unnecessary properties...
512     (when (symbol-plist s)
513     (dolist (p garbage-properties)
514     (when (get s p)
515 ram 1.2 (remprop s p))))))
516     |#
517    
518 ram 1.1 (write-string "]
519     [GC'ing it away")
520     (force-output)
521     ;;
522     ;; GC it away....
523     (gc nil)
524 ram 1.2 (write-string "]")
525 ram 1.1 ;;
526     ;; Rebuild packages...
527     (write-string "]
528     [Rebuilding packages")
529     (force-output)
530     (do-allocated-symbols (s %dynamic-space)
531     (let ((p (symbol-package s)))
532     (cond ((null p))
533     ((zerop (symbol-bits s))
534     (add-symbol (package-internal-symbols p) s))
535     (t
536     (add-symbol (package-external-symbols p) s)
537     (setf (symbol-bits s) 0)))
538     (remprop s 'purify-symbol-bits)))
539     (do-allocated-symbols (s %static-space)
540     (let ((p (symbol-package s)))
541     (cond ((null p))
542     ((zerop (symbol-bits s))
543     (add-symbol (package-internal-symbols p) s))
544     (t
545     (add-symbol (package-external-symbols p) s)
546     (setf (symbol-bits s) 0)))
547     (remprop s 'purify-symbol-bits)))
548     (write-line "]")
549     (purify :root-structures (list root-function))
550     (if (save file)
551     (quit)
552     (funcall root-function))))
553 wlott 1.6.1.1
554     |#

  ViewVC Help
Powered by ViewVC 1.1.5