Fix function type clobbering in a principled way.

The test case that brought on FUNCTIONAL-TOP-LEVEL-DEFUN-P was always
a bit suspect because we've decided that by default we want to assume
functions in the same file can't be redefined, and hence the test case
should have undefined behavior. The fix introducing
FUNCTIONAL-TOP-LEVEL-DEFUN-P (9cb20dfbaa)
was also just wrong because it broke another test case that was
basically the inverse of the original test case. So we
extend *DERIVE-FUNCTION-TYPES* to actually be able to handle the case
when people want the full ability to do function redefinition, and
leave *DERIVE-FUNCTION-TYPES* to :SAME-FILE (a new keyword) by
default, which matches the status quo behavior.

This area of the compiler could probably use some clean up, since it
seems in many places we were two minds when it came to how much of the
early binding in the same file we actually wanted to expose type-wise
in the compiler.

NEWS

@@ -1,6 +1,10 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 
 changes relative to sbcl-2.2.4:
+  * slightly incompatible change: SB-EXT:*DERIVE-FUNCTION-TYPES* being NIL now
+    means that function calls will strictly only use type information from
+    proclaimed ftypes. The previous behavior (still the default) of using
+    derived type information from the same file is specified with :SAME-FILE.
   * optimization: fasl files are now usually smaller (up to 10% on default
     policy) and may load faster, especially on high debug.
   * enhancement: debug source locations now work correctly for top level forms

src/code/cross-misc.lisp

@@ -284,9 +284,6 @@
 ;;;; in lieu of #+sb-xc-host elsewere which messes up toplevel form numbers.
 (in-package "SB-C")
 
-;;; For macro lambdas that are processed by the host
-(declaim (declaration top-level-form))
-
 ;;; The opposite of *undefined-fun-allowlist* - if certain full calls
 ;;; are seen, it is probably the result of a missed transform and/or
 ;;; misconfiguration.

src/code/macros.lisp

