(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
(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)
;;; 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)
;; 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))
+ (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)
;; 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)))
+ (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
(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
(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)))
(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.
(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