X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=8a4cf1aa9d71f06de699bccd4dde3b50a0507c6a;hb=d6f9676ae94419cb5544c45821a8d31adbc1fbe8;hp=3ad34a64be5b95f823ca1dcf8a8ac6ba946f3422;hpb=6b9745ef7667d8f98fd4a340dcf662bc6633fd0f;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 3ad34a6..8a4cf1a 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -43,6 +43,11 @@ (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))) @@ -531,7 +536,8 @@ ;;;; 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 @@ -560,11 +566,9 @@ ;; 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 (simplify-source-path-form 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))) @@ -654,10 +658,11 @@ (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) @@ -948,12 +953,18 @@ ;;; 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) @@ -1194,6 +1205,9 @@ (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) @@ -1367,13 +1381,17 @@ (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) @@ -1384,21 +1402,23 @@ (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 @@ -1408,7 +1428,7 @@ (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 ~ @@ -1421,7 +1441,7 @@ (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))))) @@ -1476,8 +1496,8 @@ (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