-;;; Return a SLOT-ACCESSOR structure usable for referencing the slot
-;;; accessor NAME. CLASS is the structure class.
-(defun find-structure-slot-accessor (class name)
- (declare (type sb!xc:class class))
- (let* ((info (layout-info
- (or (info :type :compiler-layout (sb!xc:class-name class))
- (class-layout class))))
- (accessor-name (if (listp name) (cadr name) name))
- (slot (find accessor-name (dd-slots info)
- :key #'sb!kernel:dsd-accessor-name))
- (type (dd-name info))
- (slot-type (dsd-type slot)))
- (unless slot
- (error "can't find slot ~S" type))
- (make-slot-accessor
- :%source-name name
- :type (specifier-type
- (if (listp name)
- `(function (,slot-type ,type) ,slot-type)
- `(function (,type) ,slot-type)))
- :for class
- :slot slot)))
-
-;;; If NAME is already entered in *FREE-FUNCTIONS*, then return the
-;;; value. Otherwise, make a new GLOBAL-VAR using information from the
-;;; global environment and enter it in *FREE-FUNCTIONS*. If NAME names
-;;; a macro or special form, then we error out using the supplied
-;;; context which indicates what we were trying to do that demanded a
-;;; function.
-(defun find-free-function (name context)
- (declare (string context))
- (declare (values global-var))
- (or (gethash name *free-functions*)
+;;; Has the *FREE-FUNS* entry FREE-FUN become invalid?
+;;;
+;;; In CMU CL, the answer was implicitly always true, so this
+;;; predicate didn't exist.
+;;;
+;;; This predicate was added to fix bug 138 in SBCL. In some obscure
+;;; circumstances, it was possible for a *FREE-FUNS* entry to contain a
+;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1
+;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka
+;;; "dead") component. When this IR1 stuff was reused in a new
+;;; component, under further obscure circumstances it could be used by
+;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for
+;;; *CURRENT-COMPONENT*. At that point things got all confused, since
+;;; IR1 conversion was sending code to a component which had already
+;;; been compiled and would never be compiled again.
+(defun invalid-free-fun-p (free-fun)
+ ;; There might be other reasons that *FREE-FUN* entries could
+ ;; become invalid, but the only one we've been bitten by so far
+ ;; (sbcl-0.pre7.118) is this one:
+ (and (defined-fun-p free-fun)
+ (let ((functional (defined-fun-functional free-fun)))
+ (or (and functional
+ (eql (functional-kind functional) :deleted))
+ (and (lambda-p functional)
+ (or
+ ;; (The main reason for this first test is to bail
+ ;; out early in cases where the LAMBDA-COMPONENT
+ ;; call in the second test would fail because links
+ ;; it needs are uninitialized or invalid.)
+ ;;
+ ;; If the BIND node for this LAMBDA is null, then
+ ;; according to the slot comments, the LAMBDA has
+ ;; been deleted or its call has been deleted. In
+ ;; that case, it seems rather questionable to reuse
+ ;; it, and certainly it shouldn't be necessary to
+ ;; reuse it, so we cheerfully declare it invalid.
+ (null (lambda-bind functional))
+ ;; If this IR1 stuff belongs to a dead component,
+ ;; then we can't reuse it without getting into
+ ;; bizarre confusion.
+ (eql (component-info (lambda-component functional))
+ :dead)))))))
+
+;;; If NAME already has a valid entry in *FREE-FUNS*, then return
+;;; the value. Otherwise, make a new GLOBAL-VAR using information from
+;;; the global environment and enter it in *FREE-FUNS*. If NAME
+;;; names a macro or special form, then we error out using the
+;;; supplied context which indicates what we were trying to do that
+;;; demanded a function.
+(declaim (ftype (function (t string) global-var) find-free-fun))
+(defun find-free-fun (name context)
+ (or (let ((old-free-fun (gethash name *free-funs*)))
+ (and (not (invalid-free-fun-p old-free-fun))
+ old-free-fun))