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

Contents of /src/code/purify.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5