X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=690d2a0290f79ac4faec5554c5272c874dbc4309;hb=44571438f3fc230bcc788e304bf9dfa85f8145a3;hp=728a23a310c2f013d7c1d65e88bc1c4b0518bdac;hpb=fa68810289c5be55f47f6cbd5324a5d91c20e865;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 728a23a..690d2a0 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -88,10 +88,16 @@ (eq (info :function :inlinep name) :notinline)))) ;; This will get redefined in PCL boot. -(declaim (notinline update-info-for-gf)) +(declaim (notinline maybe-update-info-for-gf)) (defun maybe-update-info-for-gf (name) - (declare (ignorable name)) - (values)) + (declare (ignore name)) + nil) + +(defun maybe-defined-here (name where) + (if (and (eq :defined where) + (member name *fun-names-in-this-file* :test #'equal)) + :defined-here + where)) ;;; Return a GLOBAL-VAR structure usable for referencing the global ;;; function NAME. @@ -113,24 +119,23 @@ ;; complain about undefined functions. (not latep)) (note-undefined-reference name :function)) - (make-global-var - :kind :global-function - :%source-name name - :type (if (or (eq where :declared) - (and (not latep) - (or *derive-function-types* - (eq where :defined-method) - (and (not (fun-lexically-notinline-p name)) - (member name *fun-names-in-this-file* - :test #'equal))))) - (progn - (maybe-update-info-for-gf name) - (info :function :type name)) - (specifier-type 'function)) - :defined-type (if (eq where :defined) - (info :function :type name) - *universal-type*) - :where-from where))) + (let ((ftype (info :function :type name)) + (notinline (fun-lexically-notinline-p name))) + (make-global-var + :kind :global-function + :%source-name name + :type (if (or (eq where :declared) + (and (not latep) + (not notinline) + *derive-function-types*)) + ftype + (specifier-type 'function)) + :defined-type (if (and (not latep) (not notinline)) + (or (maybe-update-info-for-gf name) ftype) + (specifier-type 'function)) + :where-from (if notinline + where + (maybe-defined-here name where)))))) ;;; Have some DEFINED-FUN-FUNCTIONALS of a *FREE-FUNS* entry become invalid? ;;; Drop 'em. @@ -205,14 +210,18 @@ (inlinep (info :function :inlinep name))) (setf (gethash name *free-funs*) (if (or expansion inlinep) - (make-defined-fun - :%source-name name - :inline-expansion expansion - :inlinep inlinep - :where-from (info :function :where-from name) - :type (if (eq inlinep :notinline) - (specifier-type 'function) - (info :function :type name))) + (let ((where (info :function :where-from name))) + (make-defined-fun + :%source-name name + :inline-expansion expansion + :inlinep inlinep + :where-from (if (eq inlinep :notinline) + where + (maybe-defined-here name where)) + :type (if (and (eq inlinep :notinline) + (neq where :declared)) + (specifier-type 'function) + (info :function :type name)))) (find-global-fun name nil)))))))) ;;; Return the LEAF structure for the lexically apparent function @@ -487,16 +496,19 @@ (trail form)) (declare (fixnum pos)) (macrolet ((frob () - '(progn + `(progn (when (atom subform) (return)) (let ((fm (car subform))) - (if (consp fm) - ;; If it's a cons, recurse - (sub-find-source-paths fm (cons pos path)) - ;; Otherwise store the containing form. It's - ;; not perfect, but better than nothing. - (unless (zerop pos) - (note-source-path subform pos path))) + (cond ((consp fm) + ;; If it's a cons, recurse. + (sub-find-source-paths fm (cons pos path))) + ((eq 'quote fm) + ;; Don't look into quoted constants. + (return)) + ((not (zerop pos)) + ;; Otherwise store the containing form. It's not + ;; perfect, but better than nothing. + (note-source-path subform pos path))) (incf pos)) (setq subform (cdr subform)) (when (eq subform trail) (return))))) @@ -594,22 +606,13 @@ ;;; functional instead. (defun reference-leaf (start next result leaf &optional (name '.anonymous.)) (declare (type ctran start next) (type (or lvar null) result) (type leaf leaf)) - (when (functional-p leaf) - (assure-functional-live-p leaf)) + (assure-leaf-live-p leaf) (let* ((type (lexenv-find leaf type-restrictions)) (leaf (or (and (defined-fun-p leaf) (not (eq (defined-fun-inlinep leaf) :notinline)) (let ((functional (defined-fun-functional leaf))) - (when (and functional - (not (functional-kind functional)) - ;; Bug MISC.320: ir1-transform - ;; can create a reference to a - ;; inline-expanded function, - ;; defined in another component. - (not (and (lambda-p functional) - (neq (lambda-component functional) - *current-component*)))) + (when (and functional (not (functional-kind functional))) (maybe-reanalyze-functional functional)))) (when (and (lambda-p leaf) (memq (functional-kind leaf) @@ -711,7 +714,7 @@ ;; CLHS 3.2.2.1.3 specifies that NOTINLINE ;; suppresses compiler-macros. (not (fun-lexically-notinline-p cmacro-fun-name))) - (let ((res (careful-expand-macro cmacro-fun form))) + (let ((res (careful-expand-macro cmacro-fun form t))) (cond ((eq res form) (ir1-convert-common-functoid start next result form op)) (t @@ -772,7 +775,7 @@ ;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping ;;; errors which occur during the macroexpansion. -(defun careful-expand-macro (fun form) +(defun careful-expand-macro (fun form &optional cmacro) (let (;; a hint I (WHN) wish I'd known earlier (hint "(hint: For more precise location, try *BREAK-ON-SIGNALS*.)")) (flet (;; Return a string to use as a prefix in error reporting, @@ -784,10 +787,11 @@ (*print-level* 3)) (format nil - #-sb-xc-host "(in macroexpansion of ~S)" + #-sb-xc-host "(in ~A of ~S)" ;; longer message to avoid ambiguity "Was it the xc host ;; or the cross-compiler which encountered the problem?" - #+sb-xc-host "(in cross-compiler macroexpansion of ~S)" + #+sb-xc-host "(in cross-compiler ~A of ~S)" + (if cmacro "compiler-macroexpansion" "macroexpansion") form)))) (handler-bind ((style-warning (lambda (c) (compiler-style-warn @@ -1079,9 +1083,8 @@ (type leaf var)) (let* ((node (ir1-convert-combination start next result form var)) (fun-lvar (basic-combination-fun node)) - (type (leaf-type var)) - (defined-type (leaf-defined-type var))) - (when (validate-call-type node type defined-type t) + (type (leaf-type var))) + (when (validate-call-type node type var t) (setf (lvar-%derived-type fun-lvar) (make-single-value-type type)) (setf (lvar-reoptimize fun-lvar) nil)))