Skip to content

Instantly share code, notes, and snippets.

@danlentz

danlentz/tree-shake.lisp

Created March 17, 2015 23:49
Show Gist options
  • Star 2 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save danlentz/4778188019707b21aa16 to your computer and use it in GitHub Desktop.
Save danlentz/4778188019707b21aa16 to your computer and use it in GitHub Desktop.
Download ZIP
Tree Shaker
Raw
tree-shake.lisp
;;; -*- Mode:Common-Lisp; Package:System; Base:10 -*-
;; RESTRICTED RIGHTS LEGEND
;;
;; Use, duplication, or disclosure by the Government is subject to
;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;; Technical Data and Computer Software clause at 52.227-7013.
;;
;; TEXAS INSTRUMENTS INCORPORATED.
;; P.O. BOX 2909
;; AUSTIN, TEXAS 78769
;; MS 2151
;;
;; Copyright (C) 1988-1989 Texas Instruments Incorporated. All rights reserved.
;;; *-----------------------------------------------------------*
;;; | "Tree Shaker" |
;;; *-----------------------------------------------------------*
;;Revision history:
;; 6/23/87 PHD - Original.
;; 10/01/87 DNG - Changed GC-HISTORY to GC-STATUS; some re-arrangement.
;; ... DNG - Major enhancement.
;; 10/20/87 DNG - Sort the package names for reporting.
;; 10/21/87 DNG - Add :UNDO-PREVIOUS-TRAINING option.
;; 10/23/87 DNG - Allow :PURGE-PACKAGES (LIST-ALL-PACKAGES) :KEEP-PACKAGES '(...).
;; 11/09/87 DNG - Export SYS:PKG-SHORTEST-NAME [used in TV, SUGG, and ZWEI].
;; 11/10/87 DNG - Clear variables // and ///. Reset time stamp in generic
;; pathnames so MAKE-SYSTEM won't think the file is already loaded.
;; 11/12/87 DNG - Added updating of *FEATURES* list.
;; 11/17/87 DNG - Update UPDATE-FEATURES to check whether system name is defined.
;; 11/20/87 DNG - Update *PACKAGES-TO-BE-CLEANED* list.
;; 12/11/87 DNG - Clear TOP-LEVEL-FORM. Don't add anything to *FEATURES*.
;; 12/14/87 DNG - Fix to not remove :NFS and :RPC from *FEATURES*.
;; 12/21/87 DNG - Special hack to undefine SYS:PKG-INITIALIZE.
;; 12/22/87 DNG - Default :undo-previous-training true when DELETE-SYSTEM has
;; un-defined things in predefined packages.
;; 1/08/88 DNG - Eliminate unused flavors.
;; 1/21/88 DNG - Report number of flavors deleted.
;; 2/04/88 DNG - Clean out ONCE-ONLY-INITIALIZATION-LIST.
;; 2/08/88 DNG - Give warning if *MULTIPLE-SYMBOL-BLOCKS* is not nil afterwards.
;; Improve handling of invalid package name arguments.
;; 2/11/88 DNG - Remove unused elements of *ALL-RESOURCES* list.
;; 2/15/88 DNG - Adjust source layout for narrower screen.
;; 2/20/88 DNG - Garbage-collect unused pathnames. Disable network while
;; GC'ing. Call ZWEI::CLEAR-ALL-HISTORIES.
;; 2/22/88 DNG - Don't enable network if not enabled originally.
;; 2/23/88 DNG - Show number of pathnames deleted.
;; 3/05/88 DNG - When killing package, preserve value of area name symbol.
(defvar *additional-roots*
'(gc-status gc-and-disk-save si:lisp-top-level scheduler-stack-group)
"List of symbols which will not be deleted by the tree shaker.")
;;; --- Temporary patches for release 3 ---
(eval-when (eval load compile)
(let ((sym (find-symbol "LOCF-METHOD" 'eh)))
(when (and sym
(not (eq sym 'si:LOCF-METHOD))
(null (symbol-plist sym)))
(unintern sym 'eh)))) ; to avoid error on the EXPORT below
(export 'sys:(
;; The following should be in SYS:*EXTERNAL-SYSTEM-SYMBOLS* but aren't in rel. 3.
ARRAY-TYPE-FROM-ELEMENT-TYPE COERCE-TO-ARRAY-OPTIMIZED COERCE-TO-CHARACTER
COERCE-TO-DOUBLE-FLOAT COERCE-TO-FLOAT COERCE-TO-LIST COERCE-TO-SINGLE-FLOAT
COERCE-TO-SMALL-FLOAT COMPUTE-LISPM-ARRAY-TYPE COPY-OBJECT-TREE
DBIS-PLIST DELETE-DUPLICATES-LIST-EQL
DISJOINT-TYPEP FAT-STRING-CHAR-P FLAVOR-VAR-SELF-REF-INDEX GET-LOCATION
INHIBIT-DISPLACING-FLAG
INTERNAL-MAKE-SIMPLE-VECTOR LAMBDA-EXP-ARGS-AND-BODY LOCF-METHOD MISMATCH*
PKG-SHORTEST-NAME
REMOVE-DUPLICATES-LIST-EQL
SEARCH* SEARCH*-LIST SEARCH*-LIST-EQ-OR-EQL SEARCH*-STRING-CASE
SEARCH*-STRING-CASE-FROMEND SEARCH*-STRING-NOCASE SEARCH*-STRING-NOCASE-FROMEND
SEARCH*-VECTOR SEARCH*-VECTOR-EQL SEARCH*-VECTOR-FROMEND SHUTDOWN
SIMPLE-VECTOR-SIZE-P STRING-EQUAL* STRING=*
TYPE-CANONICALIZE TYPE-SPECIFIER-P)
*system-package*)
(export '( FS:DEFAULT-HOST FS:DEFINE-CANONICAL-TYPE FS:PARSE-PATHNAME
FS:SET-DEFAULT-PATHNAME)
"FS") ; fix SPR 6740
(export '(compiler::make-obsolete-flavor) "COMPILER") ; added to "COMPILER;MINDEFS" for release 4
;;; --- end of temporary patches ---
(defvar *externals*) ; A-list of packages and external symbol names
(let ((sym (find-symbol "FASLOAD" :TICL))
(val (find-symbol "FASL-RECORD-FILE-MACROS-EXPANDED" :SYSTEM)))
(when (and sym val)
;; If the XLD loader is kept, then this function also needs to be kept
;; because it is invoked by every file even though it is not directly
;; referenced by the loader itself. Stick it on the property list
;; so it will be kept if FASLOAD is.
(setf (get sym 'requires) val)))
(defun tree-shake (&rest options)
(declare (arglist &key :clean-packages :purge-packages :kill-packages
:keep-packages :keep-symbols :undo-previous-training
:batch :kamikaze))
"Clean up a load band by deleting things that aren't used.
The following arguments are a package or package name or a list of packages:
:CLEAN-PACKAGES - delete unused internal symbols in these packages.
:PURGE-PACKAGES - delete unused symbols (both internal and external) in these.
:KILL-PACKAGES - delete everything defined here even if they are used.
If none of the above are specified, then all packages will be cleaned except for
those specified by the :KEEP-PACKAGES argument.
:KEEP-SYMBOLS is a list of symbols that are to be retained despite the actions
requested by the previous arguments.
The :UNDO-PREVIOUS-TRAINING option specifies whether to garbage-collect
regions that have previously been trained. This defaults based on whether you
request purging or killing any of the original system packages.
:BATCH, if true, suppresses querying for confirmation (default is to ask).
If the :KAMIKAZE option is true, TREE-SHAKE will delete itself before returning.
Another full garbage collection is needed after running this function in order
to reclaim the data structures it uses. You will also probably want to do
band training and then disk-save."
(let* ((this-package '#,(package-name *package*))
(fn (find-symbol "SHAKE-PARMS" this-package))
(gc-was-on (si::gc-active-p)))
(multiple-value-bind (clean-packages purge-packages kill-packages
keep-symbols kamikaze
packages-affected package-sizes undo-previous-training
more-packages)
(apply fn options) ; call SHAKE-PARMS to process the arguments
(unless (null packages-affected)
;; Now that the arguments have been normalized and validated, the actual
;; work begins.
(general-cleanup)
(setq options nil) ; allow GC'ing symbols used in original arguments.
(dolist (pkg kill-packages)
(format *debug-io* "~&Undefining local symbols in package ~A.~%"
(package-name pkg))
(do-local-symbols (symbol pkg)
(declare (symbol symbol))
(when (and (eq (symbol-package symbol) pkg)
(not (member symbol keep-symbols :test #'eq)))
(unless (member symbol area-list :test #'eq) ; deleting an area breaks GC
(makunbound symbol))
(fmakunbound symbol)
(setf (symbol-plist symbol) nil)
)))
(gc-off)
(training-off :clear-train-space nil) ; will be cleared by the second GC-IMMEDIATELY below.
(gc-immediately :max-gen 1 :promote nil)
;;(gc-status)
(let* ((*additional-roots*
(list #'tree-shake keep-symbols *additional-roots*)); so not GC'd
;; set by BLAST-PACKAGE, used by MAPATOMS-ALL-SYMBOL-AREAS
(si::*all-symbol-areas* nil)
(*externals* nil)
resource-names
;; Is the network currently enabled?
(net-enable
(or (> (length (value-if-defined "ETHERNET"
"*ETHERNET-PROTOCOLS*"))
1)
(value-if-defined "CHAOS" "CHAOS-SERVERS-ENABLED")) )
npath)
;; defined in DELETE-SYSTEM file:
(declare (special *packages-to-be-cleaned*))
(if kamikaze
(setq fn nil) ; let it be GC'd
(push fn *additional-roots*))
(unwind-protect
(progn
;; Don't want network activity to be interning symbols or pathnames.
(when net-enable
(format *debug-io* "~&Disabling the network.~%")
(call-if-defined "NET" "RESET" nil))
(when (fboundp 'fs::clear-pathnames-before-gc) ; new in release 4
;; Enable collecting unused pathnames.
(setq npath (hash-table-count fs:*pathname-hash-table*))
(format *debug-io* "~&Clearing pathname hash table.~%")
(fs::clear-pathnames-before-gc))
;; un-intern all symbols from the affected packages
(blast-packages kill-packages nil)
(blast-packages clean-packages t)
(blast-packages purge-packages nil)
;; temporarily remove some pointers to symbols
(blast-flavors)
(setq resource-names (mapcar #'symbol-spec *all-resources*))
(setq *all-resources* nil)
;; garbage collect
(when undo-previous-training
(make-generation-three-dynamic))
(gc-immediately :max-gen 3 :promote nil))
;; re-intern the symbols that survived garbage collection
(remake-packages packages-affected)
;; restore other data structures
(remake-flavors)
(setq *all-resources* (nconc *all-resources*
(remake-symbol-list resource-names)))
(when (fboundp 'fs::clear-pathnames-before-gc)
;; re-build pathname hash table
(format *debug-io* "~&Restoring pathname hash table.~%")
(fs::restore-pathnames-after-gc)
(format t "~&Deleted ~S out of ~S pathnames."
(- npath (hash-table-count fs:*pathname-hash-table*)) npath))
(when net-enable
(format *debug-io* "~&Enabling the network.~%")
(call-if-defined "NET" "RESET" t)) ; re-enable the network
) ; end of unwind-protect
(when gc-was-on (gc-on))
(setq *packages-to-be-cleaned* more-packages)
;; Report the results.
(format t "~2&")
(let ((count (length resource-names)))
(when (> count (length *all-resources*))
(format t "~&Deleted ~S out of ~S resources."
(- count (length *all-resources*)) count)))
(let ((trimmed-packages nil))
(do ((pkgs packages-affected (rest pkgs))
(sizes package-sizes (rest sizes))
(total 0))
((null sizes)
(format t "~2&There were a total of ~S symbols deleted.~2%"
total))
(let ((delta (- (first sizes)
(sys:pack-number-of-symbols (first pkgs)))))
(when (> delta 0)
(incf total delta)
(push (first pkgs) trimmed-packages))
(format t "~&Deleted ~S out of ~S symbols from package ~A."
delta (first sizes) (package-name (first pkgs)))
))
;; Finally, some assorted cleanup.
(update-features) ; update *FEATURES* list
(labels ((re-export (pkg)
(let ((x (assoc pkg *externals* :test #'eq)))
(unless (null (cdr x))
(dolist (uses (sys:pack-use-list pkg))
(re-export uses))
(format *debug-io*
"~&Restoring external symbols in package ~A.~%"
(package-name pkg))
(dolist (name (cdr x))
(export (if (consp name)
(intern (cdr name) (car name))
(intern name pkg))
pkg))
(setf (cdr x) nil)))))
(dolist (x *externals*)
(re-export (car x))))
(unless (null trimmed-packages)
(format *debug-io*
"~&Marking generic pathnames for re-load by MAKE-SYSTEM.~%")
(maphash #'(lambda (key pathname)
(declare (ignore key))
(let ((prop
(send pathname :get :file-id-package-alist)))
(dolist (loaded-id prop)
(when (member (car loaded-id) trimmed-packages
:test #'eq)
;; Found a generic pathname which was loaded into
;; one of the packages from which we have deleted
;; some symbols. Cause MAKE-SYSTEM to re-load
;; the file instead of thinking that it is
;; already loaded.
(assert (integerp (cdr (second loaded-id))))
;; reset time stamp
(setf (cdr (second loaded-id)) 0)
))))
fs:*pathname-hash-table*))
)
(let ((empty-packages nil))
(dolist (pkg packages-affected)
(when (zerop (sys:pack-number-of-symbols pkg)) ; empty package
(if (null (sys:pack-used-by-list pkg))
(push pkg empty-packages)
;; put at end of list in hopes the packages that use it can be
;; deleted first.
(push-end pkg empty-packages))))
(dolist (pkg empty-packages)
(when (and (null (sys:pack-used-by-list pkg))
(or (and (null (sys:pack-shadowing-symbols pkg))
(member (sys:pack-use-list pkg)
'#,(list (list *lisp-package*
*ticl-package*)
(list *ticl-package*
*lisp-package*))
:test #'equal)
(equal (sys:pack-prefix-name pkg)
(package-name pkg))
(null (sys:pack-nicknames pkg)))
;; Not only is this package empty, but it has no
;; non-defaulted attributes, so the package can be
;; auto-created if necessary without losing any
;; information.
(member pkg kill-packages :test #'eq)))
(format t "~&Deleting empty package ~A.~%" (package-name pkg))
(kill-package pkg))))
;; discard trash from BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT
(setq si::*symbols-seen-twice* nil)
(when kamikaze
(format *debug-io* "~&Deleting the tree shaker program.")
(let ((symbols '( tree-shake blast-packages blast-package
remake-packages general-cleanup update-features
*additional-roots* *externals*
other-packages-property external-property
symbol-spec remake-symbol blast-flavors remake-flavors
call-if-defined value-if-defined
)))
(when (setq fn (find-symbol "SHAKE-PARMS" this-package))
;; if not already garbage-collected
(push fn symbols))
(dolist (symbol symbols)
(makunbound symbol)
(fmakunbound symbol)
(remprop symbol :previous-definition)
(unless (member symbol keep-symbols :test #'eq)
(unintern symbol this-package)))
))
;;(gc-status)
(values)
)))))
(defun shake-parms (&key clean-packages purge-packages kill-packages
keep-packages keep-symbols batch kamikaze
(undo-previous-training :default))
;; This function has been carefully separated from TREE-SHAKE because it uses
;; things that TREE-SHAKE might want to eliminate.
(declare (special *packages-to-be-cleaned*)) ; defined in DELETE-SYSTEM file
(flet ((pkg-list (arg)
(unless (listp arg) (setq arg (list arg)))
(let ((pkgs '()))
(dolist (pkg-name arg)
(let ((pkg (find-package pkg-name)))
(if (null pkg)
(cerror "Continue without package ~A."
"Package ~A does not exist."
pkg-name)
(pushnew pkg pkgs :test #'eq))))
(nreverse pkgs)))
(ensure-disjoint (name1 list1 name2 list2)
(let ((conflict (intersection list1 list2 :test #'eq)))
(when conflict
(unless (= (length list1) (length (list-all-packages)))
(dolist (x conflict)
(cerror "Remove package ~A from the ~S list and continue."
"Package ~A is listed in both the ~S and ~S lists."
(package-name x) name1 name2)))
(setf list1 (set-difference list1 list2))))
list1)
(sort-packages (list)
(declare (list list))
(if (fboundp 'sort)
(sort list #'string< :key #'package-name)
list)))
(setq clean-packages (pkg-list clean-packages))
(setq keep-packages (pkg-list keep-packages))
(setq kill-packages (pkg-list kill-packages))
(setq purge-packages (pkg-list purge-packages))
(unless (listp keep-symbols) (setq keep-symbols (list keep-symbols)))
(cond ((not (or clean-packages purge-packages kill-packages))
(setq clean-packages (set-difference (list-all-packages)
keep-packages)) )
(keep-packages
(setf clean-packages (ensure-disjoint :clean-packages clean-packages
:keep-packages keep-packages))
(setf purge-packages (ensure-disjoint :purge-packages purge-packages
:keep-packages keep-packages))
(setf kill-packages (ensure-disjoint :kill-packages kill-packages
:keep-packages keep-packages))
)
)
(setq clean-packages (nset-difference clean-packages kill-packages))
(setq clean-packages
(sort-packages (nset-difference clean-packages purge-packages)))
(setq purge-packages
(sort-packages (nset-difference purge-packages kill-packages)))
(dolist (pkg kill-packages)
(when (member pkg '#,(mapcar #'find-package '("LISP" "TICL" "SYSTEM"
"KEYWORD" "GLOBAL" "EH"))
:test #'eq)
(error "Killing package ~A is not permitted because it would crash the system."
(package-name pkg))))
(setq kill-packages (sort-packages kill-packages))
(when (eq undo-previous-training :default)
(setq undo-previous-training
(dolist (pn '( "KEYWORD" "LISP" "TICL" "SYSTEM" "ZLC" "GLOBAL"
"COMPILER" "FORMAT" "FS" "TV" "W" "EH" "TIME" "FONTS"
"MATH" "NAME" "NET" "ZWEI" "NFS" "RPC")
nil)
;; These packages will have been cleaned before the band is shipped,
;; so if the customer wants to purge or kill them, the previously
;; trained regions will have to be changed from static to dynamic.
(let ((pkg (find-package pn)))
(when (and pkg
(or (member pkg purge-packages :test #'eq)
(member pkg kill-packages :test #'eq)
(and (boundp '*packages-to-be-cleaned*) ; set in UNLOAD-FILE
;; If functions have been un-defined from this
;; package, we need to undo training in order
;; to GC the FEFs, even if the package is not
;; being cleaned.
(member pkg *packages-to-be-cleaned*
:key #'find-package :test #'eq)
)))
(return t))))))
(format t "~2&")
(flet ((going-to (message list)
(unless (null list)
(let ((exceptions nil))
(declare (list exceptions))
(dolist (symbol keep-symbols)
(when (member (symbol-package symbol) list)
(pushnew symbol exceptions :test #'eq)))
(format t "~&Going to ~A in package~P ~{~A~^, ~}"
message (length list)
(mapcar #'package-name list))
(when exceptions
(format t "~& except for symbol~P ~{~S~^, ~}"
(length exceptions)
(if (fboundp 'sort) (sort exceptions #'string<)
exceptions)))
(write-char #\.)
))))
(going-to "un-define all definitions" kill-packages)
(going-to "delete unused internal symbols" clean-packages)
(going-to "delete unused symbols (both internal and external)"
purge-packages)
)
(if undo-previous-training
(format t "~&This will un-do the effects of any previous training, so the band should be
trained again after this.")
(format t "~&However, any symbols that were placed in static memory by any previous band
training will not be deleted."))
(when kamikaze
(format t "~&Going to delete the TREE-SHAKE program before returning."))
(when (or batch
(let ((duration 3)) ; timeout duration, in minutes
(with-timeout ((* 60. 60. duration)
(format *query-io* "Timed out, Yes.") t)
(yes-or-no-p "OK to proceed? (Automatic Yes after ~A minutes)"
duration))))
(terpri)
(let* ((packages-affected (sort-packages (append clean-packages
purge-packages
(copy-list kill-packages))))
(package-sizes (mapcar #'sys:pack-number-of-symbols
packages-affected))
(more-packages nil))
(when (boundp '*packages-to-be-cleaned*) ; set in UNLOAD-FILE
(dolist (name *packages-to-be-cleaned*)
(let ((pkg (find-package name)))
(unless (or (null pkg)
(member pkg packages-affected :test #'eq))
(push name more-packages)))))
(values clean-packages purge-packages kill-packages
keep-symbols kamikaze
packages-affected package-sizes undo-previous-training
more-packages)))))
(defparameter other-packages-property (make-symbol "OTHER-PACKAGES"))
(defparameter external-property (make-symbol "EXTERNAL"))
(defun blast-packages (&optional (packages (list-all-packages)) internals-only-p)
(dolist (p packages)
(blast-package p internals-only-p))
packages)
(defun blast-package (package &optional internals-only-p)
(declare (unspecial package))
(LET* ((pkg (pkg-find-package package))
(symtab (PACK-SYMBOL-TABLE pkg))
(limit (P-NUMBER-OF-ENTRIES symtab))
(used-by (sys:pack-used-by-list pkg))
(external-names nil))
(declare (list used-by external-names))
(format *debug-io* "~&Blasting package ~A.~%" (package-name pkg))
(when (eq pkg *system-package*)
(dolist (name '("INITIALIZE-COLD-LOAD" "PKG-INITIALIZE"))
;; These are only used the first time the band is cold-booted.
;; For some unknown reason they don't get shaken out automatically.
(let ((symbol (find-symbol name pkg)))
(when symbol
(fmakunbound symbol)))))
(DOTIMES (index limit )
(WHEN (P-ACTIVE-ENTRY (P-WORD0 symtab index))
(LET ((symbol (P-WORD1 symtab index)))
(pushnew (area-name (%area-number symbol))
si::*all-symbol-areas* :test #'eq)
(remprop symbol :previous-definition)
(let ((external-p (P-EXTERNAL-SYMBOL (p-word0 symtab index))))
(cond ((or (and internals-only-p
(or external-p
(and (eq pkg *keyword-package*)
(not (null (symbol-plist symbol))))))
(and (eq pkg '#,(find-package 'format))
;; symbols with these properties are accessed using
;; FIND-SYMBOL within FORMAT.
(getl symbol '( format::format-ctl-no-arg
format::format-ctl-one-arg
format::format-ctl-multi-arg))))
;; Need to keep this symbol.
(push symbol *additional-roots*)) ; so it won't be GC'd
((and external-p used-by)
;; May delete the definition, but the symbol itself needs to be
;; kept to preserve the package inheritance structure.
;; Remember the symbol's name so it can be re-created if
;; necessary.
(push (if (eq (symbol-package symbol) pkg)
(symbol-name symbol)
(cons (symbol-package symbol) (symbol-name symbol)))
external-names)))
(if (neq (symbol-package symbol) pkg)
(push (cons pkg external-p)
(get symbol other-packages-property ))
(when external-p
(setf (get symbol external-property) t))))))
(setf (aref symtab index 0) nil)
(setf (aref symtab index 1) nil))
(setf (PACK-NUMBER-OF-SYMBOLS pkg) 0)
(when external-names
(push (cons pkg external-names) *externals*)))
(values))
(defun remake-packages (packages)
(format *debug-io* "~&Remaking packages.~%")
(MAPATOMS-ALL-SYMBOL-AREAS
#'(lambda (symbol)
(let ((pkg (symbol-package symbol)))
(when (and (packagep pkg)
(or (member pkg packages :test #'eq)
(not (eq symbol (find-symbol (symbol-name symbol) pkg)))))
(BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT
symbol pkg (get symbol external-property nil))))
(dolist (item (get symbol other-packages-property '()))
(BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT symbol (car item) (cdr item)))
(remprop symbol external-property)
(remprop symbol other-packages-property)
))
(dolist (x si::*MULTIPLE-SYMBOL-BLOCKS*)
;; This could happen if someone calls INTERN while TREE-SHAKE is running.
(format t "~&Warning: now have two instances of symbol ~S; see ~S."
(cdr x) 'si::*MULTIPLE-SYMBOL-BLOCKS*))
(values))
(defun call-if-defined (package-name symbol-name &rest args)
(let ((pkg (find-package package-name)))
(unless (null pkg)
(let ((symbol (find-symbol symbol-name pkg)))
(unless (or (null symbol)
(not (fboundp symbol)))
(apply symbol args))))))
(defun value-if-defined (package-name symbol-name &optional default)
(let (pkg symbol)
(if (and (setq pkg (find-package package-name))
(setq symbol (find-symbol symbol-name pkg))
(boundp symbol))
(symbol-value symbol)
default)))
(defun general-cleanup ()
;; Get rid of some lists normally deleted by FINISH-BUILD or BAND-CLEANER.
(setf fs:*default-pathname-defaults* (fs:make-pathname-defaults))
(setf fs:load-pathname-defaults (fs:make-pathname-defaults))
(dolist (name '( "FASLOADED-FILE-TRUENAMES" "COLD-LOAD-FUNCTION-PROPERTY-LISTS"
"AUX-CRASH-LIST" "*FLAVOR-COMPILATIONS*"
;; These ought to be cleared by FINISH-BUILD.
"*SYMBOLS-SEEN-TWICE*" "*MULTIPLE-SYMBOL-BLOCKS*"
"*PKG-HACK*" "*DUP-SYMBOLS*" "ORIGINAL-LISP-CRASH-LIST"))
(let ((symbol (find-symbol name *system-package*)))
(when symbol
(set symbol nil))))
;; Get rid of some data that is normally cleared by FULL-GC.
(call-if-defined "DOC" "ERASE-XREF-TABLE")
(SETQ + NIL * NIL - NIL / NIL ++ NIL +++ NIL ** NIL *** NIL)
(setq *VALUES* nil)
(call-if-defined "ZWEI" "CLEAR-ALL-HISTORIES")
;; These ought to be cleared by FULL-GC.
(SETQ // NIL /// NIL)
(makunbound 'grindef)
(MAKUNBOUND 'EH:*COMMAND-DISPATCH-TABLE*) ; work-around for SPR 7052
;; Dispose of form being evaluated.
(SET 'SI::TOP-LEVEL-FORM NIL) ; used in EVAL-ABORT-TRIVIAL-ERRORS
;; Other stuff not needed anymore
(if (fboundp 'fasload)
;; keep init-name so not done again if file is reloaded.
(dolist (init si:once-only-initialization-list)
(setf (si:init-form init) nil))
(setq si:once-only-initialization-list nil))
)
(defun update-features () ; update the *FEATURES* list to reflect changes made.
(dolist (x '(; ( <feature> <package> <function-name> <system-name>)
(:LX :LX "RESET" :LX)
(:NFS :NFS NIL :NFS)
(:RPC :RPC NIL :RPC)
(:BN :BN NIL :BN)
(:FLAVORS :SYSTEM "DEFFLAVOR")
(:DEFSTRUCT :SYSTEM :DEFSTRUCT)
(:LOOP :SYSTEM :LOOP)
(:CHAOS :CHAOS "OPEN-STREAM")
(:SORT :LISP :SORT)
(:FASLOAD :SYSTEM :FASLOAD)
(:TRACE :LISP :TRACE)
(:GRINDEF :TICL :GRINDEF)))
(let* ((feature (first x))
(pkg (find-package (second x)))
symbol)
(declare (symbol feature symbol))
(if (and pkg
(> (sys:pack-number-of-symbols pkg) 0)
(or (null (third x))
(and (setq symbol (find-symbol (third x) pkg))
(fboundp symbol)))
;; The following test commented out because not safe -- the system
;; name won't be defined if they are in the cold band.
;;(or (null (fourth x))
;; (si:find-system-named (fourth x) t t))
)
(comment ; not really safe to do this here, and no longer necessary.
(unless (or (member feature *FEATURES*)
(null (cddr x)))
(format t "~&Adding ~A to *FEATURES*." feature)
(push feature *FEATURES*)))
(when (member feature *FEATURES*)
(format t "~&Removing ~A from *FEATURES*." feature)
(setq *FEATURES* (remove feature (the list *FEATURES*) :test #'eq))))
))
(values))
(defun symbol-spec (symbol)
(cons (symbol-package symbol) (symbol-name symbol)))
(defun remake-symbol (spec)
(declare (values symbol foundp))
(if (symbolp spec)
(values spec t)
(find-symbol (cdr spec) (car spec))))
(defun remake-symbol-list (list)
(let ((symbols '()))
(dolist (elt list)
(multiple-value-bind (symbol foundp)
(remake-symbol elt)
(when foundp
(push symbol symbols))))
(copy-list (nreverse symbols))))
(defun blast-flavors ()
(format *debug-io* "~&Blasting flavors.~%")
(dolist (name *all-flavor-names*)
(let ((fl (get name 'si:flavor)))
(unless (null fl)
(setf (flavor-depended-on-by fl)
(mapcar #'symbol-spec (flavor-depended-on-by fl))))))
(setf *ALL-FLAVOR-NAMES*
(mapcar #'symbol-spec *ALL-FLAVOR-NAMES*))
(dotimes (i (length *ALL-FLAVOR-NAMES-AARRAY*))
(let ((elt (aref *ALL-FLAVOR-NAMES-AARRAY* i))) ; ("FOO" . FOO)
(setf (cdr elt) (symbol-spec (cdr elt)))))
(setf *FLAVOR-PENDING-DEPENDS*
(mapcar #'(lambda (x) (cons (symbol-spec (car x)) (symbol-spec (cdr x))))
*FLAVOR-PENDING-DEPENDS*))
(setf *FLAVOR-COMPILATIONS* '() )
(setf LAST-FASLOAD-COMBINED-METHOD-SPEC nil)
(setf LAST-FASLOAD-COMBINED-METHOD-DEF nil)
(when SOME-COMPONENT-UNDEFINED
(setf SOME-COMPONENT-UNDEFINED (symbol-spec SOME-COMPONENT-UNDEFINED)))
(values))
(defun remake-flavors ()
(format *debug-io* "~&Remaking flavors.~%")
(let ((count (length *ALL-FLAVOR-NAMES*)))
(setf *ALL-FLAVOR-NAMES* (remake-symbol-list *ALL-FLAVOR-NAMES*))
(format t "~&Deleted ~S out of ~S flavors."
(- count (length *ALL-FLAVOR-NAMES*)) count))
(dolist (name *all-flavor-names*)
(let ((fl (get name 'si:flavor)))
(unless (null fl)
(setf (flavor-depended-on-by fl)
(remake-symbol-list (flavor-depended-on-by fl))))))
(let ((limit (fill-pointer *ALL-FLAVOR-NAMES-AARRAY*)))
(setf (fill-pointer *ALL-FLAVOR-NAMES-AARRAY*) 0)
(dotimes (i limit)
(let ((elt (aref *ALL-FLAVOR-NAMES-AARRAY* i)))
(setf (aref *ALL-FLAVOR-NAMES-AARRAY* i) nil)
(multiple-value-bind (symbol foundp)
(remake-symbol (cdr elt))
(when foundp
(setf (cdr elt) symbol)
(vector-push elt *ALL-FLAVOR-NAMES-AARRAY*)
)))))
(when SOME-COMPONENT-UNDEFINED
(setf SOME-COMPONENT-UNDEFINED (remake-symbol SOME-COMPONENT-UNDEFINED)))
(setf *FLAVOR-PENDING-DEPENDS*
(mapcar #'(lambda (x)
(cons (remake-symbol (car x)) (remake-symbol (cdr x))))
*FLAVOR-PENDING-DEPENDS*))
(values))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment