(when (source-form-has-path-p form)
(gethash form *source-paths*)))
+(defun ensure-source-path (form)
+ (or (get-source-path form)
+ (cons (simplify-source-path-form form)
+ *current-path*)))
+
+(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*)
context))
((:function nil)
(check-fun-name name)
- (note-if-setf-fun-and-macro name)
(let ((expansion (fun-name-inline-expansion name))
(inlinep (info :function :inlinep name)))
(setf (gethash name *free-funs*)
symbol
number
character
- string)))
+ string
+ #!+sb-simd-pack
+ #+sb-xc-host nil
+ #-sb-xc-host sb!kernel:simd-pack)))
(grovel (value)
;; Unless VALUE is an object which which obviously
;; can't contain other objects
\f
;;;; IR1-CONVERT, macroexpansion and special form dispatching
-(declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values))
+(declaim (ftype (sfunction (ctran ctran (or lvar null) t &optional t)
+ (values))
ir1-convert))
(macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
;; out of the body and converts a condition signalling form
;; the creation using backquote of forms that contain leaf
;; references, without having to introduce dummy names into the
;; namespace.
- (defun ir1-convert (start next result form)
+ (defun ir1-convert (start next result form &optional alias)
(ir1-error-bailout (start next result form)
- (let* ((*current-path* (or (get-source-path form)
- (cons form *current-path*)))
+ (let* ((*current-path* (ensure-source-path (or alias form)))
(start (instrument-coverage start nil form)))
(cond ((atom form)
(cond ((and (symbolp form) (not (keywordp form)))
(defun ir1-convert-var (start next result name)
(declare (type ctran start next) (type (or lvar null) result) (symbol name))
(let ((var (or (lexenv-find name vars) (find-free-var name))))
- (if (and (global-var-p var) (not result))
- ;; KLUDGE: If the reference is dead, convert using SYMBOL-VALUE
- ;; which is not flushable, so that unbound dead variables signal
- ;; an error (bug 412).
+ (if (and (global-var-p var) (not (info :variable :always-bound name)))
+ ;; KLUDGE: If the variable may be unbound, convert using SYMBOL-VALUE
+ ;; which is not flushable, so that unbound dead variables signal an
+ ;; error (bug 412, lp#722734): checking for null RESULT is not enough,
+ ;; since variables can become dead due to later optimizations.
(ir1-convert start next result
(if (eq (global-var-kind var) :global)
`(symbol-global-value ',name)
;; processing our own code, though.
#+sb-xc-host
(warn "reading an ignored variable: ~S" name)))
+ (when (global-var-p var)
+ (check-deprecated-variable name))
(reference-leaf start next result var name))
(cons
(aver (eq (car var) 'macro))
(defun find-compiler-macro (opname form)
(if (eq opname 'funcall)
(let ((fun-form (cadr form)))
- (cond ((and (consp fun-form) (eq 'function (car fun-form)))
+ (cond ((and (consp fun-form) (eq 'function (car fun-form))
+ (not (cddr fun-form)))
(let ((real-fun (cadr fun-form)))
(if (legal-fun-name-p real-fun)
(values (sb!xc:compiler-macro-function real-fun *lexenv*)
;; 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 t)))
+ (let ((res (handler-case
+ (careful-expand-macro cmacro-fun form t)
+ (compiler-macro-keyword-problem (c)
+ (print-compiler-message *error-output* "note: ~A" (list c))
+ form))))
(cond ((eq res form)
(ir1-convert-common-functoid start next result form op))
(t
(t
;; implicitly (LAMBDA ..) because the LAMBDA expression is
;; the CAR of an executed form.
- (ir1-convert-combination
- start next result form
- (ir1-convert-lambda op
- :debug-name (debug-name 'inline-lambda op))))))
+ (ir1-convert start next result `(%funcall ,@form)))))
;;; Convert anything that looks like a global function call.
(defun ir1-convert-global-functoid (start next result form fun)
(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*))))
+ (format nil
+ "~@<~A of ~S. Use ~S to intercept.~%~:@>"
+ (cond (cmacro
+ #-sb-xc-host "Error during compiler-macroexpansion"
+ #+sb-xc-host "Error during XC compiler-macroexpansion")
+ (t
+ #-sb-xc-host "during macroexpansion"
+ #+sb-xc-host "during XC 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
(wherestring)
c)
(muffle-warning-or-die)))
- (error (lambda (c)
- (compiler-error "~@<~A~@:_ ~A~:>"
- (wherestring) c))))
+ (error
+ (lambda (c)
+ (cond
+ (cmacro
+ ;; The spec is silent on what we should do. Signaling
+ ;; a full warning but declining to expand seems like
+ ;; a conservative and sane thing to do.
+ (compiler-warn "~@<~A~@:_ ~A~:>" (wherestring) c)
+ (return-from careful-expand-macro form))
+ (t
+ (compiler-error "~@<~A~@:_ ~A~:>"
+ (wherestring) c))))))
(funcall sb!xc:*macroexpand-hook* fun form *lexenv*))))
\f
;;;; conversion utilities
;;; instrumentation for?
(defun step-form-p (form)
(flet ((step-symbol-p (symbol)
- (not (member (symbol-package symbol)
- (load-time-value
- ;; KLUDGE: packages we're not interested in
- ;; stepping.
- (mapcar #'find-package '(sb!c sb!int sb!impl
- sb!kernel sb!pcl)))))))
+ (and (not (member (symbol-package symbol)
+ (load-time-value
+ ;; KLUDGE: packages we're not interested in
+ ;; stepping.
+ (mapcar #'find-package '(sb!c sb!int sb!impl
+ sb!kernel sb!pcl)))))
+ ;; Consistent treatment of *FOO* vs (SYMBOL-VALUE '*FOO*):
+ ;; we insert calls to SYMBOL-VALUE for most non-lexical
+ ;; variable references in order to avoid them being elided
+ ;; if the value is unused.
+ (or (not (member symbol '(symbol-value symbol-global-value)))
+ (not (constantp (second form)))))))
(and *allow-instrumenting*
(policy *lexenv* (= insert-step-conditions 3))
(listp form)
(declare (type list names fvars)
(type lexenv res))
(let ((type (compiler-specifier-type spec)))
+ (unless (csubtypep type (specifier-type 'function))
+ (compiler-style-warn "ignoring declared FTYPE: ~S (not a function type)" spec)
+ (return-from process-ftype-decl res))
(collect ((res nil cons))
(dolist (name names)
(when (fboundp name)
;;; like FIND-IN-BINDINGS, but looks for #'FOO in the FVARS
(defun find-in-bindings-or-fbindings (name vars fvars)
(declare (list vars fvars))
- (if (consp name)
- (destructuring-bind (wot fn-name) name
- (unless (eq wot 'function)
- (compiler-error "The function or variable name ~S is unrecognizable."
- name))
- (find fn-name fvars :key #'leaf-source-name :test #'equal))
- (find-in-bindings vars name)))
+ (typecase name
+ (atom
+ (find-in-bindings vars name))
+ ((cons (eql function) (cons * null))
+ (find (cadr name) fvars :key #'leaf-source-name :test #'equal))
+ (t
+ (compiler-error "Malformed function or variable name ~S." name))))
;;; Process an ignore/ignorable declaration, checking for various losing
;;; conditions.
(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)
- (let ((dx (cond ((eq 'truly-dynamic-extent kind)
- :truly)
- ((and (eq 'dynamic-extent kind)
- *stack-allocate-dynamic-extent*)
- t))))
- (if dx
+(defun process-extent-decl (names vars fvars kind)
+ (let ((extent
+ (ecase kind
+ (truly-dynamic-extent
+ :always-dynamic)
+ (dynamic-extent
+ (when *stack-allocate-dynamic-extent*
+ :maybe-dynamic))
+ (indefinite-extent
+ :indefinite))))
+ (if extent
(dolist (name names)
(cond
((symbolp name)
(etypecase var
(leaf
(if bound-var
- (setf (leaf-dynamic-extent var) dx)
+ (if (and (leaf-extent var) (neq extent (leaf-extent var)))
+ (warn "Multiple incompatible extent declarations for ~S?" name)
+ (setf (leaf-extent var) extent))
(compiler-notify
- "Ignoring free DYNAMIC-EXTENT declaration: ~S" name)))
+ "Ignoring free ~S declaration: ~S" kind name)))
(cons
- (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+ (compiler-error "~S on symbol-macro: ~S" kind name))
(heap-alien-info
- (compiler-error "DYNAMIC-EXTENT on alien-variable: ~S"
- name))
+ (compiler-error "~S on alien-variable: ~S" kind name))
(null
(compiler-style-warn
- "Unbound variable declared DYNAMIC-EXTENT: ~S" name)))))
+ "Unbound variable declared ~S: ~S" kind name)))))
((and (consp name)
(eq (car name) 'function)
(null (cddr name))
- (valid-function-name-p (cadr name)))
+ (valid-function-name-p (cadr name))
+ (neq :indefinite extent))
(let* ((fname (cadr name))
(bound-fun (find fname fvars
:key #'leaf-source-name
(leaf
(if bound-fun
#!+stack-allocatable-closures
- (setf (leaf-dynamic-extent bound-fun) dx)
+ (setf (leaf-extent bound-fun) extent)
#!-stack-allocatable-closures
(compiler-notify
"Ignoring DYNAMIC-EXTENT declaration on function ~S ~
(compiler-style-warn
"Unbound function declared DYNAMIC-EXTENT: ~S" name)))))
(t
- (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
+ (compiler-error "~S on a weird thing: ~S" kind name))))
(when (policy *lexenv* (= speed 3))
(compiler-notify "Ignoring DYNAMIC-EXTENT declarations: ~S" names)))))
(car types)
`(values ,@types)))))
res))
- ((dynamic-extent truly-dynamic-extent)
- (process-dx-decl (cdr spec) vars fvars (first spec))
+ ((dynamic-extent truly-dynamic-extent indefinite-extent)
+ (process-extent-decl (cdr spec) vars fvars (first spec))
res)
((disable-package-locks enable-package-locks)
(make-lexenv
projects / sbcl.git / blobdiff