diff --git a/NEWS b/NEWS index 6dc2a2190..cb40775ee 100644 --- a/NEWS +++ b/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 diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index a9fbe7c62..90a1e551a 100644 --- a/src/code/cross-misc.lisp +++ b/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. diff --git a/src/code/macros.lisp b/src/code/macros.lisp index e162b36a9..54ec2c677 100644 --- a/src/code/macros.lisp +++ b/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. diff --git a/src/code/save.lisp b/src/code/save.lisp index 084c69c02..0b6612374 100644 --- a/src/code/save.lisp +++ b/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) diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 324620532..01941a4b0 100644 --- a/src/cold/warm.lisp +++ b/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 diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index 2bb359cec..1723ce05c 100644 --- a/src/compiler/ir1final.lisp +++ b/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 - "~@" - 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 diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 36db021b4..0b91ea032 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/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) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 90ac610e5..237648e03 100644 --- a/src/compiler/ir1tran.lisp +++ b/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. diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 8d0d0041b..6cff013ec 100644 --- a/src/compiler/node.lisp +++ b/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) diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index 5ddd434a8..c1f31ec22 100644 --- a/tests/compiler.impure-cload.lisp +++ b/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 ()