Try (and fail) to reimplement "missed compiler macro" warning

There were/are limitations with the mechanism, e.g. compiling "file_a"
which could have benefited from a compiler-macro in "file_b", then
quitting and retarting lisp before compiling "file_b" should somehow warn.
This is particularly a problem for sandboxed builds where each
build executor compiles 1 file.

To do it, info about missed optimizations has to be part of the fasl.
I was able to get either the existing regression tests to pass, or the
warnings from genesis to be right, but not both. I left it where
the tests pass, but I gave up for the moment on doing it right.

If nothing else, this rectifies the poor decision of using globaldb for
the compiler's dynamic data. It meant that COMPILE on the simplest of
functions could touch a ton of GC cards for no particularly good reason,
as each mentioned symbol might accrete a new PACKED-INFO instance.

make-genesis-2.lisp

@@ -22,6 +22,46 @@
          ;; The map file is not needed by the system, but can be
          ;; 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

@@ -75,47 +75,6 @@
                 (find-symbol (string name) "COMMON-LISP")
                 name))))
 
-(when sb-c::*track-full-called-fnames*
-  (let (possibly-suspicious likely-suspicious)
-    (sb-int:call-with-each-globaldb-name
-     (lambda (name)
-       (let* ((cell (sb-int:info :function :emitted-full-calls name))
-              (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)))
-         (if (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 (cons 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 (cons 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"))))
-
 ;; 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

@@ -159,6 +159,10 @@
   ;; 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))
+
   ;; All sorts of things need INFO and/or (SETF INFO).
   (/show0 "about to SHOW-AND-CALL !GLOBALDB-COLD-INIT")
   (show-and-call !globaldb-cold-init)

src/code/defstruct.lisp

@@ -1474,7 +1474,7 @@ unless :NAMED is also specified.")))
                            accessor-name
                            (dsd-name dsd))))))))
 
