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