(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 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
(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)))))
;;; 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)
+(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,
(*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
(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
(values))
(defun process-dx-decl (names vars fvars kind)
- (flet ((maybe-notify (control &rest args)
- (when (policy *lexenv* (> speed inhibit-warnings))
- (apply #'compiler-notify control args))))
- (let ((dx (cond ((eq 'truly-dynamic-extent kind)
- :truly)
- ((and (eq 'dynamic-extent kind)
- *stack-allocate-dynamic-extent*)
- t))))
- (if dx
- (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))))
- (etypecase var
- (leaf
- (if bound-var
- (setf (leaf-dynamic-extent var) dx)
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration for free ~S"
- name)))
- (cons
- (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
- (heap-alien-info
- (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S"
- name)))))
- ((and (consp name)
- (eq (car name) 'function)
- (null (cddr name))
- (valid-function-name-p (cadr name)))
- (let* ((fname (cadr name))
- (bound-fun (find fname fvars
- :key #'leaf-source-name
- :test #'equal)))
- (etypecase bound-fun
- (leaf
- #!+stack-allocatable-closures
- (setf (leaf-dynamic-extent bound-fun) dx)
- #!-stack-allocatable-closures
- (maybe-notify
- "ignoring DYNAMIC-EXTENT declaration on a function ~S ~
- (not supported on this platform)." fname))
- (cons
- (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname))
- (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)))))
+ (let ((dx (cond ((eq 'truly-dynamic-extent kind)
+ :truly)
+ ((and (eq 'dynamic-extent kind)
+ *stack-allocate-dynamic-extent*)
+ t))))
+ (if dx
+ (dolist (name names)
+ (cond
+ ((symbolp name)
+ (let* ((bound-var (find-in-bindings vars name))
+ (var (or bound-var
+ (lexenv-find name vars)
+ (maybe-find-free-var name))))
+ (etypecase var
+ (leaf
+ (if bound-var
+ (setf (leaf-dynamic-extent var) dx)
+ (compiler-notify
+ "Ignoring free DYNAMIC-EXTENT declaration: ~S" name)))
+ (cons
+ (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+ (heap-alien-info
+ (compiler-error "DYNAMIC-EXTENT on alien-variable: ~S"
+ name))
+ (null
+ (compiler-style-warn
+ "Unbound variable declared DYNAMIC-EXTENT: ~S" name)))))
+ ((and (consp name)
+ (eq (car name) 'function)
+ (null (cddr name))
+ (valid-function-name-p (cadr name)))
+ (let* ((fname (cadr name))
+ (bound-fun (find fname fvars
+ :key #'leaf-source-name
+ :test #'equal))
+ (fun (or bound-fun (lexenv-find fname funs))))
+ (etypecase fun
+ (leaf
+ (if bound-fun
+ #!+stack-allocatable-closures
+ (setf (leaf-dynamic-extent bound-fun) dx)
+ #!-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" name))
+ (null
+ (compiler-style-warn
+ "Unbound function declared DYNAMIC-EXTENT: ~S" name)))))
+ (t
+ (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" 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.
projects / sbcl.git / blobdiff