@@ -121,7 +121,6 @@ tree structure resulting from the evaluation of EXPRESSION."
            (lambda-guts `(,@decls (block ,(fun-name-block-name name) ,@forms)))
            (lambda `(lambda ,lambda-list ,@lambda-guts))
            (named-lambda `(named-lambda ,name ,lambda-list
-                           ,@(when *top-level-form-p* '((declare (sb-c::top-level-form))))
                            ,@(when doc (list doc)) ,@lambda-guts))
            ;; DXABLE-ARGS and SNIPPET are mutually exclusive, so we can sleazily pass
            ;; whichever exists (if either does) as one parameter to %DEFUN.

src/code/save.lisp

@@ -81,7 +81,7 @@
        sb-kernel::*gc-epoch*))
 
 (defun start-lisp (toplevel callable-exports)
-  (named-lambda start-lisp ()
+  (named-lambda %start-lisp ()
     (cond (callable-exports
            (reinit t)
            (dolist (export callable-exports)

src/cold/warm.lisp

@@ -165,8 +165,9 @@ sb-kernel::(rplaca (last *handler-clusters*) (car **initial-handler-clusters**))
                      ((t)
                       (let ((sb-c::*source-namestring* fullname)
                             (sb-ext:*derive-function-types*
-                              (unless (search "/pcl/" stem)
-                                t)))
+                              (if (search "/pcl/" stem)
+                                  :same-file
+                                  t)))
                         (ensure-directories-exist output)
                         ;; Like PROCLAIM-TARGET-OPTIMIZATION in 'compile-cold-sbcl'
                         ;; We should probably stash a copy of the POLICY instance from

src/compiler/ir1final.lisp

@@ -57,45 +57,48 @@
 ;;; possibility that new references might be converted to it.
 (defun finalize-xep-definition (fun)
   (let* ((leaf (functional-entry-fun fun))
+         (source-name (and (leaf-has-source-name-p leaf)
+                           (leaf-source-name leaf)))
          (ns *ir1-namespace*)
          (defined-ftype (definition-type leaf)))
     (setf (leaf-type leaf) defined-ftype)
-    (when (and (leaf-has-source-name-p leaf)
-               (eq (leaf-source-name leaf) (functional-debug-name leaf))
-               (functional-top-level-defun-p leaf))
-      (let ((source-name (leaf-source-name leaf)))
-        (let* ((where (info :function :where-from source-name))
-               (*compiler-error-context* (lambda-bind (main-entry leaf)))
-               (global-def (gethash source-name (free-funs ns)))
-               (global-p (defined-fun-p global-def)))
-          (note-name-defined source-name :function)
-          (when global-p
-            (remhash source-name (free-funs ns)))
-          (ecase where
-            (:assumed
-             (let ((approx-type (info :function :assumed-type source-name)))
-               (when (and approx-type (fun-type-p defined-ftype))
-                 (valid-approximate-type approx-type defined-ftype))
-               ;; globaldb can't enforce invariants such as :assumed-type and
-               ;; :type being mutually exclusive. For that reason it would have
-               ;; made sense to use a single info-type holding either a true
-               ;; function type or an approximate-fun-type. Regardless, it is
-               ;; slightly preferable to clear the old before setting the new.
-               (clear-info :function :assumed-type source-name)
-               (setf (info :function :type source-name) defined-ftype))
-             (setf (info :function :where-from source-name) :defined))
-            ((:declared :defined-method)
-             (let ((declared-ftype (global-ftype source-name)))
-               (unless (defined-ftype-matches-declared-ftype-p
+    (when (and source-name
+               (eq source-name (functional-debug-name leaf))
+               ;; FIXME (?): We don't know how to set the globaldb
+               ;; info for these kinds of names.
+               (not (pcl-methodfn-name-p source-name)))
+      (let* ((where (info :function :where-from source-name))
+             (*compiler-error-context* (lambda-bind (main-entry leaf)))
+             (global-def (gethash source-name (free-funs ns)))
+             (global-p (defined-fun-p global-def)))
+        (note-name-defined source-name :function)
+        (when global-p
+          (remhash source-name (free-funs ns)))
+        (ecase where
+          (:assumed
+           (let ((approx-type (info :function :assumed-type source-name)))
+             (when (and approx-type (fun-type-p defined-ftype))
+               (valid-approximate-type approx-type defined-ftype))
+             ;; globaldb can't enforce invariants such as :assumed-type and
+             ;; :type being mutually exclusive. For that reason it would have
+             ;; made sense to use a single info-type holding either a true
+             ;; function type or an approximate-fun-type. Regardless, it is
+             ;; slightly preferable to clear the old before setting the new.
+             (clear-info :function :assumed-type source-name)
+             (setf (info :function :type source-name) defined-ftype))
+           (setf (info :function :where-from source-name) :defined))
+          ((:declared :defined-method)
+           (let ((declared-ftype (global-ftype source-name)))
+             (unless (defined-ftype-matches-declared-ftype-p
                          defined-ftype declared-ftype)
-                 (compiler-style-warn
-                  "~@<The previously declared FTYPE~
+               (compiler-style-warn
+                "~@<The previously declared FTYPE~
                    ~2I ~_~/sb-impl:print-type/~I ~_~
                    conflicts with the definition type ~
                    ~2I~_~/sb-impl:print-type/~:>"
-                  declared-ftype defined-ftype))))
-            (:defined
-             (setf (info :function :type source-name) defined-ftype)))))))
+                declared-ftype defined-ftype))))
+          (:defined
+           (setf (info :function :type source-name) defined-ftype))))))
   (values))
 
 ;;; Find all calls in COMPONENT to assumed functions and update the

src/compiler/ir1tran-lambda.lisp

@@ -981,14 +981,6 @@
              (progn
                ,@forms))))))))
 
-;; FIXME: really should be an aspect of the lexical environment,
-;; but LEXENVs don't know whether they are toplevel or not.
-(defun has-toplevelness-decl (lambda-expr)
-  (dolist (expr (cddr lambda-expr)) ; Skip over (LAMBDA (ARGS))
-    (cond ((equal expr '(declare (top-level-form))) (return t))
-          ((typep expr '(or (cons (eql declare)) string))) ; DECL | DOCSTRING
-          (t (return nil)))))
-
 ;;; helper for LAMBDA-like things, to massage them into a form
 ;;; suitable for IR1-CONVERT-LAMBDA.
 (defun ir1-convert-lambdalike (thing
@@ -1015,8 +1007,6 @@
                  (info (info :function :info name)))
              (setf (functional-inlinep res) (info :function :inlinep name)
                    (defined-fun-same-block-p defined-fun-res) t)
-             (when (has-toplevelness-decl lambda-expression)
-               (setf (functional-top-level-defun-p res) t))
              ;; FIXME: Should non-entry block compiled defuns have
              ;; this propagate?
              (assert-global-function-definition-type name res)

src/compiler/ir1tran.lisp

@@ -112,12 +112,12 @@
                                  *current-path*))))
     (funcall thunk)))
 
-(defvar *derive-function-types* nil
-  "Should the compiler assume that function types will never change,
-  so that it can use type information inferred from current definitions
-  to optimize code which uses those definitions? Setting this true
-  gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
-  the efficiency of stable code.")
+(defvar *derive-function-types* :same-file
+  "If true, argument and result type information derived from
+  compilation of DEFUNs is used when compiling calls to that
+  function. If :SAME-FILE (the default, as allowed by ANSI 3.2.2.3),
+  the information is derived only from DEFUNs in the same file. If
+  false, only information from FTYPE proclamations will be used.")
 
 ;;;; namespace management utilities
 
@@ -214,10 +214,11 @@
          :type (if (or (eq where :declared)
                        (and (not latep)
                             (not notinline)
-                            *derive-function-types*))
+                            (eq *derive-function-types* t)))
                    ftype
                    (specifier-type 'function))
-         :defined-type (if (and (not latep) (not notinline))
+         :defined-type (if (and (not latep) (not notinline)
+                                *derive-function-types*)
                            ftype
                            (specifier-type 'function))
          :where-from (if notinline
@@ -1695,7 +1696,6 @@
                                       it))
                     (setq explicit-check (or (cdr spec) t)
                           allow-explicit-check nil)) ; at most one of this decl
-                   ((equal spec '(top-level-form))) ; ignore
                    ((typep spec '(cons (eql source-form)))
                     (setf source-form (cadr spec)))
                    ;; Used only for the current function.

src/compiler/node.lisp

@@ -1106,8 +1106,6 @@
   ;; True if this functional was created from an inline expansion. This
   ;; is either T, or the GLOBAL-VAR for which it is an expansion.
   (inline-expanded nil)
-  ;; Is it coming from a top-level NAMED-LAMBDA?
-  (top-level-defun-p nil)
   (ignore nil))
 
 (defun pretty-print-functional (functional stream)

tests/compiler.impure-cload.lisp

@@ -570,18 +570,37 @@
 (with-test (:name :optional-default-hairy-defconstant)
   (assert (eq (first (f)) foo-vector)))
 
-(defun non-top-level-type-clobbering ()
+(eval-when (:compile-toplevel)
+  (setq sb-ext:*derive-function-types* nil))
+
+(defun type-clobbering ()
   99)
 
 (when nil
-  (defun non-top-level-type-clobbering ()
+  (defun type-clobbering ()
     93))
 
-(defun non-top-level-type-clobbering2 ()
-  (eq (non-top-level-type-clobbering) 99))
+(defun uses-type-clobbering ()
+  (eq (type-clobbering) 99))
 
-(with-test (:name :non-top-level-type-clobbering)
-  (assert (non-top-level-type-clobbering2)))
+(with-test (:name :type-clobbering)
+  (assert (uses-type-clobbering)))
+
+(defun type-clobbering.2 ()
+  99)
+
+(when t
+  (defun type-clobbering.2 ()
+    93))
+
+(defun uses-type-clobbering.2 ()
+  (eq (type-clobbering.2) 93))
+
+(with-test (:name :type-clobbering.2)
+  (assert (uses-type-clobbering.2)))
+
+(eval-when (:compile-toplevel)
+  (setq sb-ext:*derive-function-types* :same-file))
 
 (macrolet ((x () '#(a b c d)))
   (defun constant-test-1 ()