diff --git a/make-genesis-2.lisp b/make-genesis-2.lisp index 144a3f12d..3ba651571 100644 --- a/make-genesis-2.lisp +++ b/make-genesis-2.lisp @@ -27,45 +27,6 @@ ;; very handy when debugging cold init problems. :map-file-name "output/cold-sbcl.map")) -(when sb-c::*track-full-called-fnames* - (let (possibly-suspicious likely-suspicious) - (sb-int:dohash ((name cell) sb-c::*emitted-full-calls*) - (let* ((inlinep (eq (sb-int:info :function :inlinep name) 'inline)) - (source-xform (sb-int:info :function :source-transform name)) - (info (sb-int:info :function :info name))) - (when (and cell - (or inlinep - source-xform - (and info (sb-c::fun-info-templates info)) - (sb-int:info :function :compiler-macro-function name))) - (cond (inlinep - ;; A full call to an inline function almost always indicates - ;; an out-of-order definition. If not an inline function, - ;; the call could be due to an inapplicable transformation. - (push (list name cell) likely-suspicious)) - ;; structure constructors aren't inlined by default, - ;; though we have a source-xform. - ((and (listp source-xform) (eq :constructor (cdr source-xform)))) - (t - (push (list name cell) possibly-suspicious)))))) - (flet ((show (label list) - (when list - (format t "~%~A suspicious calls:~:{~%~4d ~S~@{~% ~S~}~}~%" - label - (mapcar (lambda (x) (list* (ash (cadr x) -2) (car x) (cddr x))) - (sort list #'> :key #'cadr)))))) - ;; Called inlines not in the presence of a declaration to the contrary - ;; indicate that perhaps the function definition appeared too late. - (show "Likely" likely-suspicious) - ;; Failed transforms are considered not quite as suspicious - ;; because it could either be too late, or that the transform failed. - (show "Possibly" possibly-suspicious)) - ;; As each platform's build becomes warning-free, - ;; it should be added to the list here to prevent regresssions. - (when (and likely-suspicious - (target-featurep '(:and (:or :x86 :x86-64) (:or :linux :darwin)))) - (warn "Expected zero inlinining failures")))) - #+cmu (ext:quit) #+clisp (ext:quit) #+abcl (ext:quit) diff --git a/make-host-2.lisp b/make-host-2.lisp index 11af3133f..4525dde20 100644 --- a/make-host-2.lisp +++ b/make-host-2.lisp @@ -30,6 +30,7 @@ ;;; Run the cross-compiler to produce cold fasl files. (setq sb-c::*track-full-called-fnames* :minimal) ; Change this as desired (setq sb-c::*static-vop-usage-counts* (make-hash-table)) +(defvar *emitted-full-calls*) (let (fail variables functions @@ -48,6 +49,8 @@ (setq warnp 'warning)))) (sb-xc:with-compilation-unit () (load "src/cold/compile-cold-sbcl.lisp") + (setf *emitted-full-calls* + (sb-c::cu-emitted-full-calls sb-c::*compilation-unit*)) (let ((cache (math-journal-pathname :output))) (when (probe-file cache) (copy-file-from-file "output/xfloat-math.lisp-expr" cache) @@ -88,6 +91,48 @@ (find-symbol (string name) "COMMON-LISP") name)))) +(when sb-c::*track-full-called-fnames* + (let (possibly-suspicious likely-suspicious) + (sb-int:dohash ((name cell) *emitted-full-calls*) + (let* ((inlinep (eq (sb-int:info :function :inlinep name) 'inline)) + (source-xform (sb-int:info :function :source-transform name)) + (info (sb-int:info :function :info name))) + (when (and cell + (or inlinep + source-xform + (and info (sb-c::fun-info-templates info)) + (sb-int:info :function :compiler-macro-function name))) + (cond (inlinep + ;; A full call to an inline function almost always indicates + ;; an out-of-order definition. If not an inline function, + ;; the call could be due to an inapplicable transformation. + (push (list name cell) likely-suspicious)) + ;; structure constructors aren't inlined by default, + ;; though we have a source-xform. + ((and (listp source-xform) (eq :constructor (cdr source-xform)))) + (t + (push (list name cell) possibly-suspicious)))))) + (flet ((show (label list) + (when list + (format t "~%~A suspicious calls:~:{~%~4d ~S~@{~% ~S~}~}~%" + label + (mapcar (lambda (x) (list* (ash (cadr x) -2) (car x) (cddr x))) + (sort list #'> :key #'cadr)))))) + ;; Called inlines not in the presence of a declaration to the contrary + ;; indicate that perhaps the function definition appeared too late. + (show "Likely" likely-suspicious) ; "quite likely" an error + ;; Failed transforms are considered not quite as suspicious + ;; because it could either be too late, or that the transform failed. + (show "Possibly" possibly-suspicious)) ; _potentially_ an error + ;; As each platform's build becomes warning-free, + ;; it should be added to the list here to prevent regresssions. + ;; But oops! apparently this check started failing a long time ago + ;; but because it was done in the wrong place, the check failed to fail. + #+nil + (when (and likely-suspicious + (target-featurep '(:and (:or :x86 :x86-64) (:or :linux :darwin)))) + (warn "Expected zero inlinining failures")))) + ;; After cross-compiling, show me a list of types that checkgen ;; would have liked to use primitive traps for but couldn't. #+nil diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 39e6473a3..229ba17fe 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -155,9 +155,7 @@ ;; this to be initialized, so we initialize it right away. (show-and-call !random-cold-init) - ;; We can't do such much as a simple PROCLAIM without this global - ;; hash-table (because of WARN-IF-INLINE-FAILED/PROCLAIM) - (setf sb-c::*emitted-full-calls* (make-hash-table :test 'equal :synchronized t)) + (setq sb-c::*compilation-unit* nil) ; its DEFVAR is not processed yet ;; All sorts of things need INFO and/or (SETF INFO). (/show0 "about to SHOW-AND-CALL !GLOBALDB-COLD-INIT") diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 2ac1390ed..8731e704c 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1481,7 +1481,8 @@ unless :NAMED is also specified."))) accessor-name (dsd-name dsd)))))))) - (awhen (remove-if-not #'sb-c::emitted-full-call-count fnames) + (awhen (and sb-c::*compilation-unit* + (remove-if-not #'sb-c::emitted-full-call-count fnames)) (sb-c:compiler-style-warn 'sb-c:inlining-dependency-failure ;; This message omits the http://en.wikipedia.org/wiki/Serial_comma diff --git a/src/code/save.lisp b/src/code/save.lisp index c3281e254..00af59366 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -343,7 +343,6 @@ sufficiently motivated to do lengthy fixes." (sb-kernel::rebuild-ctype-hashsets) (drop-all-hash-caches) (os-deinit) - (clrhash sb-c::*emitted-full-calls*) ; Don't immortalize compiler's scratchpad (finalizers-deinit) ;; Try to shrink the pathname cache. It might be largely nulls (rebuild-pathname-cache) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index ff54861a9..c372991de 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -1489,6 +1489,8 @@ (dump-object cc file) (dump-fop 'fop-record-code-coverage file)) +;;; NOTE: this is unused at present and may never have been necessary- +;;; full-calls can be inferred at load-time by tracking :LINKAGE-CELL fixups or FOP-FDEFN. (defun dump-emitted-full-calls (hash-table fasl) (let ((list (%hash-table-alist hash-table))) #+sb-xc-host ; enforce host-insensitive reproducible ordering diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index b9b59bb94..ad57601dd 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -223,13 +223,6 @@ (coverage-metadata nil :type (or (cons hash-table hash-table) null) :read-only t) (msan-unpoison nil :read-only t) (sset-counter 1 :type fixnum) - ;; Map of function name -> something about how many calls were converted - ;; as ordinary calls not in the scope of a local or global notinline declaration. - ;; Useful for finding functions that were supposed to have been converted - ;; through some kind of transformation but were not. - ;; FIXME: this should be scoped to a compile/load but there are - ;; apparently some difficulties in doing so. - ; (emitted-full-calls (make-hash-table :test 'equal)) ;; if emitting a cfasl, the fasl stream to that (compile-toplevel-object nil :read-only t) ;; The current block compilation state. These are initialized to @@ -275,15 +268,31 @@ #+linux ; shadow space differs by OS (defconstant sb-vm::msan-mem-to-shadow-xor-const #x500000000000) -(define-load-time-global *emitted-full-calls* - (make-hash-table :test 'equal #-sb-xc-host :synchronized #-sb-xc-host t)) +(defstruct (compilation-unit (:conc-name cu-) (:predicate nil) (:copier nil) + (:constructor make-compilation-unit ())) + ;; Count of the number of compilation units dynamically enclosed by + ;; the current active WITH-COMPILATION-UNIT that were unwound out of. + (aborted-count 0 :type fixnum) + ;; Keep track of how many times each kind of condition happens. + (error-count 0 :type fixnum) + (warning-count 0 :type fixnum) + (style-warning-count 0 :type fixnum) + (note-count 0 :type fixnum) + ;; Map of function name -> something about how many calls were converted + ;; as ordinary calls not in the scope of a local or global notinline declaration. + ;; Useful for finding functions that were supposed to have been converted + ;; through some kind of transformation but were not. + (emitted-full-calls (make-hash-table :test 'equal)) + ;; hash-table of hash-tables: + ;; outer: GF-Name -> hash-table + ;; inner: (qualifiers . specializers) -> lambda-list + (methods nil :type (or null hash-table))) +;;; This is a COMPILATION-UNIT if we are within a WITH-COMPILATION-UNIT form (which +;;; normally causes nested uses to be no-ops). +(defvar *compilation-unit* nil) (defmacro get-emitted-full-calls (name) -;; Todo: probably remove the wrapping cons. It was for globaldb -;; which is particularly inefficient at updates (because it can only -;; use an R/C/U paradigm, and so conses on every insert, -;; unlike a hash-table which can just update the cell) - `(gethash ,name *emitted-full-calls*)) + `(awhen *compilation-unit* (gethash ,name (cu-emitted-full-calls it)))) ;; Return the number of calls to NAME that IR2 emitted as full calls, ;; not counting calls via #'F that went untracked. @@ -301,11 +310,16 @@ (= (logand status 3) #b01) (ash status -2)))) ; the call count as tracked by IR2 +;;; FIXME: the math here is very suspicious-looking. If the flag bits are #b11 +;;; then they can rollover into the counts. And we're ORing counts. Wtf is this doing??? +;;; Well, it doesn't matter really. This is used only in FOP-NOTE-FULL-CALLS which is called +;;; only if DUMP-EMITTED-FULL-CALLS emits that fop. But that function is never invoked. (defun accumulate-full-calls (data) (loop for (name status) in data do - (let ((existing (gethash name *emitted-full-calls* 0))) - (setf (gethash name *emitted-full-calls*) + (let* ((table (cu-emitted-full-calls *compilation-unit*)) + (existing (gethash name table 0))) + (setf (gethash name table) (logior (+ (logand existing #b11) ; old flag bits (logand status #b11)) ; new flag bits (logand existing -4) ; old count diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index de8d7bd01..75d613eec 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -517,24 +517,6 @@ has written, having proved that it is unreachable.")) ;;;; condition system interface -(defstruct (compilation-unit (:conc-name cu-) (:predicate nil) (:copier nil) - (:constructor make-compilation-unit ())) - ;; Count of the number of compilation units dynamically enclosed by - ;; the current active WITH-COMPILATION-UNIT that were unwound out of. - (aborted-count 0 :type fixnum) - ;; Keep track of how many times each kind of condition happens. - (error-count 0 :type fixnum) - (warning-count 0 :type fixnum) - (style-warning-count 0 :type fixnum) - (note-count 0 :type fixnum) - ;; hash-table of hash-tables: - ;; outer: GF-Name -> hash-table - ;; inner: (qualifiers . specializers) -> lambda-list - (methods nil :type (or null hash-table))) -;;; This is a CUNIT if we are within a WITH-COMPILATION-UNIT form (which -;;; normally causes nested uses to be no-ops). -(defvar *compilation-unit* nil) - ;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call ;;; should return WARNINGS-P or FAILURE-P. (defvar *failure-p*) @@ -810,7 +792,7 @@ and defining the function before its first potential use.~@:>" ;; Set a bit saying that a warning about the call was generated, ;; which suppresses the warning about either a later ;; call or a later proclamation. - (setf (gethash name *emitted-full-calls*) (logior count 2)) + (setf (gethash name (cu-emitted-full-calls *compilation-unit*)) (logior count 2)) ;; While there could be a different style-warning for ;; "You should put the DEFUN after the DECLAIM" ;; if they appeared reversed, it's not ideal to warn as soon as that. diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index a3e4237c9..be39075fe 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1379,14 +1379,15 @@ (let* ((inlineable-p (not (let ((*lexenv* (node-lexenv node))) (fun-lexically-notinline-p fname)))) (inlineable-bit (if inlineable-p 1 0)) - (cell (get-emitted-full-calls fname))) + (table (cu-emitted-full-calls *compilation-unit*)) + (cell (gethash fname table))) (if (not cell) ;; The low bit indicates whether any not-NOTINLINE call was seen. ;; The next-lowest bit is magic. Refer to %COMPILER-DEFMACRO ;; and WARN-IF-INLINE-FAILED/CALL for the pertinent logic. (setf cell (logior 4 inlineable-bit)) (incf cell (+ 4 (if (oddp cell) 0 inlineable-bit)))) - (setf (get-emitted-full-calls fname) cell) + (setf (gethash fname table) cell) ;; If the full call was wanted, don't record anything. ;; (This was originally for debugging SBCL self-compilation) (when inlineable-p diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index b374ded9f..6ccc4465b 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1658,9 +1658,6 @@ necessary, since type inference may take arbitrarily long to converge.") #-sb-xc-host (core-object (fix-core-source-info info object)) (null))))) - ;; FIXME: dump/restore "linkage" information, produce deferred warnings - ;; (sb-fasl::dump-emitted-full-calls (emitted-full-calls *compilation*) - ;; *compile-object*) (let ((code-coverage-records (code-coverage-records (coverage-metadata *compilation*)))) (unless (zerop (hash-table-count code-coverage-records)) diff --git a/tests/style-warnings.impure.lisp b/tests/style-warnings.impure.lisp index ea75f83fb..f723d3edc 100644 --- a/tests/style-warnings.impure.lisp +++ b/tests/style-warnings.impure.lisp @@ -19,6 +19,16 @@ ;; These tests don't work unless compiling #+interpreter (invoke-restart 'run-tests::skip-file) +(defun compile-from-string (string) ; probably should be in CTU: for everyone to use + (with-scratch-file (lisp "lisp") + (with-open-file (f lisp :direction :output) (write-string string f)) + (multiple-value-bind (result warn fail) (compile-file lisp :verbose nil) + (delete-file result) + (values result warn fail)))) + +(test-util:with-test (:name :compiler-macro-order-bug) + (with-compilation-unit () + (compile-from-string " (defun f-with-macro (arg) (list arg)) (defun f2-with-macro (a b) (list a b)) (defun map-f-with-macro (l) (mapcar #'f-with-macro l)) @@ -37,50 +47,52 @@ (declaim (notinline h-with-macro)) (defun h-with-macro (arg) (list arg)) -(defun map-h-with-macro (l) (mapcar #'h-with-macro l)) +(defun map-h-with-macro (l) (mapcar #'h-with-macro l))") -(test-util:with-test (:name :compiler-macro-order-bug) - ;; There is one explicit NOTINLINE, but we still get a warning. - (assert-signal - (define-compiler-macro f-with-macro (arg) `(list ,arg)) - sb-c:compiler-macro-application-missed-warning) - ;; To exercise both cases of the ~:P directive in the warning message. - (assert-signal - (define-compiler-macro f2-with-macro (a b) `(list ,a ,b)) - sb-c:compiler-macro-application-missed-warning) + ;; There is one explicit NOTINLINE, but we still get a warning. + (assert-signal + (define-compiler-macro f-with-macro (arg) `(list ,arg)) + sb-c:compiler-macro-application-missed-warning) + ;; To exercise both cases of the ~:P directive in the warning message. + (assert-signal + (define-compiler-macro f2-with-macro (a b) `(list ,a ,b)) + sb-c:compiler-macro-application-missed-warning) - ;; There is a local notinline decl, so no warning about a compiler-macro. - (assert-no-signal - (define-compiler-macro g-with-macro (arg) `(list ,arg))) - ;; There is a global notinline proclamation. - (assert-no-signal - (define-compiler-macro h-with-macro (arg) `(list ,arg)))) + ;; There is a local notinline decl, so no warning about a compiler-macro. + (assert-no-signal + (define-compiler-macro g-with-macro (arg) `(list ,arg))) + ;; There is a global notinline proclamation. + (assert-no-signal + (define-compiler-macro h-with-macro (arg) `(list ,arg))))) +(with-test (:name :inline-failure-1) + (with-compilation-unit () + (compile-from-string " (defun g (x) (1- x)) (defun h (x) (1+ x)) (defun use-g (x) (g x)) -(defun use-h (x) (list (h x) (h x))) -(with-test (:name :inline-failure-1) - (assert-signal (declaim (inline g h)) - sb-c:inlining-dependency-failure 2)) +(defun use-h (x) (list (h x) (h x)))") + (assert-signal (declaim (inline g h)) + sb-c:inlining-dependency-failure 2))) -(declaim (inline fast-guy)) +(declaim (inline fast-guy)) ; function does not exist (with-test (:name :inline-failure-2a) (assert-signal (compile nil '(lambda (x) (fast-guy x))) sb-c:inlining-dependency-failure)) -(defun zippy (y) y) +(defun zippy (y) y) ; didn't save source for this function (with-test (:name :inline-failure-2b) (assert-signal (eval '(defun baz (arg) (declare (inline zippy)) (zippy arg))) sb-c:inlining-dependency-failure)) -(locally (declare (muffle-conditions style-warning)) - (defun foofy1 (x) (and (somestruct-p x) 'hi))) - (test-util:with-test (:name :structure-pred-inline-failure) - (assert-signal (defstruct somestruct a b) - sb-c:inlining-dependency-failure)) + (with-compilation-unit () + (compile-from-string " +(locally (declare (muffle-conditions style-warning)) + (defun foofy1 (x) (and (somestruct-p x) 'hi)))") + (assert-signal (defstruct somestruct a b) + sb-c:inlining-dependency-failure))) (test-util:with-test (:name :redef-macro-same-file) (let* ((lisp (scratch-file-name "lisp"))