gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
the efficiency of stable code.")
+(defvar *fun-names-in-this-file* nil)
+
;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the
;;; insertion a (CATCH ...) around code to allow the debugger RETURN
;;; command to function.
\f
;;;; namespace management utilities
+(defun fun-lexically-notinline-p (name)
+ (let ((fun (lexenv-find name funs :test #'equal)))
+ ;; a declaration will trump a proclamation
+ (if (and fun (defined-fun-p fun))
+ (eq (defined-fun-inlinep fun) :notinline)
+ (eq (info :function :inlinep name) :notinline))))
+
;;; Return a GLOBAL-VAR structure usable for referencing the global
;;; function NAME.
(defun find-free-really-fun (name)
;; definedness at runtime, which is what matters.
#-sb-xc-host (not (fboundp name)))
(note-undefined-reference name :function))
- (make-global-var :kind :global-function
- :%source-name name
- :type (if (or *derive-function-types*
- (eq where :declared))
- (info :function :type name)
- (specifier-type 'function))
- :where-from where)))
+ (make-global-var
+ :kind :global-function
+ :%source-name name
+ :type (if (or *derive-function-types*
+ (eq where :declared)
+ (and (member name *fun-names-in-this-file* :test #'equal)
+ (not (fun-lexically-notinline-p name))))
+ (info :function :type name)
+ (specifier-type 'function))
+ :where-from where)))
;;; Has the *FREE-FUNS* entry FREE-FUN become invalid?
;;;
;;; 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))
+(declaim (ftype (sfunction (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))
:inline-expansion expansion
:inlinep inlinep
:where-from (info :function :where-from name)
- :type (info :function :type name))
+ :type (if (eq inlinep :notinline)
+ (specifier-type 'function)
+ (info :function :type name)))
(find-free-really-fun name))))))))
;;; Return the LEAF structure for the lexically apparent function
;;; definition of NAME.
-(declaim (ftype (function (t string) leaf) find-lexically-apparent-fun))
+(declaim (ftype (sfunction (t string) leaf) find-lexically-apparent-fun))
(defun find-lexically-apparent-fun (name context)
(let ((var (lexenv-find name funs :test #'equal)))
(cond (var
;;; corresponding value. Otherwise, we make a new leaf using
;;; information from the global environment and enter it in
;;; *FREE-VARS*. If the variable is unknown, then we emit a warning.
-(declaim (ftype (function (t) (or leaf cons heap-alien-info)) find-free-var))
+(declaim (ftype (sfunction (t) (or leaf cons heap-alien-info)) find-free-var))
(defun find-free-var (name)
(unless (symbolp name)
(compiler-error "Variable name is not a symbol: ~S." name))
\f
;;;; IR1-CONVERT, macroexpansion and special form dispatching
+(declaim (ftype (sfunction (continuation continuation t) (values))
+ ir1-convert))
(macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
;; out of the body and converts a proxy form instead.
(ir1-error-bailout ((start
;; the creation using backquote of forms that contain leaf
;; references, without having to introduce dummy names into the
;; namespace.
- (declaim (ftype (function (continuation continuation t) (values)) ir1-convert))
(defun ir1-convert (start cont form)
(ir1-error-bailout (start cont form)
(let ((*current-path* (or (gethash form *source-paths*)
;;; functional instead.
(defun reference-leaf (start cont leaf)
(declare (type continuation start cont) (type leaf leaf))
+ (when (functional-p leaf)
+ (assure-functional-live-p leaf))
(let* ((type (lexenv-find leaf type-restrictions))
(leaf (or (and (defined-fun-p leaf)
(not (eq (defined-fun-inlinep leaf)
;; WHN 19990412
#+(and cmu sb-xc-host)
(warning (lambda (c)
- (compiler-note
+ (compiler-notify
"~@<~A~:@_~
~A~:@_~
~@<(KLUDGE: That was a non-STYLE WARNING. ~
;;; Convert a bunch of forms, discarding all the values except the
;;; last. If there aren't any forms, then translate a NIL.
-(declaim (ftype (function (continuation continuation list) (values))
+(declaim (ftype (sfunction (continuation continuation list) (values))
ir1-convert-progn-body))
(defun ir1-convert-progn-body (start cont body)
(if (endp body)
;;; 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)
+(declaim (ftype (sfunction (continuation continuation list leaf) combination)
ir1-convert-combination))
(defun ir1-convert-combination (start cont form fun)
(let ((fun-cont (make-continuation)))
(let ((transform (info :function
:source-transform
(leaf-source-name var))))
- (if transform
- (multiple-value-bind (result pass) (funcall transform form)
- (if pass
- (ir1-convert-maybe-predicate start cont form var)
+ (if transform
+ (multiple-value-bind (result pass) (funcall transform form)
+ (if pass
+ (ir1-convert-maybe-predicate start cont form var)
(ir1-convert start cont result)))
- (ir1-convert-maybe-predicate start cont form var))))))
+ (ir1-convert-maybe-predicate start cont form var))))))
;;; If the function has the PREDICATE attribute, and the CONT's DEST
;;; isn't an IF, then we convert (IF <form> T NIL), ensuring that a
;;; 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)))
-
+ (assure-functional-live-p functional)
(ir1-convert-combination start
cont
form
;;; LAMBDA-VAR for that name, or NIL if it isn't found. We return the
;;; *last* variable with that name, since LET* bindings may be
;;; duplicated, and declarations always apply to the last.
-(declaim (ftype (function (list symbol) (or lambda-var list))
+(declaim (ftype (sfunction (list symbol) (or lambda-var list))
find-in-bindings))
(defun find-in-bindings (vars name)
(let ((found nil))
(found
(setf (leaf-type found) type)
(assert-definition-type found type
- :unwinnage-fun #'compiler-note
+ :unwinnage-fun #'compiler-notify
:where "FTYPE declaration"))
(t
(res (cons (find-lexically-apparent-fun
(make-lexenv :default res :vars (new-venv))
res)))
-;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP.
+;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP
+;;; (and TYPE if notinline).
(defun make-new-inlinep (var inlinep)
(declare (type global-var var) (type inlinep inlinep))
(let ((res (make-defined-fun
:%source-name (leaf-source-name var)
:where-from (leaf-where-from var)
- :type (leaf-type var)
+ :type (if (and (eq inlinep :notinline)
+ (not (eq (leaf-where-from var) :declared)))
+ (specifier-type 'function)
+ (leaf-type var))
:inlinep inlinep)))
(when (defined-fun-p var)
(setf (defined-fun-inline-expansion res)
(etypecase found
(functional
(when (policy *lexenv* (>= speed inhibit-warnings))
- (compiler-note "ignoring ~A declaration not at ~
- definition of local function:~% ~S"
- sense name)))
+ (compiler-notify "ignoring ~A declaration not at ~
+ definition of local function:~% ~S"
+ sense name)))
(global-var
(push (cons name (make-new-inlinep found sense))
new-fenv)))))))
"in VALUES declaration"))))
(dynamic-extent
(when (policy *lexenv* (> speed inhibit-warnings))
- (compiler-note
+ (compiler-notify
"compiler limitation: ~
~% There's no special support for DYNAMIC-EXTENT (so it's ignored)."))
res)
projects / sbcl.git / blobdiff