X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=b05f9c380f056e310db689fd51b9bf17edfc9cd1;hb=7f579b076a1fc54587538ead07e506e7f06f3fe8;hp=6a8bedefbfdc41099c5b7a7c2bfbffb4cc1eb040;hpb=8ae4206d774745ea928fc89a13ebf34de506aa6e;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 6a8bede..b05f9c3 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -43,6 +43,23 @@ (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*) @@ -303,7 +320,10 @@ symbol number character - string))) + 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 @@ -519,7 +539,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 @@ -548,10 +569,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 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))) @@ -641,10 +661,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) @@ -664,6 +685,8 @@ ;; processing our own code, though. #+sb-xc-host (warn "reading an ignored variable: ~S" name))) + (when (global-var-p var) + (check-deprecated-variable name)) (reference-leaf start next result var name)) (cons (aver (eq (car var) 'macro)) @@ -714,7 +737,11 @@ ;; 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 t))) + (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 @@ -745,10 +772,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) @@ -782,15 +806,16 @@ (let (;; We rely on the printer to abbreviate FORM. (*print-length* 3) (*print-level* 3)) - (format - nil - #-sb-xc-host "~@<~;during ~A of ~S. Use ~S to intercept:~%~:@>" - ;; longer message to avoid ambiguity "Was it the xc host - ;; or the cross-compiler which encountered the problem?" - #+sb-xc-host "~@<~;during cross-compiler ~A of ~S. Use ~S to intercept:~%~:@>" - (if cmacro "compiler-macroexpansion" "macroexpansion") - form - '*break-on-signals*)))) + (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 @@ -821,9 +846,18 @@ (wherestring) c) (muffle-warning-or-die))) - (error (lambda (c) - (compiler-error "~@<~A~@:_ ~A~:>" - (wherestring) c)))) + (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*)))) ;;;; conversion utilities @@ -938,12 +972,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) @@ -1184,6 +1224,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) @@ -1305,13 +1348,13 @@ ;;; 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. @@ -1320,35 +1363,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) @@ -1359,21 +1421,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 @@ -1383,7 +1447,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 ~ @@ -1396,7 +1460,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))))) @@ -1451,8 +1515,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