(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*)
(eq (defined-fun-inlinep fun) :notinline)
(eq (info :function :inlinep name) :notinline))))
+;; This will get redefined in PCL boot.
+(declaim (notinline maybe-update-info-for-gf))
+(defun maybe-update-info-for-gf (name)
+ (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.
(defun find-global-fun (name latep)
;; complain about undefined functions.
(not latep))
(note-undefined-reference name :function))
- (make-global-var
- :kind :global-function
- :%source-name name
- :type (if (and (not latep)
- (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?
-;;;
-;;; In CMU CL, the answer was implicitly always true, so this
-;;; predicate didn't exist.
+ (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.
;;;
-;;; This predicate was added to fix bug 138 in SBCL. In some obscure
-;;; circumstances, it was possible for a *FREE-FUNS* entry to contain a
-;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1
-;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka
-;;; "dead") component. When this IR1 stuff was reused in a new
-;;; component, under further obscure circumstances it could be used by
+;;; This was added to fix bug 138 in SBCL. It is possible for a *FREE-FUNS*
+;;; entry to contain a DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object
+;;; contained IR1 stuff (NODEs, BLOCKs...) referring to an already compiled
+;;; (aka "dead") component. When this IR1 stuff was reused in a new component,
+;;; under further obscure circumstances it could be used by
;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for
-;;; *CURRENT-COMPONENT*. At that point things got all confused, since
-;;; IR1 conversion was sending code to a component which had already
-;;; been compiled and would never be compiled again.
-(defun invalid-free-fun-p (free-fun)
+;;; *CURRENT-COMPONENT*. At that point things got all confused, since IR1
+;;; conversion was sending code to a component which had already been compiled
+;;; and would never be compiled again.
+;;;
+;;; Note: as of 1.0.24.41 this seems to happen only in XC, and the original
+;;; BUGS entry also makes it seem like this might not be an issue at all on
+;;; target.
+(defun clear-invalid-functionals (free-fun)
;; There might be other reasons that *FREE-FUN* entries could
;; become invalid, but the only one we've been bitten by so far
;; (sbcl-0.pre7.118) is this one:
- (and (defined-fun-p free-fun)
- (let ((functional (defined-fun-functional free-fun)))
- (or (and functional
- (eql (functional-kind functional) :deleted))
- (and (lambda-p functional)
- (or
- ;; (The main reason for this first test is to bail
- ;; out early in cases where the LAMBDA-COMPONENT
- ;; call in the second test would fail because links
- ;; it needs are uninitialized or invalid.)
- ;;
- ;; If the BIND node for this LAMBDA is null, then
- ;; according to the slot comments, the LAMBDA has
- ;; been deleted or its call has been deleted. In
- ;; that case, it seems rather questionable to reuse
- ;; it, and certainly it shouldn't be necessary to
- ;; reuse it, so we cheerfully declare it invalid.
- (null (lambda-bind functional))
- ;; If this IR1 stuff belongs to a dead component,
- ;; then we can't reuse it without getting into
- ;; bizarre confusion.
- (eql (component-info (lambda-component functional))
- :dead)))))))
+ (when (defined-fun-p free-fun)
+ (setf (defined-fun-functionals free-fun)
+ (delete-if (lambda (functional)
+ (or (eq (functional-kind functional) :deleted)
+ (when (lambda-p functional)
+ (or
+ ;; (The main reason for this first test is to bail
+ ;; out early in cases where the LAMBDA-COMPONENT
+ ;; call in the second test would fail because links
+ ;; it needs are uninitialized or invalid.)
+ ;;
+ ;; If the BIND node for this LAMBDA is null, then
+ ;; according to the slot comments, the LAMBDA has
+ ;; been deleted or its call has been deleted. In
+ ;; that case, it seems rather questionable to reuse
+ ;; it, and certainly it shouldn't be necessary to
+ ;; reuse it, so we cheerfully declare it invalid.
+ (not (lambda-bind functional))
+ ;; If this IR1 stuff belongs to a dead component,
+ ;; then we can't reuse it without getting into
+ ;; bizarre confusion.
+ (eq (component-info (lambda-component functional))
+ :dead)))))
+ (defined-fun-functionals free-fun)))
+ nil))
;;; If NAME already has a valid entry in *FREE-FUNS*, then return
;;; the value. Otherwise, make a new GLOBAL-VAR using information from
(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))
- old-free-fun))
+ (when old-free-fun
+ (clear-invalid-functionals old-free-fun)
+ old-free-fun))
(ecase (info :function :kind name)
;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged.
(:macro
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*)
(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
(t
(find-free-fun name context)))))
+(defun maybe-find-free-var (name)
+ (gethash name *free-vars*))
+
;;; Return the LEAF node for a global variable reference to NAME. If
;;; NAME is already entered in *FREE-VARS*, then we just return the
;;; corresponding value. Otherwise, we make a new leaf using
(let ((kind (info :variable :kind name))
(type (info :variable :type name))
(where-from (info :variable :where-from name)))
- (when (and (eq where-from :assumed) (eq kind :global))
+ (when (eq kind :unknown)
(note-undefined-reference name :variable))
(setf (gethash name *free-vars*)
(case kind
(type (type-specifier (info :variable :type name))))
`(macro . (the ,type ,expansion))))
(:constant
- (let ((value (info :variable :constant-value name)))
- (make-constant :value value
- :%source-name name
- :type (ctype-of value)
- :where-from where-from)))
+ (let ((value (symbol-value name)))
+ ;; Override the values of standard symbols in XC,
+ ;; since we can't redefine them.
+ #+sb-xc-host
+ (when (eql (find-symbol (symbol-name name) :cl) name)
+ (multiple-value-bind (xc-value foundp)
+ (info :variable :xc-constant-value name)
+ (cond (foundp
+ (setf value xc-value))
+ ((not (eq value name))
+ (compiler-warn
+ "Using cross-compilation host's definition of ~S: ~A~%"
+ name (symbol-value name))))))
+ (find-constant value name)))
(t
(make-global-var :kind kind
:%source-name name
;;; processed with MAKE-LOAD-FORM. We have to be careful, because
;;; CONSTANT might be circular. We also check that the constant (and
;;; any subparts) are dumpable at all.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
- ;; below. -- AL 20010227
- (def!constant list-to-hash-table-threshold 32))
-(defun maybe-emit-make-load-forms (constant)
- (let ((things-processed nil)
- (count 0))
- ;; FIXME: Does this LIST-or-HASH-TABLE messiness give much benefit?
- (declare (type (or list hash-table) things-processed)
- (type (integer 0 #.(1+ list-to-hash-table-threshold)) count)
- (inline member))
- (labels ((grovel (value)
+(defun maybe-emit-make-load-forms (constant &optional (name nil namep))
+ (let ((xset (alloc-xset)))
+ (labels ((trivialp (value)
+ (typep value
+ '(or
+ #-sb-xc-host unboxed-array
+ #+sb-xc-host (simple-array (unsigned-byte 8) (*))
+ symbol
+ number
+ character
+ 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
- (unless (typep value
- '(or #-sb-xc-host unboxed-array
- #+sb-xc-host (simple-array (unsigned-byte 8) (*))
- symbol
- number
- character
- string))
- (etypecase things-processed
- (list
- (when (member value things-processed :test #'eq)
- (return-from grovel nil))
- (push value things-processed)
- (incf count)
- (when (> count list-to-hash-table-threshold)
- (let ((things things-processed))
- (setf things-processed
- (make-hash-table :test 'eq))
- (dolist (thing things)
- (setf (gethash thing things-processed) t)))))
- (hash-table
- (when (gethash value things-processed)
- (return-from grovel nil))
- (setf (gethash value things-processed) t)))
+ (unless (trivialp value)
+ (if (xset-member-p value xset)
+ (return-from grovel nil)
+ (add-to-xset value xset))
(typecase value
(cons
(grovel (car value))
((array t)
(dotimes (i (array-total-size value))
(grovel (row-major-aref value i))))
- (;; In the target SBCL, we can dump any instance,
- ;; but in the cross-compilation host,
- ;; %INSTANCE-FOO functions don't work on general
- ;; instances, only on STRUCTURE!OBJECTs.
- #+sb-xc-host structure!object
+ (#+sb-xc-host structure!object
#-sb-xc-host instance
+ ;; In the target SBCL, we can dump any instance, but
+ ;; in the cross-compilation host, %INSTANCE-FOO
+ ;; functions don't work on general instances, only on
+ ;; STRUCTURE!OBJECTs.
+ ;;
+ ;; FIXME: What about funcallable instances with
+ ;; user-defined MAKE-LOAD-FORM methods?
(when (emit-make-load-form value)
(dotimes (i (- (%instance-length value)
#+sb-xc-host 0
(compiler-error
"Objects of type ~S can't be dumped into fasl files."
(type-of value)))))))
- (grovel constant)))
+ ;; Dump all non-trivial named constants using the name.
+ (if (and namep (not (typep constant '(or symbol character
+ ;; FIXME: Cold init breaks if we
+ ;; try to reference FP constants
+ ;; thru their names.
+ #+sb-xc-host number
+ #-sb-xc-host fixnum))))
+ (emit-make-load-form constant name)
+ (grovel constant))))
(values))
\f
;;;; some flow-graph hacking utilities
(error "~S is already a predecessor of ~S." node-block block))
(push node-block (block-pred block))))
+;;; Insert NEW before OLD in the flow-graph.
+(defun insert-node-before (old new)
+ (let ((prev (node-prev old))
+ (temp (make-ctran)))
+ (ensure-block-start prev)
+ (setf (ctran-next prev) nil)
+ (link-node-to-previous-ctran new prev)
+ (use-ctran new temp)
+ (link-node-to-previous-ctran old temp))
+ (values))
+
;;; This function is used to set the ctran for a node, and thus
;;; determine what receives the value.
(defun use-lvar (node lvar)
(let* ((forms (if for-value `(,form) `(,form nil)))
(res (ir1-convert-lambda-body
forms ()
- :debug-name (debug-name 'top-level-form form))))
+ :debug-name (debug-name 'top-level-form #+sb-xc-host nil #-sb-xc-host form))))
(setf (functional-entry-fun res) res
(functional-arg-documentation res) ()
(functional-kind res) :toplevel)
(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)))))
\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)))
(values))
;; Generate a reference to a manifest constant, creating a new leaf
- ;; if necessary. If we are producing a fasl file, make sure that
- ;; MAKE-LOAD-FORM gets used on any parts of the constant that it
- ;; needs to be.
+ ;; if necessary.
(defun reference-constant (start next result value)
(declare (type ctran start next)
- (type (or lvar null) result)
- (inline find-constant))
+ (type (or lvar null) result))
(ir1-error-bailout (start next result value)
- (when (producing-fasl-file)
- (maybe-emit-make-load-forms value))
- (let* ((leaf (find-constant value))
- (res (make-ref leaf)))
- (push res (leaf-refs leaf))
- (link-node-to-previous-ctran res start)
- (use-continuation res next result)))
+ (let* ((leaf (find-constant value))
+ (res (make-ref leaf)))
+ (push res (leaf-refs leaf))
+ (link-node-to-previous-ctran res start)
+ (use-continuation res next result)))
(values)))
;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's
;;; needed. If LEAF represents a defined function which has already
;;; been converted, and is not :NOTINLINE, then reference the
;;; functional instead.
-(defun reference-leaf (start next result leaf)
+(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)
'(nil :optional)))
(maybe-reanalyze-functional leaf))
leaf))
- (ref (make-ref leaf)))
+ (ref (make-ref leaf name)))
(push ref (leaf-refs leaf))
(setf (leaf-ever-used leaf) t)
(link-node-to-previous-ctran ref start)
(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).
- (ir1-convert start next result `(symbol-value ',name))
+ (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)
+ `(symbol-value ',name)))
(etypecase var
(leaf
(when (lambda-var-p var)
;; processing our own code, though.
#+sb-xc-host
(warn "reading an ignored variable: ~S" name)))
- (reference-leaf start next result var))
+ (when (global-var-p var)
+ (check-deprecated-variable name))
+ (reference-leaf start next result var name))
(cons
(aver (eq (car var) 'macro))
;; FIXME: [Free] type declarations. -- APD, 2002-01-26
(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)))
- (if (eq res form)
- (ir1-convert-common-functoid start next result form
- op)
- (ir1-convert start next result res)))
+ (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
+ (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
(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)
;;; 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
+ "~@<~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
+ ;; 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)
+ (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
\f
;;;; code coverage
-;;; Used as the CDR of the code coverage instrumentation records
-;;; (instead of NIL) to ensure that any well-behaving user code will
-;;; not have constants EQUAL to that record. This avoids problems with
-;;; the records getting coalesced with non-record conses, which then
-;;; get mutated when the instrumentation runs. Note that it's
-;;; important for multiple records for the same location to be
-;;; coalesced. -- JES, 2008-01-02
-(defconstant +code-coverage-unmarked+ '%code-coverage-unmarked%)
-
;;; Check the policy for whether we should generate code coverage
;;; instrumentation. If not, just return the original START
;;; ctran. Otherwise insert code coverage instrumentation after
`(locally
(declare (optimize speed
(safety 0)
- (debug 0)))
+ (debug 0)
+ (check-constant-modification 0)))
;; We're being naughty here, and
;; modifying constant data. That's ok,
;; we know what we're doing.
;;; 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)
(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
(let* ((node (ir1-convert-combination start next result form var))
(fun-lvar (basic-combination-fun node))
(type (leaf-type var)))
- (when (validate-call-type node type t)
+ (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)))
(type-specifier old-type)
(type-specifier type)
var-name))))
- (bound-var (setf (leaf-type bound-var) int))
+ (bound-var
+ (setf (leaf-type bound-var) int
+ (leaf-where-from bound-var) :declared))
(t
(restr (cons var int)))))))
(process-var var bound-var)
(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)
(declare (list spec vars) (type lexenv res))
(collect ((new-venv nil cons))
(dolist (name (cdr spec))
+ ;; While CLHS seems to allow local SPECIAL declarations for constants,
+ ;; whatever the semantics are supposed to be is not at all clear to me
+ ;; -- since constants aren't allowed to be bound it should be a no-op as
+ ;; no-one can observe the difference portably, but specials are allowed
+ ;; to be bound... yet nowhere does it say that the special declaration
+ ;; removes the constantness. Call it a spec bug and prohibit it. Same
+ ;; for GLOBAL variables.
+ (let ((kind (info :variable :kind name)))
+ (unless (member kind '(:special :unknown))
+ (error "Can't declare ~(~A~) variable locally special: ~S" kind name)))
(program-assert-symbol-home-package-unlocked
context name "declaring ~A special")
(let ((var (find-in-bindings vars name)))
(when (defined-fun-p var)
(setf (defined-fun-inline-expansion res)
(defined-fun-inline-expansion var))
- (setf (defined-fun-functional res)
- (defined-fun-functional var)))
+ (setf (defined-fun-functionals res)
+ (defined-fun-functionals var)))
;; FIXME: Is this really right? Needs we not set the FUNCTIONAL
;; to the original global-var?
res))
;;; 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)
- (flet ((maybe-notify (control &rest args)
- (when (policy *lexenv* (> speed inhibit-warnings))
- (apply #'compiler-notify control args))))
- (if (policy *lexenv* (= stack-allocate-dynamic-extent 3))
+(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)
(let* ((bound-var (find-in-bindings vars name))
(var (or bound-var
(lexenv-find name vars)
- (find-free-var name))))
+ (maybe-find-free-var name))))
(etypecase var
(leaf
(if bound-var
- (setf (leaf-dynamic-extent var) t)
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration for free ~S"
- name)))
+ (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 ~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 heap-alien-info: ~S"
- name)))))
+ (compiler-error "~S on alien-variable: ~S" kind name))
+ (null
+ (compiler-style-warn
+ "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
- :test #'equal)))
- (etypecase bound-fun
+ :test #'equal))
+ (fun (or bound-fun (lexenv-find fname funs))))
+ (etypecase fun
(leaf
- #!+stack-allocatable-closures
- (setf (leaf-dynamic-extent bound-fun) t)
- #!-stack-allocatable-closures
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration on a function ~S ~
- (not supported on this platform)." fname))
+ (if bound-fun
+ #!+stack-allocatable-closures
+ (setf (leaf-extent bound-fun) extent)
+ #!-stack-allocatable-closures
+ (compiler-notify
+ "Ignoring DYNAMIC-EXTENT declaration on function ~S ~
+ (not supported on this platform)." fname)
+ (compiler-notify
+ "Ignoring free DYNAMIC-EXTENT declaration: ~S" name)))
(cons
- (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname))
+ (compiler-error "DYNAMIC-EXTENT on macro: ~S" name))
(null
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration for free ~S"
- fname)))))
- (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
- (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))
+ (compiler-style-warn
+ "Unbound function declared DYNAMIC-EXTENT: ~S" name)))))
+ (t
+ (compiler-error "~S on a weird thing: ~S" kind name))))
+ (when (policy *lexenv* (= speed 3))
+ (compiler-notify "Ignoring DYNAMIC-EXTENT declarations: ~S" names)))))
;;; FIXME: This is non-ANSI, so the default should be T, or it should
;;; go away, I think.
(car types)
`(values ,@types)))))
res))
- (dynamic-extent
- (process-dx-decl (cdr spec) vars fvars)
+ ((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
(t
(unless (info :declaration :recognized (first spec))
(compiler-warn "unrecognized declaration ~S" raw-spec))
- res))
+ (let ((fn (info :declaration :handler (first spec))))
+ (if fn
+ (funcall fn res spec vars fvars)
+ res))))
result-type)))
;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR
(*post-binding-variable-lexenv* nil))
(dolist (decl decls)
(dolist (spec (rest decl))
- (unless (consp spec)
- (compiler-error "malformed declaration specifier ~S in ~S" spec decl))
- (multiple-value-bind (new-env new-result-type)
- (process-1-decl spec lexenv vars fvars binding-form-p context)
- (setq lexenv new-env)
- (unless (eq new-result-type *wild-type*)
- (setq result-type
- (values-type-intersection result-type new-result-type))))))
+ (progv
+ ;; Kludge: EVAL calls this function to deal with LOCALLY.
+ (when (eq context :compile) (list '*current-path*))
+ (when (eq context :compile) (list (or (get-source-path spec)
+ (get-source-path decl)
+ *current-path*)))
+ (unless (consp spec)
+ (compiler-error "malformed declaration specifier ~S in ~S" spec decl))
+ (multiple-value-bind (new-env new-result-type)
+ (process-1-decl spec lexenv vars fvars binding-form-p context)
+ (setq lexenv new-env)
+ (unless (eq new-result-type *wild-type*)
+ (setq result-type
+ (values-type-intersection result-type new-result-type)))))))
(values lexenv result-type *post-binding-variable-lexenv*)))
(defun %processing-decls (decls vars fvars ctran lvar binding-form-p fun)
(check-type ctran symbol)
(check-type lvar symbol)
(let ((post-binding-lexenv-p (not (null post-binding-lexenv)))
- (post-binding-lexenv (or post-binding-lexenv (gensym))))
+ (post-binding-lexenv (or post-binding-lexenv (sb!xc:gensym "LEXENV"))))
`(%processing-decls ,decls ,vars ,fvars ,ctran ,lvar
,post-binding-lexenv-p
(lambda (,ctran ,lvar ,post-binding-lexenv)
projects / sbcl.git / blobdiff