X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=a46f8ad3672b7ed411a2e48b601a9d23d423de18;hb=6d36f2d6954cb79e3c88fef33fe0c3ad63deaea8;hp=9ac65b658d3b78b2149291a7998aad402023b2ac;hpb=1b6b3e70df90dca341b22f1f3229ca3887c27510;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 9ac65b6..a46f8ad 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -43,6 +43,18 @@ (when (source-form-has-path-p form) (gethash form *source-paths*))) +(defun simplify-source-path-form (form) + (if (consp form) + (let ((op (car form))) + ;; In the compiler functions can be directly represented + ;; by leaves. Having leaves in the source path is pretty + ;; hard on the poor user, however, so replace with the + ;; source-name when possible. + (if (and (leaf-p op) (leaf-has-source-name-p op)) + (cons (leaf-source-name op) (cdr form)) + form)) + form)) + (defun note-source-path (form &rest arguments) (when (source-form-has-path-p form) (setf (gethash form *source-paths*) @@ -88,10 +100,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 +131,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 +222,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 +508,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))))) @@ -539,7 +563,8 @@ (defun ir1-convert (start next result form) (ir1-error-bailout (start next result form) (let* ((*current-path* (or (get-source-path form) - (cons form *current-path*))) + (cons (simplify-source-path-form form) + *current-path*))) (start (instrument-coverage start nil form))) (cond ((atom form) (cond ((and (symbolp form) (not (keywordp form))) @@ -594,22 +619,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,10 +727,13 @@ ;; 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))) - (if (eq res form) - (ir1-convert-common-functoid start next result form op) - (ir1-convert start next result res))) + (let ((res (careful-expand-macro cmacro-fun form t))) + (cond ((eq res form) + (ir1-convert-common-functoid start next result form op)) + (t + (unless (policy *lexenv* (zerop store-xref-data)) + (record-call cmacro-fun-name (ctran-block start) *current-path*)) + (ir1-convert start next result res)))) (ir1-convert-common-functoid start next result form op))))))) ;;; Handles the "common" cases: any other forms except special forms @@ -769,69 +788,56 @@ ;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping ;;; errors which occur during the macroexpansion. -(defun careful-expand-macro (fun form) - (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, - ;; telling something about which form caused the problem. - (wherestring () - (let ((*print-pretty* nil) - ;; We rely on the printer to abbreviate FORM. - (*print-length* 3) - (*print-level* 3)) - (format - nil - #-sb-xc-host "(in macroexpansion 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)" - form)))) - (handler-bind ((style-warning (lambda (c) - (compiler-style-warn - "~@<~A~:@_~A~@:_~A~:>" - (wherestring) hint c) - (muffle-warning-or-die))) - ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for - ;; Debian Linux, anyway) raises a CL:WARNING - ;; condition (not a CL:STYLE-WARNING) for undefined - ;; symbols when converting interpreted functions, - ;; causing COMPILE-FILE to think the file has a real - ;; problem, causing COMPILE-FILE to return FAILURE-P - ;; set (not just WARNINGS-P set). Since undefined - ;; symbol warnings are often harmless forward - ;; references, and since it'd be inordinately painful - ;; to try to eliminate all such forward references, - ;; these warnings are basically unavoidable. Thus, we - ;; need to coerce the system to work through them, - ;; and this code does so, by crudely suppressing all - ;; warnings in cross-compilation macroexpansion. -- - ;; WHN 19990412 - #+(and cmu sb-xc-host) - (warning (lambda (c) - (compiler-notify - "~@<~A~:@_~ - ~A~:@_~ - ~@<(KLUDGE: That was a non-STYLE WARNING. ~ - Ordinarily that would cause compilation to ~ - fail. However, since we're running under ~ - CMU CL, and since CMU CL emits non-STYLE ~ - warnings for safe, hard-to-fix things (e.g. ~ - references to not-yet-defined functions) ~ - we're going to have to ignore it and ~ - proceed anyway. Hopefully we're not ~ - ignoring anything horrible here..)~:@>~:>" - (wherestring) - c) - (muffle-warning-or-die))) - #-(and cmu sb-xc-host) - (warning (lambda (c) - (warn "~@<~A~:@_~A~@:_~A~:>" - (wherestring) hint c) - (muffle-warning-or-die))) - (error (lambda (c) - (compiler-error "~@<~A~:@_~A~@:_~A~:>" - (wherestring) hint c)))) - (funcall sb!xc:*macroexpand-hook* fun form *lexenv*))))) +(defun careful-expand-macro (fun form &optional cmacro) + (flet (;; Return a string to use as a prefix in error reporting, + ;; telling something about which form caused the problem. + (wherestring () + (let (;; We rely on the printer to abbreviate FORM. + (*print-length* 3) + (*print-level* 3)) + (format + nil + #-sb-xc-host "~@<~;during ~A of ~S. Use ~S to intercept:~%~:@>" + ;; longer message to avoid ambiguity "Was it the xc host + ;; or the cross-compiler which encountered the problem?" + #+sb-xc-host "~@<~;during cross-compiler ~A of ~S. Use ~S to intercept:~%~:@>" + (if cmacro "compiler-macroexpansion" "macroexpansion") + form + '*break-on-signals*)))) + (handler-bind (;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for Debian + ;; Linux, anyway) raises a CL:WARNING condition (not a + ;; CL:STYLE-WARNING) for undefined symbols when converting + ;; interpreted functions, causing COMPILE-FILE to think the + ;; file has a real problem, causing COMPILE-FILE to return + ;; FAILURE-P set (not just WARNINGS-P set). Since undefined + ;; symbol warnings are often harmless forward references, + ;; and since it'd be inordinately painful to try to + ;; eliminate all such forward references, these warnings + ;; are basically unavoidable. Thus, we need to coerce the + ;; system to work through them, and this code does so, by + ;; crudely suppressing all warnings in cross-compilation + ;; macroexpansion. -- WHN 19990412 + #+(and cmu sb-xc-host) + (warning (lambda (c) + (compiler-notify + "~@<~A~:@_~ + ~A~:@_~ + ~@<(KLUDGE: That was a non-STYLE WARNING. ~ + Ordinarily that would cause compilation to ~ + fail. However, since we're running under ~ + CMU CL, and since CMU CL emits non-STYLE ~ + warnings for safe, hard-to-fix things (e.g. ~ + references to not-yet-defined functions) ~ + we're going to have to ignore it and ~ + proceed anyway. Hopefully we're not ~ + ignoring anything horrible here..)~:@>~:>" + (wherestring) + c) + (muffle-warning-or-die))) + (error (lambda (c) + (compiler-error "~@<~A~@:_ ~A~:>" + (wherestring) c)))) + (funcall sb!xc:*macroexpand-hook* fun form *lexenv*)))) ;;;; conversion utilities @@ -1021,14 +1027,16 @@ (defined-fun-inlinep var)))) (if (eq inlinep :notinline) (ir1-convert-combination start next result form var) - (let ((transform (info :function - :source-transform - (leaf-source-name var)))) + (let* ((name (leaf-source-name var)) + (transform (info :function :source-transform name))) (if transform (multiple-value-bind (transformed pass) (funcall transform form) - (if pass - (ir1-convert-maybe-predicate start next result form var) - (ir1-convert start next result transformed))) + (cond (pass + (ir1-convert-maybe-predicate start next result form var)) + (t + (unless (policy *lexenv* (zerop store-xref-data)) + (record-call name (ctran-block start) *current-path*)) + (ir1-convert start next result transformed)))) (ir1-convert-maybe-predicate start next result form var)))))) ;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE @@ -1074,9 +1082,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))) @@ -1326,26 +1333,41 @@ (dolist (name (rest spec)) (let ((var (find-in-bindings-or-fbindings name vars fvars))) (cond - ((not var) - ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" - ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warn "declaring unknown variable ~S to be ignored" - name)) - ;; FIXME: This special case looks like non-ANSI weirdness. - ((and (consp var) (eq (car var) 'macro)) - ;; Just ignore the IGNORE decl. - ) - ((functional-p var) - (setf (leaf-ever-used var) t)) - ((and (lambda-var-specvar var) (eq (first spec) 'ignore)) - ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" - ;; requires that this be a STYLE-WARNING, not a full WARNING. - (compiler-style-warn "declaring special variable ~S to be ignored" - name)) - ((eq (first spec) 'ignorable) - (setf (leaf-ever-used var) t)) - (t - (setf (lambda-var-ignorep var) t))))) + ((not var) + ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" + ;; requires that this be a STYLE-WARNING, not a full WARNING. + (multiple-value-call #'compiler-style-warn + "~A declaration for ~A: ~A" + (first spec) + (if (symbolp name) + (values + (case (info :variable :kind name) + (:special "a special variable") + (:global "a global lexical variable") + (:alien "a global alien variable") + (t "an unknown variable")) + name) + (values + (if (info :function :kind (second name)) + "a global function" + "an unknown function") + (second name))))) + ((and (consp var) (eq (car var) 'macro)) + ;; Just ignore the IGNORE decl: we don't currently signal style-warnings + ;; for unused symbol-macros, so there's no need to do anything. + ) + ((functional-p var) + (setf (leaf-ever-used var) t)) + ((and (lambda-var-specvar var) (eq (first spec) 'ignore)) + ;; ANSI's definition for "Declaration IGNORE, IGNORABLE" + ;; requires that this be a STYLE-WARNING, not a full WARNING. + (compiler-style-warn "Declaring special variable ~S to be ~A" + name + (first spec))) + ((eq (first spec) 'ignorable) + (setf (leaf-ever-used var) t)) + (t + (setf (lambda-var-ignorep var) t))))) (values)) (defun process-dx-decl (names vars fvars kind)