;;; 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* to contain a
+;;; 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
;; (sbcl-0.pre7.118) is this one:
(and (defined-fun-p free-fun)
(let ((functional (defined-fun-functional free-fun)))
- (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))))))
+ (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
(use-continuation res cont)))
(values)))
-;;; Add FUN to the COMPONENT-REANALYZE-FUNS, unless it's some trivial
-;;; type for which reanalysis is a trivial no-op, or unless it doesn't
-;;; belong in this component at all.
+;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's
+;;; some trivial type for which reanalysis is a trivial no-op, or
+;;; unless it doesn't belong in this component at all.
;;;
-;;; FUN is returned.
-(defun maybe-reanalyze-fun (fun)
- (declare (type functional fun))
+;;; FUNCTIONAL is returned.
+(defun maybe-reanalyze-functional (functional)
+ (aver (not (eql (functional-kind functional) :deleted))) ; bug 148
(aver-live-component *current-component*)
- ;; When FUN is of a type for which reanalysis isn't a trivial no-op
- (when (typep fun '(or optional-dispatch clambda))
+ ;; When FUNCTIONAL is of a type for which reanalysis isn't a trivial
+ ;; no-op
+ (when (typep functional '(or optional-dispatch clambda))
- ;; When FUN knows its component
- (when (lambda-p fun)
- (aver (eql (lambda-component fun) *current-component*)))
+ ;; When FUNCTIONAL knows its component
+ (when (lambda-p functional)
+ (aver (eql (lambda-component functional) *current-component*)))
- (pushnew fun (component-reanalyze-funs *current-component*)))
+ (pushnew functional
+ (component-reanalyze-functionals *current-component*)))
- fun)
+ functional)
;;; Generate a REF node for LEAF, frobbing the LEAF structure as
;;; needed. If LEAF represents a defined function which has already
(let* ((leaf (or (and (defined-fun-p leaf)
(not (eq (defined-fun-inlinep leaf)
:notinline))
- (let ((fun (defined-fun-functional leaf)))
- (when (and fun (not (functional-kind fun)))
- (maybe-reanalyze-fun fun))))
+ (let ((functional (defined-fun-functional leaf)))
+ (when (and functional
+ (not (functional-kind functional)))
+ (maybe-reanalyze-functional functional))))
leaf))
(res (make-ref (or (lexenv-find leaf type-restrictions)
(leaf-type leaf))
(defun muffle-warning-or-die ()
(muffle-warning)
- (error "internal error -- no MUFFLE-WARNING restart"))
+ (bug "no MUFFLE-WARNING restart"))
;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping
;;; errors which occur during the macroexpansion.
\f
;;;; converting combinations
-;;; Convert a function call where the function (i.e. the FUN argument)
-;;; is a LEAF. We return the COMBINATION node so that the caller can
-;;; poke at it if it wants to.
+;;; Convert a function call where the function FUN is a LEAF. FORM is
+;;; the source for the call. We return the COMBINATION node so that
+;;; the caller can poke at it if it wants to.
(declaim (ftype (function (continuation continuation list leaf) combination)
ir1-convert-combination))
(defun ir1-convert-combination (start cont form fun)
(reference-leaf start fun-cont fun)
(ir1-convert-combination-args fun-cont cont (cdr form))))
-;;; Convert the arguments to a call and make the COMBINATION node.
-;;; FUN-CONT is the continuation which yields the function to call.
-;;; FORM is the source for the call. ARGS is the list of arguments for
-;;; the call, which defaults to the cdr of source. We return the
-;;; COMBINATION node.
+;;; Convert the arguments to a call and make the COMBINATION
+;;; node. FUN-CONT is the continuation which yields the function to
+;;; call. ARGS is the list of arguments for the call, which defaults
+;;; to the cdr of source. We return the COMBINATION node.
(defun ir1-convert-combination-args (fun-cont cont args)
(declare (type continuation fun-cont cont) (list args))
(let ((node (make-combination fun-cont)))
(setf (continuation-%type-check fun-cont) nil)))
(values))
-;;; Convert a call to a local function. If the function has already
-;;; been LET converted, then throw FUN to LOCAL-CALL-LOSSAGE. This
-;;; should only happen when we are converting inline expansions for
-;;; local functions during optimization.
-(defun ir1-convert-local-combination (start cont form fun)
- (if (functional-kind fun)
- (throw 'local-call-lossage fun)
- (ir1-convert-combination start cont form
- (maybe-reanalyze-fun fun))))
+;;; Convert a call to a local function, or if the function has already
+;;; been LET converted, then throw FUNCTIONAL to
+;;; LOCALL-ALREADY-LET-CONVERTED. The THROW should only happen when we
+;;; are converting inline expansions for local functions during
+;;; optimization.
+(defun ir1-convert-local-combination (start cont form functional)
+
+ ;; The test here is for "when LET converted", as a translation of
+ ;; the old CMU CL comments into code. Unfortunately, the old CMU CL
+ ;; comments aren't specific enough to tell whether the correct
+ ;; translation is FUNCTIONAL-SOMEWHAT-LETLIKE-P or
+ ;; FUNCTIONAL-LETLIKE-P or what. The old CMU CL code assumed that
+ ;; any non-null FUNCTIONAL-KIND meant that the function "had been
+ ;; LET converted", which might even be right, but seems fragile, so
+ ;; we try to be pickier.
+ (when (or
+ ;; looks LET-converted
+ (functional-somewhat-letlike-p functional)
+ ;; It's possible for a LET-converted function to end up
+ ;; deleted later. In that case, for the purposes of this
+ ;; analysis, it is LET-converted: LET-converted functionals
+ ;; are too badly trashed to expand them inline, and deleted
+ ;; LET-converted functionals are even worse.
+ (eql (functional-kind functional) :deleted))
+ (throw 'locall-already-let-converted functional))
+ ;; Any other non-NIL KIND value is a case we haven't found a
+ ;; justification for, and at least some such values (e.g. :EXTERNAL
+ ;; and :TOPLEVEL) seem obviously wrong.
+ (aver (null (functional-kind functional)))
+
+ (ir1-convert-combination start
+ cont
+ form
+ (maybe-reanalyze-functional functional)))
\f
;;;; PROCESS-DECLS
(setf found (cdr var)))))
found))
-;;; Called by Process-Decls to deal with a variable type declaration.
-;;; If a lambda-var being bound, we intersect the type with the vars
-;;; type, otherwise we add a type-restriction on the var. If a symbol
+;;; Called by PROCESS-DECLS to deal with a variable type declaration.
+;;; If a LAMBDA-VAR being bound, we intersect the type with the var's
+;;; type, otherwise we add a type restriction on the var. If a symbol
;;; macro, we just wrap a THE around the expansion.
(defun process-type-decl (decl res vars)
(declare (list decl vars) (type lexenv res))
(make-lexenv :default res :funs new-fenv)
res)))
-;;; Like FIND-IN-BINDINGS, but looks for #'foo in the fvars.
+;;; like FIND-IN-BINDINGS, but looks for #'FOO in the FVARS
(defun find-in-bindings-or-fbindings (name vars fvars)
(declare (list vars fvars))
(if (consp name)
(special (process-special-decl spec res vars))
(ftype
(unless (cdr spec)
- (compiler-error "No type specified in FTYPE declaration: ~S" spec))
+ (compiler-error "no type specified in FTYPE declaration: ~S" spec))
(process-ftype-decl (second spec) res (cddr spec) fvars))
((inline notinline maybe-inline)
(process-inline-decl spec res fvars))
(dolist (decl decls)
(dolist (spec (rest decl))
(unless (consp spec)
- (compiler-error "malformed declaration specifier ~S in ~S"
- spec
- decl))
+ (compiler-error "malformed declaration specifier ~S in ~S" spec decl))
(setq env (process-1-decl spec env vars fvars cont))))
env)
;;;; function representation" before you seriously mess with this
;;;; stuff.
-;;; Verify that a thing is a legal name for a variable and return a
-;;; Var structure for it, filling in info if it is globally special.
-;;; If it is losing, we punt with a Compiler-Error. Names-So-Far is an
-;;; alist of names which have previously been bound. If the name is in
+;;; Verify that the NAME is a legal name for a variable and return a
+;;; VAR structure for it, filling in info if it is globally special.
+;;; If it is losing, we punt with a COMPILER-ERROR. NAMES-SO-FAR is a
+;;; list of names which have previously been bound. If the NAME is in
;;; this list, then we error out.
(declaim (ftype (function (t list) lambda-var) varify-lambda-arg))
(defun varify-lambda-arg (name names-so-far)
(declare (inline member))
(unless (symbolp name)
- (compiler-error "The lambda-variable ~S is not a symbol." name))
+ (compiler-error "The lambda variable ~S is not a symbol." name))
(when (member name names-so-far :test #'eq)
(compiler-error "The variable ~S occurs more than once in the lambda-list."
name))
(let ((kind (info :variable :kind name)))
(when (or (keywordp name) (eq kind :constant))
- (compiler-error "The name of the lambda-variable ~S is a constant."
+ (compiler-error "The name of the lambda variable ~S is already in use to name a constant."
name))
(cond ((eq kind :special)
(let ((specvar (find-free-var name)))
(dolist (spec optional)
(if (atom spec)
(let ((var (varify-lambda-arg spec (names-so-far))))
- (setf (lambda-var-arg-info var) (make-arg-info :kind :optional))
+ (setf (lambda-var-arg-info var)
+ (make-arg-info :kind :optional))
(vars var)
(names-so-far spec))
(let* ((name (first spec))
;;; Create a lambda node out of some code, returning the result. The
;;; bindings are specified by the list of VAR structures VARS. We deal
;;; with adding the names to the LEXENV-VARS for the conversion. The
-;;; result is added to the NEW-FUNS in the *CURRENT-COMPONENT* and
-;;; linked to the component head and tail.
+;;; result is added to the NEW-FUNCTIONALS in the *CURRENT-COMPONENT*
+;;; and linked to the component head and tail.
;;;
;;; We detect special bindings here, replacing the original VAR in the
;;; lambda list with a temporary variable. We then pass a list of the
(link-blocks block (component-tail *current-component*))))))
(link-blocks (component-head *current-component*) (node-block bind))
- (push lambda (component-new-funs *current-component*))
+ (push lambda (component-new-functionals *current-component*))
lambda))
(body
`(when (oddp ,n-count)
- (%odd-key-arguments-error)))
+ (%odd-key-args-error)))
(body
`(locally
(unless allowp
(body `(when (and ,n-losep (not ,n-allowp))
- (%unknown-key-argument-error ,n-losep)))))))
+ (%unknown-key-arg-error ,n-losep)))))))
(let ((ep (ir1-convert-lambda-body
`((let ,(temps)
:aux-vars (append (bind-vars) aux-vars)
:aux-vals (append (bind-vals) aux-vals)
:result cont
- :debug-name (debug-namify "varargs entry point for ~A"
+ :debug-name (debug-namify "varargs entry for ~A"
(as-debug-name source-name
debug-name))))
(last-entry (convert-optional-entry main-entry default-vars
:%debug-name debug-name))
(min (or (position-if #'lambda-var-arg-info vars) (length vars))))
(aver-live-component *current-component*)
- (push res (component-new-funs *current-component*))
+ (push res (component-new-functionals *current-component*))
(ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals
cont source-name debug-name)
(setf (optional-dispatch-min-args res) min)
(unless (eq (defined-fun-inlinep var) :inline)
(setf (defined-fun-inline-expansion var) nil))
(let* ((name (leaf-source-name var))
- (fun (funcall converter lambda :source-name name))
+ (fun (funcall converter lambda
+ :source-name name))
(fun-info (info :function :info name)))
(setf (functional-inlinep fun) (defined-fun-inlinep var))
(assert-new-definition var fun)
projects / sbcl.git / blobdiff