-    (awhen (remove-if-not #'sb-impl::emitted-full-call-count fnames)
+    (awhen (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/load.lisp

@@ -1310,6 +1310,10 @@
                                  :plist plist))
   (values))
 
+(define-fop 125 :not-host (fop-note-full-calls (alist) nil)
+  (sb-c::accumulate-full-calls alist)
+  (values))
+
 ;;;; fops for code coverage
 
 (define-fop 120 :not-host (fop-record-code-coverage (namestring cc) nil)

src/code/save.lisp

@@ -343,6 +343,7 @@ 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
   ;; Perform static linkage. Functions become un-statically-linked
   ;; on demand, for TRACE, redefinition, etc.
   #+immobile-code (sb-vm::statically-link-core)

src/compiler/dump.lisp

@@ -1477,3 +1477,21 @@
   (dump-object namestring file)
   (dump-object cc file)
   (dump-fop 'fop-record-code-coverage file))
+
+(defun dump-emitted-full-calls (hash-table fasl)
+  (let ((list (%hash-table-alist hash-table)))
+    #+sb-xc-host ; enforce host-insensitive reproducible ordering
+    (labels ((symbol< (a b)
+               (cond ((string< a b) t)
+                     ((string= a b)
+                      ;; this does find a few pairs of lookalikes
+                      (string< (cl:package-name (sb-xc:symbol-package a))
+                               (cl:package-name (sb-xc:symbol-package b))))))
+             (fname< (a b)
+               (cond ((and (atom a) (atom b)) (symbol< a b))
+                     ((atom a) t) ; symbol < list
+                     ((atom b) nil) ; opposite
+                     ((symbol< (cadr a) (cadr b))))))
+      (setq list (sort list #'fname< :key #'car)))
+    (dump-object list fasl)
+    (dump-fop 'fop-note-full-calls fasl)))

src/compiler/early-c.lisp

@@ -228,6 +228,13 @@
   (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
@@ -272,3 +279,38 @@
 ;;  "#define MEM_TO_SHADOW(mem) (((uptr)(mem)) ^ 0x500000000000ULL)"
 #+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))
+
+(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*))
+
+;; Return the number of calls to NAME that IR2 emitted as full calls,
+;; not counting calls via #'F that went untracked.
+;; Return 0 if the answer is nonzero but a warning was already signaled
+;; about any full calls were emitted. This return convention satisfies the
+;; intended use of this statistic - to decide whether to generate a warning
+;; about failure to inline NAME, which is shown at most once per name
+;; to avoid unleashing a flood of identical warnings.
+(defun emitted-full-call-count (name)
+  (let ((status (car (get-emitted-full-calls name))))
+    (and (integerp status)
+         ;; Bit 0 tells whether any call was NOT in the presence of
+         ;; a 'notinline' declaration, thus eligible to be inline.
+         ;; Bit 1 tells whether any warning was emitted yet.
+         (= (logand status 3) #b01)
+         (ash status -2)))) ; the call count as tracked by IR2
+
+(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*)
+                (logior (+ (logand existing #b11) ; old flag bits
+                           (logand status #b11))  ; new flag bits
+                        (logand existing -4)      ; old count
+                        (logand status -4))))))   ; new count

src/compiler/early-globaldb.lisp

@@ -324,7 +324,6 @@
       (:function . :assumed-type)
       (:type . :deprecated)
       (:type . :expander)
-      (:function . :emitted-full-calls)
       (:setf . :expander)
       (:type . :compiler-layout)
       (:variable . :wired-tls)

src/compiler/generic/genesis.lisp

@@ -2953,6 +2953,10 @@ Legal values for OFFSET are -4, -8, -12, ..."
   (pop-stack)
   (values))
 
+(define-cold-fop (fop-note-full-calls)
+  (sb-c::accumulate-full-calls (host-object-from-core (pop-stack)))
+  (values))
+
 ;;; Target variant of this is defined in 'target-load'
 (defun apply-fixups (code-obj fixups index count &aux (end (1- (+ index count))))
   (let ((retained-fixups (svref fixups index)))

src/compiler/globaldb.lisp

@@ -353,28 +353,6 @@
 ;;; null, we don't care.
 (define-info-type (:function :inlinep) :type-spec sb-c::inlinep)
 
-;;; Track how many times IR2 converted a call to this function as a full call
-;;; that was 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.
-(define-info-type (:function :emitted-full-calls) :type-spec list)
-
-;; Return the number of calls to NAME that IR2 emitted as full calls,
-;; not counting calls via #'F that went untracked.
-;; Return 0 if the answer is nonzero but a warning was already signaled
-;; about any full calls were emitted. This return convention satisfies the
-;; intended use of this statistic - to decide whether to generate a warning
-;; about failure to inline NAME, which is shown at most once per name
-;; to avoid unleashing a flood of identical warnings.
-(defun emitted-full-call-count (name)
-  (let ((status (car (info :function :emitted-full-calls name))))
-     (and (integerp status)
-          ;; Bit 0 tells whether any call was NOT in the presence of
-          ;; a 'notinline' declaration, thus eligible to be inline.
-          ;; Bit 1 tells whether any warning was emitted yet.
-          (= (logand status 3) #b01)
-          (ash status -2)))) ; the call count as tracked by IR2
-
 ;;; a macro-like function which transforms a call to this function
 ;;; into some other Lisp form. This expansion is inhibited if inline
 ;;; expansion is inhibited.

src/compiler/ir1report.lisp

@@ -715,7 +715,7 @@ has written, having proved that it is unreachable."))
 ;;
 (defun warn-if-compiler-macro-dependency-problem (name)
   (unless (compiler-macro-function name)
-    (let ((status (car (info :function :emitted-full-calls name)))) ; TODO use emitted-full-call-count?
+    (let ((status (car (get-emitted-full-calls name))))
       (when (and (integerp status) (oddp status))
         ;; Show the total number of calls, because otherwise the warning
         ;; would be worded rather obliquely: "N calls were compiled
@@ -734,7 +734,7 @@ has written, having proved that it is unreachable."))
 ;;
 (defun warn-if-inline-failed/proclaim (name new-inlinep)
   (when (eq new-inlinep 'inline)
-    (let ((warning-count (sb-impl::emitted-full-call-count name)))
+    (let ((warning-count (emitted-full-call-count name)))
       (when (and warning-count
                  ;; Warn only if the the compiler did not have the expansion.
                  (not (fun-name-inline-expansion name))

src/compiler/ir2tran.lisp

@@ -1321,13 +1321,13 @@
       (let* ((inlineable-p (not (let ((*lexenv* (node-lexenv node)))
                                   (fun-lexically-notinline-p fname))))
              (inlineable-bit (if inlineable-p 1 0))
-             (cell (info :function :emitted-full-calls fname)))
+             (cell (get-emitted-full-calls fname)))
         (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 (list (logior 4 inlineable-bit))
-                  (info :function :emitted-full-calls fname) cell)
+                  (get-emitted-full-calls fname) cell)
             (incf (car cell) (+ 4 (if (oddp (car cell)) 0 inlineable-bit))))
         ;; If the full call was wanted, don't record anything.
         ;; (This was originally for debugging SBCL self-compilation)

src/compiler/main.lisp

@@ -1728,6 +1728,9 @@ 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))