(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*)
(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.
;; 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.
(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
(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)))))
(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)))
;;; 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)
;; 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
;;; 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*))))
\f
;;;; conversion utilities
(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
(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)))
projects / sbcl.git / blobdiff