Propagate "undefined function" warnings to load-time

This is intended to supplant the concept of deferred-warnings in ASDF by
imparting the ability to the FASLoader to issue warnings about unresolved
function linkage. At last, Lisp can use a more modern paradigm of
separately compiled translation units.

LOAD is totally unchanged if you don't hook into this mechanism in user code.

src/code/linkage-space.lisp

@@ -58,9 +58,16 @@
 
 ;;; Give DESIGNATOR (a symbol, list, or fdefn) a linkage index.
 (defun ensure-linkage-index (designator
+                             &optional quiet
                              &aux (fname (if (typep designator '(or symbol fdefn))
                                              designator
                                              (find-or-create-fdefn designator))))
+  ;; The QUIET arg is for an extension to the FASLoader that discriminates between looking
+  ;; up a linkage index where the compiler did/did-not emit an "undefined" warning.
+  ;; In certain cases where a linkage-cell is referenced, the compiler will never warn,
+  ;; so neither should the loader, for example in (WHEN (FBOUNDP 'F) (FUNCALL 'F)).
+  ;; Observing the QUIET argument requires placing an encapsulation on this function.
+  (declare (ignore quiet))
   (aver designator) ; can not assign a linkage index to NIL
   ;; Optimistically assume FNAME has an index already but don't return it if the linkage cell
   ;; isn't also set, which avoids a subtle data race. Consider: Thread A sets the index in the name,

src/compiler/dump.lisp

@@ -1077,7 +1077,7 @@
     :foreign :foreign-dataref
     :code-object
     :layout :immobile-symbol
-    #+linkage-space ,@'(:linkage-cell)
+    #+linkage-space ,@'(:linkage-cell :linkage-cell-ud)
     :symbol-value
     :layout-id)
   #'equalp)

src/compiler/generic/core.lisp

@@ -70,9 +70,12 @@
                    (:foreign (foreign-symbol-address name))
                    (:foreign-dataref (foreign-symbol-address name t))
                    #+linkage-space
-                   (:linkage-cell
+                   ((:linkage-cell :linkage-cell-ud)
-                    (let ((index (ensure-linkage-index name)))
+                    (let* ((quiet (eq flavor :linkage-cell))
+                           (index (ensure-linkage-index name quiet)))
                       (unless (permanent-fname-p name) (setq callees (adjoin index callees)))
+                      ;; machine-dependent fixup doesn't want to know which flavor was used
+                      (setq flavor :linkage-cell)
                       index))
                    (:code-object (get-lisp-obj-address real-code-obj))
                    #+sb-thread (:symbol-tls-index (ensure-symbol-tls-index name))

src/compiler/generic/genesis.lisp

@@ -2929,7 +2929,8 @@ Legal values for OFFSET are -4, -8, -12, ..."
            code-obj offset
            (ecase flavor
              #+linkage-space
-             (:linkage-cell
+             ((:linkage-cell :linkage-cell-ud)
+              (setq flavor :linkage-cell) ; -ud variant is irrelevant
               (let ((i (ensure-linkage-index name)))
                 (unless (permanent-fname-p (warm-fun-name name))
                   (pushnew i callees))

src/compiler/x86-64/call.lisp

@@ -20,12 +20,42 @@
 (defconstant old-fp-passing-offset
   (make-sc+offset control-stack-sc-number ocfp-save-offset))
 
+(defun linkage-cell-fixup (name node)
+  ;; The distinction between the two linkage-cell fixups is that :linkage-cell
+  ;; never warns about undefined linkage but the "-ud" one may, after resolving
+  ;; separately-compiled fasls much the same as a standard linker, thereby liberating
+  ;; SBCL from the restriction that WITH-COMPILATION-UNIT is the only way to avoid
+  ;; style-warnings about defined-elsewhere functions. Needless to say, we must avoid
+  ;; emitting any such warnings at compile-time. Two tests are done to decide whether
+  ;; to emit the load-time warning:
+  ;; - did the compiler style-warn?  If not then don't. This covers the case
+  ;;   of (FUNCALL 'name)
+  ;; - was it lexically notinline? Even if the compiler style-warned, there should
+  ;;   not be a load-time warning if the user wanted an out-of-line call.
+  (let* ((explicit-notinline
+          (sb-c::fun-lexically-notinline-p name (sb-c::node-lexenv node)))
+         (lt-warn ; (possible) load-time warning for unresolved linkage
+          (and (not explicit-notinline)
+               ;; Optimize the predicate to FIND-IF. We can usually
+               ;; compare names by EQ except when NAME is a list.
+               (find-if (if (symbolp name)
+                            (lambda (x)
+                              (and (eq (sb-c::undefined-warning-kind x) :function)
+                                   (eq (sb-c::undefined-warning-name x) name)))
+                            (lambda (x)
+                              (and (eq (sb-c::undefined-warning-kind x) :function)
+                                   (equal (sb-c::undefined-warning-name x) name))))
+                        sb-c::*undefined-warnings*))))
+    (make-fixup name (if lt-warn
+                         :linkage-cell-ud  ; was undefined at compile-time
+                         :linkage-cell))))
+
 (defun compute-linkage-cell (node name res)
   (cond ((sb-c::code-immobile-p node)
-         (inst lea res (rip-relative-ea (make-fixup name :linkage-cell))))
+         (inst lea res (rip-relative-ea (linkage-cell-fixup name node))))
         (t
          (inst mov res (thread-slot-ea sb-vm::thread-linkage-table-slot))
-         (inst lea res (ea (make-fixup name :linkage-cell) res)))))
+         (inst lea res (ea (linkage-cell-fixup name node) res)))))
 
 ;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current
 ;;; function. We treat these specially so that the debugger can find
@@ -871,11 +901,11 @@
          ;; If step-instrumenting, then RAX points to the linkage table cell
          (inst* instruction (ea rax-tn)))
         ((sb-c::code-immobile-p node)
-         (inst* instruction (rip-relative-ea (make-fixup name :linkage-cell))))
+         (inst* instruction (rip-relative-ea (linkage-cell-fixup name node))))
         (t
          ;; get the linkage table base into RAX
          (inst mov rax-tn (thread-slot-ea sb-vm::thread-linkage-table-slot))
-         (inst* instruction (ea (make-fixup name :linkage-cell) rax-tn)))))
+         (inst* instruction (ea (linkage-cell-fixup name node) rax-tn)))))
 
 ;;; Invoke the function-designator FUN.
 (defun tail-call-unnamed (fun type vop)

tests/linkage-refs.impure.lisp

@@ -0,0 +1,35 @@
+#-x86-64 (invoke-restart 'run-tests::skip-file)
+
+(defvar *lookups* nil)
+
+(with-scratch-file (source "lisp")
+  (with-open-file (stream source :direction :output :if-does-not-exist :create)
+    (write-string "
+(defun f1 (x)
+  (declare (notinline g1))
+  (g1 x))
+
+(defun f2 (x)
+  (when (fboundp 'g2) (funcall 'g2 x)))
+
+(defun f3 (x) (g3 x))
+
+(defun f4 (x)
+  (when (fboundp 'g3) (g4 x)))" stream))
+  (let ((fasl (handler-bind ((style-warning #'muffle-warning))
+                (compile-file source))))
+    (delete-file source)
+    (sb-int:encapsulate 'sb-int:ensure-linkage-index 'trace
+       (compile nil
+        '(lambda (realfun fname &optional quiet)
+           (when (member fname '(g1 g2 g3 g4))
+             (push (cons fname quiet) *lookups*))
+           (funcall realfun fname quiet))))
+    (load fasl)
+    (delete-file fasl)
+    (sb-int:unencapsulate 'sb-int:ensure-linkage-index 'trace)
+    (assert (equal (nreverse *lookups*)
+                   '((g1 . t) ; g1 and g2 are looked up silently
+                     (g2 . t)
+                     (g3 . nil) ; g3 and g4 will check for a defined callee
+                     (g4 . nil))))))

xperfecthash61.lisp-expr

@@ -539,6 +539,12 @@
 (#(B7AF76D 21E9089F 2E6D6C2F 42D83FFB 88BDE5B2)
  "(:ALLOW-OTHER-KEYS :FLAG-TN :TEMP-TN :NODE :STACK-P)"
  "(  (& (- val (>> val 9)) 7))")
+(#(BA316CC 1FE456EC 3836DEFB 5D714507 6A1FC394 7F87FE72 8A31A1DB A2500404 A56E935B AB2C6780 B4FE847C C95BECAA E578E28F F36C4AC5)
+ "#(:ASSEMBLY-ROUTINE :CARD-TABLE-INDEX-MASK :SYMBOL-TLS-INDEX :ALIEN-CODE-LINKAGE-INDEX :ALIEN-DATA-LINKAGE-INDEX :FOREIGN :FOREIGN-DATAREF :CODE-OBJECT :LAYOUT :IMMOBILE-SYMBOL :LINKAGE-CELL :LINKAGE-CELL-UD :SYMBOL-VALUE :LAYOUT-ID)"
+ "((let ((tab #a((8) (unsigned-byte 8) 4 0 13 14 13 2 4 12)))
+  (let ((b (& (>> val 2) #x7)))
+   (let ((a (>> (<< val 5) 29)))
+    (^ a (aref tab b))))))")
 (#(BA316CC 1FE456EC 3836DEFB 5D714507 6A1FC394 7F87FE72 8A31A1DB A56E935B AB2C6780 B4FE847C C95BECAA E578E28F F36C4AC5)
  "#(:ASSEMBLY-ROUTINE :CARD-TABLE-INDEX-MASK :SYMBOL-TLS-INDEX :ALIEN-CODE-LINKAGE-INDEX :ALIEN-DATA-LINKAGE-INDEX :FOREIGN :FOREIGN-DATAREF :CODE-OBJECT :LAYOUT :IMMOBILE-SYMBOL :LINKAGE-CELL :SYMBOL-VALUE :LAYOUT-ID)"
  "((let ((tab #a((8) (unsigned-byte 8) 0 11 12 5 9 14 2 3)))

xperfecthash63.lisp-expr

@@ -779,6 +779,12 @@
 (#(B445B28 B02153B3 C6B4780F D0F360C2)
  "(NIL BASE-CHAR CHARACTER *)"
  "(  (& (>> val 7) 3) )")
+(#(BA316CC 1FE456EC 3836DEFB 5D714507 6A1FC394 7F87FE72 8A31A1DB A2500404 A56E935B AB2C6780 B4FE847C C95BECAA E578E28F F36C4AC5)
+ "#(:ASSEMBLY-ROUTINE :CARD-TABLE-INDEX-MASK :SYMBOL-TLS-INDEX :ALIEN-CODE-LINKAGE-INDEX :ALIEN-DATA-LINKAGE-INDEX :FOREIGN :FOREIGN-DATAREF :CODE-OBJECT :LAYOUT :IMMOBILE-SYMBOL :LINKAGE-CELL :LINKAGE-CELL-UD :SYMBOL-VALUE :LAYOUT-ID)"
+ "((let ((tab #a((8) (unsigned-byte 8) 4 0 13 14 13 2 4 12)))
+  (let ((b (& (>> val 2) #x7)))
+   (let ((a (>> (<< val 5) 29)))
+    (^ a (aref tab b))))))")
 (#(BA316CC 1FE456EC 3836DEFB 5D714507 6A1FC394 7F87FE72 8A31A1DB A56E935B AB2C6780 B4FE847C C95BECAA E578E28F F36C4AC5)
  "#(:ASSEMBLY-ROUTINE :CARD-TABLE-INDEX-MASK :SYMBOL-TLS-INDEX :ALIEN-CODE-LINKAGE-INDEX :ALIEN-DATA-LINKAGE-INDEX :FOREIGN :FOREIGN-DATAREF :CODE-OBJECT :LAYOUT :IMMOBILE-SYMBOL :LINKAGE-CELL :SYMBOL-VALUE :LAYOUT-ID)"
  "((let ((tab #a((8) (unsigned-byte 8) 0 11 12 5 9 14 2 3)))