Once more reimplement "missed compiler macro" warning

Scope it to the outermost compilation-unit that didn't use :OVERRIDE.
It's still inadequate but at least it doesn't hold on to all function names
thereby causing garbage to be retained.

Rev e483e8c6ce claimed that to do this correctly, the loader must participate
in determining missed optimizations, perhaps by having %define-compiler-macro
examine which fdefns (now linkage cells) were looked up.
On top of all else, I can't see how make-genesis-2 could ever have reported
anything given that the entire cross-compiler state was reset at that point.

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)

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

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
+  (setq sb-c::*compilation-unit* nil) ; its DEFVAR is not processed yet
-  ;; hash-table (because of WARN-IF-INLINE-FAILED/PROCLAIM)
-  (setf sb-c::*emitted-full-calls* (make-hash-table :test 'equal :synchronized t))
 
   ;; All sorts of things need INFO and/or (SETF INFO).
   (/show0 "about to SHOW-AND-CALL !GLOBALDB-COLD-INIT")

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

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)

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

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*
+(defstruct (compilation-unit (:conc-name cu-) (:predicate nil) (:copier nil)
-    (make-hash-table :test 'equal #-sb-xc-host :synchronized #-sb-xc-host t))
+                             (: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
+  `(awhen *compilation-unit* (gethash ,name (cu-emitted-full-calls it))))
-;; 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*))
 
 ;; 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)))
+        (let* ((table (cu-emitted-full-calls *compilation-unit*))
-          (setf (gethash name *emitted-full-calls*)
+               (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

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.

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

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))

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.
-  ;; There is one explicit NOTINLINE, but we still get a warning.
+    (assert-signal
-  (assert-signal
+     (define-compiler-macro f-with-macro (arg) `(list ,arg))
-   (define-compiler-macro f-with-macro (arg) `(list ,arg))
+     sb-c:compiler-macro-application-missed-warning)
-   sb-c:compiler-macro-application-missed-warning)
+    ;; To exercise both cases of the ~:P directive in the warning message.
-  ;; To exercise both cases of the ~:P directive in the warning message.
+    (assert-signal
-  (assert-signal
+     (define-compiler-macro f2-with-macro (a b) `(list ,a ,b))
-   (define-compiler-macro f2-with-macro (a b) `(list ,a ,b))
+     sb-c:compiler-macro-application-missed-warning)
-   sb-c:compiler-macro-application-missed-warning)
 
-  ;; There is a local notinline decl, so no warning about a compiler-macro.
+    ;; There is a local notinline decl, so no warning about a compiler-macro.
-  (assert-no-signal
+    (assert-no-signal
-    (define-compiler-macro g-with-macro (arg) `(list ,arg)))
+      (define-compiler-macro g-with-macro (arg) `(list ,arg)))
-  ;; There is a global notinline proclamation.
+    ;; There is a global notinline proclamation.
-  (assert-no-signal
+    (assert-no-signal
-    (define-compiler-macro h-with-macro (arg) `(list ,arg))))
+      (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)))
+(defun use-h (x) (list (h x) (h x)))")
-(with-test (:name :inline-failure-1)
+    (assert-signal (declaim (inline g h))
-  (assert-signal (declaim (inline g h))
+                   sb-c:inlining-dependency-failure 2)))
-                 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)
+  (with-compilation-unit ()
-                sb-c:inlining-dependency-failure))
+    (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"))