X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=b05f9c380f056e310db689fd51b9bf17edfc9cd1;hb=2372ff8da6e1099e8840b0815d75c414fff2f302;hp=a46f8ad3672b7ed411a2e48b601a9d23d423de18;hpb=eda188832e16afa22cfdb274184d08d3228f9504;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index a46f8ad..b05f9c3 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))) @@ -315,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 @@ -531,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 @@ -560,11 +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 (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 +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) @@ -677,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)) @@ -727,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 @@ -758,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) @@ -795,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 @@ -834,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 @@ -951,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) @@ -1197,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) @@ -1318,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. @@ -1370,13 +1400,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) @@ -1387,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 @@ -1411,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 ~ @@ -1424,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))))) @@ -1479,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