X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=8a4cf1aa9d71f06de699bccd4dde3b50a0507c6a;hb=534ad97e08a9725fb4c9618f47602d7e83583600;hp=1dff082cd57bfe87a2c32c77dbc7fb36605de50e;hpb=ea6c9e2eb0f0a270d83e8c94c0daa934d1058f0f;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 1dff082..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) @@ -758,10 +763,7 @@ (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) @@ -951,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) @@ -1197,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) @@ -1333,35 +1344,54 @@ (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) @@ -1372,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 @@ -1396,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 ~ @@ -1409,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))))) @@ -1464,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