From 942e5de3f3e27e1cc6ae4aae69c040fa1dc7db00 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Thu, 12 Jun 2003 06:41:13 +0000 Subject: [PATCH] 0.8.0.63: * Declare return type of structure constructors; * make some FTYPE declarations to be "exact"; * GENERATE-TYPE-CHECKS prints too hairy type in the full form; * new optimization quality: INSERT-DEBUG-CATCH; * avoid using TYPE-SPECIFIER in the VALUES type deriver. --- NEWS | 9 ++++--- src/code/defstruct.lisp | 25 +++++++++++++------ src/code/typecheckfuns.lisp | 2 +- src/compiler/checkgen.lisp | 2 +- src/compiler/ctype.lisp | 2 +- src/compiler/debug.lisp | 2 +- src/compiler/early-c.lisp | 1 + src/compiler/ir1tran-lambda.lisp | 2 +- src/compiler/ir1tran.lisp | 14 +++++------ src/compiler/ir1util.lisp | 50 ++++++++++++++++++++------------------ src/compiler/knownfun.lisp | 2 +- src/compiler/policies.lisp | 6 +++++ src/compiler/srctran.lisp | 6 +---- src/compiler/sset.lisp | 16 ++++++------ version.lisp-expr | 2 +- 15 files changed, 79 insertions(+), 62 deletions(-) diff --git a/NEWS b/NEWS index 86b4d82..02d68b4 100644 --- a/NEWS +++ b/NEWS @@ -1778,14 +1778,17 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: were silently accepted). * minor incompatible change: COMPILE-FILE now uses the freedom afforded (ANSI 3.2.2.3) to use derived function types for - functions defined in the same file. This also permits the system - to warn on static type mismatches and function redefinition. + functions defined in the same file. This also permits the system + to warn on static type mismatches and function + redefinition. (Currently it does not work with high DEBUG level.) * changes in type checking closed the following bugs: ** type checking of unused values (192b, 194d, 203); ** template selection based on unsafe type assertions (192c, 236); ** type checking in branches (194bc). * VALUES declaration is disabled. - * a short form of VALUES type specifier has ANSI meaning. + * a short form of VALUES type specifier has ANSI meaning (it has + increased the number of situations when SBCL cannot perform type + checking). * fixed bug in DEFSTRUCT: once again, naming structure slots with keywords or constants is permissible. * STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE now have methods diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index e4f0119..ae83f97 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1442,17 +1442,26 @@ (unless (or defaults boas) (push (symbolicate "MAKE-" (dd-name defstruct)) defaults)) - (collect ((res)) + (collect ((res) (names)) (when defaults - (let ((cname (first defaults))) - (setf (dd-default-constructor defstruct) cname) - (res (create-keyword-constructor defstruct creator)) - (dolist (other-name (rest defaults)) - (res `(setf (fdefinition ',other-name) (fdefinition ',cname))) - (res `(declaim (ftype function ',other-name)))))) + (let ((cname (first defaults))) + (setf (dd-default-constructor defstruct) cname) + (res (create-keyword-constructor defstruct creator)) + (names cname) + (dolist (other-name (rest defaults)) + (res `(setf (fdefinition ',other-name) (fdefinition ',cname))) + (names other-name)))) (dolist (boa boas) - (res (create-boa-constructor defstruct boa creator))) + (res (create-boa-constructor defstruct boa creator)) + (names (first boa))) + + (res `(declaim (ftype + (sfunction * + ,(if (eq (dd-type defstruct) 'structure) + (dd-name defstruct) + '*)) + ,@(names)))) (res)))) diff --git a/src/code/typecheckfuns.lisp b/src/code/typecheckfuns.lisp index 9f3bee9..f8253cc 100644 --- a/src/code/typecheckfuns.lisp +++ b/src/code/typecheckfuns.lisp @@ -207,7 +207,7 @@ ;;; The name is slightly misleading, since some cases are memoized, so ;;; we might reuse a value which was made earlier instead of creating ;;; a new one from scratch. -(declaim (ftype (function (t) function) typespec-typecheckfun)) +(declaim (ftype (sfunction (t) function) typespec-typecheckfun)) (defun typespec-typecheckfun (typespec) ;; a general-purpose default case, hopefully overridden by the ;; DEFINE-COMPILER-MACRO implementation diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index e437e9b..d3d8a17 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -489,7 +489,7 @@ (when (policy cast (>= safety inhibit-warnings)) (compiler-note "type assertion too complex to check:~% ~S." - (type-specifier (cast-asserted-type cast))))) + (type-specifier (coerce-to-values (cast-asserted-type cast)))))) (setf (cast-type-to-check cast) *wild-type*) (setf (cast-%type-check cast) nil))))))) (values)) diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 3edc03b..c4dc579 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -265,7 +265,7 @@ ;;; ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct ;;; the &REST type. -(declaim (ftype (function (functional) fun-type) definition-type)) +(declaim (ftype (sfunction (functional) fun-type) definition-type)) (defun definition-type (functional) (if (lambda-p functional) (make-fun-type diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index b9b8cb3..cd549cc 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -925,7 +925,7 @@ (format stream "~S ~S" (type-of leaf) (functional-debug-name leaf))))) ;;; Attempt to find a block given some thing that has to do with it. -(declaim (ftype (function (t) cblock) block-or-lose)) +(declaim (ftype (sfunction (t) cblock) block-or-lose)) (defun block-or-lose (thing) (ctypecase thing (cblock thing) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 1faa6f8..6f2fe93 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -174,6 +174,7 @@ convention (names like *FOO*) for special variables" symbol)) ;;; FIXME: This function seems to have a lot in common with ;;; STRINGIFY-FORM, and perhaps there's some way to merge the two ;;; functions. +(declaim (ftype (sfunction (string &rest t) string) debug-namify)) (defun debug-namify (format-string &rest format-arguments) (with-standard-io-syntax (let ((*print-readably* nil) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 15943b7..be94415 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -869,7 +869,7 @@ (append aux-vars vars) nil result-cont)) (forms (if (and *allow-debug-catch-tag* - (policy *lexenv* (> debug (max speed space)))) + (policy *lexenv* (= insert-debug-catch 3))) `((catch (make-symbol "SB-DEBUG-CATCH-TAG") ,@forms)) forms)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index fd5d1a2..d2b0c96 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -141,7 +141,7 @@ ;;; names a macro or special form, then we error out using the ;;; supplied context which indicates what we were trying to do that ;;; demanded a function. -(declaim (ftype (function (t string) global-var) find-free-fun)) +(declaim (ftype (sfunction (t string) global-var) find-free-fun)) (defun find-free-fun (name context) (or (let ((old-free-fun (gethash name *free-funs*))) (and (not (invalid-free-fun-p old-free-fun)) @@ -173,7 +173,7 @@ ;;; Return the LEAF structure for the lexically apparent function ;;; definition of NAME. -(declaim (ftype (function (t string) leaf) find-lexically-apparent-fun)) +(declaim (ftype (sfunction (t string) leaf) find-lexically-apparent-fun)) (defun find-lexically-apparent-fun (name context) (let ((var (lexenv-find name funs :test #'equal))) (cond (var @@ -189,7 +189,7 @@ ;;; corresponding value. Otherwise, we make a new leaf using ;;; information from the global environment and enter it in ;;; *FREE-VARS*. If the variable is unknown, then we emit a warning. -(declaim (ftype (function (t) (or leaf cons heap-alien-info)) find-free-var)) +(declaim (ftype (sfunction (t) (or leaf cons heap-alien-info)) find-free-var)) (defun find-free-var (name) (unless (symbolp name) (compiler-error "Variable name is not a symbol: ~S." name)) @@ -461,7 +461,7 @@ ;; the creation using backquote of forms that contain leaf ;; references, without having to introduce dummy names into the ;; namespace. - (declaim (ftype (function (continuation continuation t) (values)) ir1-convert)) + (declaim (ftype (sfunction (continuation continuation t) (values)) ir1-convert)) (defun ir1-convert (start cont form) (ir1-error-bailout (start cont form) (let ((*current-path* (or (gethash form *source-paths*) @@ -730,7 +730,7 @@ ;;; Convert a bunch of forms, discarding all the values except the ;;; last. If there aren't any forms, then translate a NIL. -(declaim (ftype (function (continuation continuation list) (values)) +(declaim (ftype (sfunction (continuation continuation list) (values)) ir1-convert-progn-body)) (defun ir1-convert-progn-body (start cont body) (if (endp body) @@ -753,7 +753,7 @@ ;;; Convert a function call where the function FUN is a LEAF. FORM is ;;; the source for the call. We return the COMBINATION node so that ;;; the caller can poke at it if it wants to. -(declaim (ftype (function (continuation continuation list leaf) combination) +(declaim (ftype (sfunction (continuation continuation list leaf) combination) ir1-convert-combination)) (defun ir1-convert-combination (start cont form fun) (let ((fun-cont (make-continuation))) @@ -882,7 +882,7 @@ ;;; LAMBDA-VAR for that name, or NIL if it isn't found. We return the ;;; *last* variable with that name, since LET* bindings may be ;;; duplicated, and declarations always apply to the last. -(declaim (ftype (function (list symbol) (or lambda-var list)) +(declaim (ftype (sfunction (list symbol) (or lambda-var list)) find-in-bindings)) (defun find-in-bindings (vars name) (let ((found nil)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 19da60e..0a9d898 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -54,7 +54,7 @@ ;;;; continuation use hacking ;;; Return a list of all the nodes which use Cont. -(declaim (ftype (function (continuation) list) find-uses)) +(declaim (ftype (sfunction (continuation) list) find-uses)) (defun find-uses (cont) (ecase (continuation-kind cont) ((:block-start :deleted-block-start) @@ -77,7 +77,7 @@ ;;; Note: if you call this function, you may have to do a ;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something ;;; has changed. -(declaim (ftype (function (node) (values)) delete-continuation-use)) +(declaim (ftype (sfunction (node) (values)) delete-continuation-use)) (defun delete-continuation-use (node) (let* ((cont (node-cont node)) (block (continuation-block cont))) @@ -103,7 +103,7 @@ ;;; Note: if you call this function, you may have to do a ;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something ;;; has changed. -(declaim (ftype (function (node continuation) (values)) add-continuation-use)) +(declaim (ftype (sfunction (node continuation) (values)) add-continuation-use)) (defun add-continuation-use (node cont) (aver (not (node-cont node))) (let ((block (continuation-block cont))) @@ -366,19 +366,20 @@ (when (eq (lambda-home fun) fun) (return fun)))) +(declaim (ftype (sfunction (node) cblock) node-block)) (defun node-block (node) - (declare (type node node)) - (the cblock (continuation-block (node-prev node)))) + (continuation-block (node-prev node))) +(declaim (ftype (sfunction (node) component) node-component)) (defun node-component (node) - (declare (type node node)) (block-component (node-block node))) +(declaim (ftype (sfunction (node) physenv) node-physenv)) (defun node-physenv (node) - (declare (type node node)) - (the physenv (lambda-physenv (node-home-lambda node)))) + (lambda-physenv (node-home-lambda node))) +(declaim (ftype (sfunction (clambda) cblock) lambda-block)) (defun lambda-block (clambda) - (declare (type clambda clambda)) (node-block (lambda-bind clambda))) +(declaim (ftype (sfunction (clambda) component) lambda-component)) (defun lambda-component (clambda) (block-component (lambda-block clambda))) @@ -430,13 +431,13 @@ nil)))) ;;; Return the non-LET LAMBDA that holds BLOCK's code. +(declaim (ftype (sfunction (cblock) clambda) block-home-lambda)) (defun block-home-lambda (block) - (the clambda - (block-home-lambda-or-null block))) + (block-home-lambda-or-null block)) ;;; Return the IR1 physical environment for BLOCK. +(declaim (ftype (sfunction (cblock) physenv) block-physenv)) (defun block-physenv (block) - (declare (type cblock block)) (lambda-physenv (block-home-lambda block))) ;;; Return the Top Level Form number of PATH, i.e. the ordinal number @@ -502,9 +503,10 @@ (bug "confused about home lambda for ~S")))) ;;; Return the LAMBDA that is CONT's home. +(declaim (ftype (sfunction (continuation) clambda) + continuation-home-lambda)) (defun continuation-home-lambda (cont) - (the clambda - (continuation-home-lambda-or-null cont))) + (continuation-home-lambda-or-null cont)) #!-sb-fluid (declaim (inline continuation-single-value-p)) (defun continuation-single-value-p (cont) @@ -667,7 +669,7 @@ ;;; Unlink a block from the next/prev chain. We also null out the ;;; COMPONENT. -(declaim (ftype (function (cblock) (values)) remove-from-dfo)) +(declaim (ftype (sfunction (cblock) (values)) remove-from-dfo)) (defun remove-from-dfo (block) (let ((next (block-next block)) (prev (block-prev block))) @@ -692,7 +694,7 @@ ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for ;;; the head and tail which are set to T. -(declaim (ftype (function (component) (values)) clear-flags)) +(declaim (ftype (sfunction (component) (values)) clear-flags)) (defun clear-flags (component) (let ((head (component-head component)) (tail (component-tail component))) @@ -704,7 +706,7 @@ ;;; Make a component with no blocks in it. The BLOCK-FLAG is initially ;;; true in the head and tail blocks. -(declaim (ftype (function nil component) make-empty-component)) +(declaim (ftype (sfunction () component) make-empty-component)) (defun make-empty-component () (let* ((head (make-block-key :start nil :component nil)) (tail (make-block-key :start nil :component nil)) @@ -1490,7 +1492,7 @@ ;;;; functional hackery -(declaim (ftype (function (functional) clambda) main-entry)) +(declaim (ftype (sfunction (functional) clambda) main-entry)) (defun main-entry (functional) (etypecase functional (clambda functional) @@ -1501,7 +1503,7 @@ ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be ;;; optional with null default and no SUPPLIED-P. There must be a ;;; &REST arg with no references. -(declaim (ftype (function (functional) boolean) looks-like-an-mv-bind)) +(declaim (ftype (sfunction (functional) boolean) looks-like-an-mv-bind)) (defun looks-like-an-mv-bind (functional) (and (optional-dispatch-p functional) (do ((arg (optional-dispatch-arglist functional) (cdr arg))) @@ -1607,7 +1609,7 @@ ;;; return NIL as our second value to indicate this. NODE is used as ;;; the error context for any error message, and CONTEXT is a string ;;; that is spliced into the warning. -(declaim (ftype (function ((or symbol function) list node function string) +(declaim (ftype (sfunction ((or symbol function) list node function string) (values list boolean)) careful-call)) (defun careful-call (function args node warn-fun context) @@ -1652,7 +1654,7 @@ ;;; list of continuations ARGS. It returns the continuation if the ;;; keyword is present, or NIL otherwise. The legality and ;;; constantness of the keywords should already have been checked. -(declaim (ftype (function (list keyword) (or continuation null)) +(declaim (ftype (sfunction (list keyword) (or continuation null)) find-keyword-continuation)) (defun find-keyword-continuation (args key) (do ((arg args (cddr arg))) @@ -1663,7 +1665,7 @@ ;;; This function is used by the result of PARSE-DEFTRANSFORM to ;;; verify that alternating continuations in ARGS are constant and ;;; that there is an even number of args. -(declaim (ftype (function (list) boolean) check-key-args-constant)) +(declaim (ftype (sfunction (list) boolean) check-key-args-constant)) (defun check-key-args-constant (args) (do ((arg args (cddr arg))) ((null arg) t) @@ -1675,7 +1677,7 @@ ;;; verify that the list of continuations ARGS is a well-formed &KEY ;;; arglist and that only keywords present in the list KEYS are ;;; supplied. -(declaim (ftype (function (list list) boolean) check-transform-keys)) +(declaim (ftype (sfunction (list list) boolean) check-transform-keys)) (defun check-transform-keys (args keys) (and (check-key-args-constant args) (do ((arg args (cddr arg))) @@ -1686,7 +1688,7 @@ ;;;; miscellaneous ;;; Called by the expansion of the EVENT macro. -(declaim (ftype (function (event-info (or node null)) *) %event)) +(declaim (ftype (sfunction (event-info (or node null)) *) %event)) (defun %event (info node) (incf (event-info-count info)) (when (and (>= (event-info-level info) *event-note-threshold*) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 86f4b85..e47a03a 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -208,7 +208,7 @@ ;;; shared, we copy it. We don't have to copy the lists, since each ;;; function that has generators or transforms has already been ;;; through here. -(declaim (ftype (function (t) fun-info) fun-info-or-lose)) +(declaim (ftype (sfunction (t) fun-info) fun-info-or-lose)) (defun fun-info-or-lose (name) (let (;; FIXME: Do we need this rebinding here? It's a literal ;; translation of the old CMU CL rebinding to diff --git a/src/compiler/policies.lisp b/src/compiler/policies.lisp index 57ffbdd..c55e3a6 100644 --- a/src/compiler/policies.lisp +++ b/src/compiler/policies.lisp @@ -37,3 +37,9 @@ 3 0) ("no" "maybe" "yes" "yes")) + +(define-optimization-quality insert-debug-catch + (if (> debug (max speed space)) + 3 + 0) + ("no" "maybe" "yes" "yes")) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index ac6527a..1e712f3 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2262,11 +2262,7 @@ (specifier-type 'base-char)) (defoptimizer (values derive-type) ((&rest values)) - (values-specifier-type - `(values ,@(mapcar (lambda (x) - (type-specifier (continuation-type x))) - values) - &optional))) + (make-values-type :required (mapcar #'continuation-type values))) ;;;; byte operations ;;;; diff --git a/src/compiler/sset.lisp b/src/compiler/sset.lisp index 624fa08..cbf8f47 100644 --- a/src/compiler/sset.lisp +++ b/src/compiler/sset.lisp @@ -39,7 +39,7 @@ ;;; Destructively add ELEMENT to SET. If ELEMENT was not in the set, ;;; then we return true, otherwise we return false. -(declaim (ftype (function (sset-element sset) boolean) sset-adjoin)) +(declaim (ftype (sfunction (sset-element sset) boolean) sset-adjoin)) (defun sset-adjoin (element set) (let ((number (sset-element-number element)) (elements (sset-elements set))) @@ -57,7 +57,7 @@ ;;; Destructively remove ELEMENT from SET. If element was in the set, ;;; then return true, otherwise return false. -(declaim (ftype (function (sset-element sset) boolean) sset-delete)) +(declaim (ftype (sfunction (sset-element sset) boolean) sset-delete)) (defun sset-delete (element set) (let ((elements (sset-elements set))) (do ((prev elements current) @@ -68,29 +68,29 @@ (return t))))) ;;; Return true if ELEMENT is in SET, false otherwise. -(declaim (ftype (function (sset-element sset) boolean) sset-member)) +(declaim (ftype (sfunction (sset-element sset) boolean) sset-member)) (defun sset-member (element set) (declare (inline member)) (not (null (member element (cdr (sset-elements set)) :test #'eq)))) -(declaim (ftype (function (sset sset) boolean) sset=)) +(declaim (ftype (sfunction (sset sset) boolean) sset=)) (defun sset= (set1 set2) (equal (sset-elements set1) (sset-elements set2))) ;;; Return true if SET contains no elements, false otherwise. -(declaim (ftype (function (sset) boolean) sset-empty)) +(declaim (ftype (sfunction (sset) boolean) sset-empty)) (defun sset-empty (set) (null (cdr (sset-elements set)))) ;;; Return a new copy of SET. -(declaim (ftype (function (sset) sset) copy-sset)) +(declaim (ftype (sfunction (sset) sset) copy-sset)) (defun copy-sset (set) (make-sset :elements (copy-list (sset-elements set)))) ;;; Perform the appropriate set operation on SET1 and SET2 by ;;; destructively modifying SET1. We return true if SET1 was modified, ;;; false otherwise. -(declaim (ftype (function (sset sset) boolean) sset-union sset-intersection +(declaim (ftype (sfunction (sset sset) boolean) sset-union sset-intersection sset-difference)) (defun sset-union (set1 set2) (let* ((prev-el1 (sset-elements set1)) @@ -158,7 +158,7 @@ ;;; Destructively modify SET1 to include its union with the difference ;;; of SET2 and SET3. We return true if SET1 was modified, false ;;; otherwise. -(declaim (ftype (function (sset sset sset) boolean) sset-union-of-difference)) +(declaim (ftype (sfunction (sset sset sset) boolean) sset-union-of-difference)) (defun sset-union-of-difference (set1 set2 set3) (let* ((prev-el1 (sset-elements set1)) (el1 (cdr prev-el1)) diff --git a/version.lisp-expr b/version.lisp-expr index 5835611..740c16e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.0.62" +"0.8.0.63" -- 1.7.10.4