X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=71ec219008ad911eda250df5accfb3246b2ad3d5;hb=ae1efb49d01b7f887b4e6bed741a01a28124c643;hp=ddca38e14580f03a156c1bc7b57ffe13f5f18668;hpb=16f848f33e91035457132f704448d2d23c34724e;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index ddca38e..71ec219 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -49,6 +49,8 @@ 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. @@ -56,6 +58,13 @@ ;;;; 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) @@ -72,13 +81,16 @@ ;; 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? ;;; @@ -129,7 +141,7 @@ ;;; 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)) @@ -154,12 +166,14 @@ :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 @@ -175,7 +189,7 @@ ;;; 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)) @@ -417,6 +431,8 @@ ;;;; 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 @@ -447,7 +463,6 @@ ;; 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*) @@ -542,6 +557,8 @@ ;;; 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) @@ -687,7 +704,7 @@ ;; WHN 19990412 #+(and cmu sb-xc-host) (warning (lambda (c) - (compiler-note + (compiler-notify "~@<~A~:@_~ ~A~:@_~ ~@<(KLUDGE: That was a non-STYLE WARNING. ~ @@ -716,7 +733,7 @@ ;;; 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) @@ -739,7 +756,7 @@ ;;; 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))) @@ -780,12 +797,12 @@ (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
T NIL), ensuring that a @@ -833,30 +850,7 @@ ;;; 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 @@ -868,7 +862,7 @@ ;;; 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)) @@ -956,7 +950,7 @@ (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 @@ -996,13 +990,17 @@ (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) @@ -1028,9 +1026,9 @@ (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))))))) @@ -1122,7 +1120,7 @@ "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)