Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler checkgen.lisp,1.33,1.34 ctype.lisp,1.23,1.24 debug.lisp,1.26,1.27 early-c.lisp,1.24,1.25 ir1tran-lambda.lisp,1.3,1.4 ir1tran.lisp,1.108,1.109 ir1util.lisp,1.64,1.65 knownfun.lisp,1.26,1.27 policies.lisp,1.1,1.2 srctran.lisp,1.65,1.66 sset.lisp,1.6,1.7
|
From: Alexey D. <ade...@us...> - 2003-06-12 06:41:17
|
Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv27149/src/compiler
Modified Files:
checkgen.lisp ctype.lisp debug.lisp early-c.lisp
ir1tran-lambda.lisp ir1tran.lisp ir1util.lisp knownfun.lisp
policies.lisp srctran.lisp sset.lisp
Log Message:
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.
Index: checkgen.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/checkgen.lisp,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -d -r1.33 -r1.34
--- checkgen.lisp 5 Jun 2003 06:24:27 -0000 1.33
+++ checkgen.lisp 12 Jun 2003 06:41:13 -0000 1.34
@@ -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))
Index: ctype.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ctype.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- ctype.lisp 7 Jun 2003 06:08:58 -0000 1.23
+++ ctype.lisp 12 Jun 2003 06:41:13 -0000 1.24
@@ -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
Index: debug.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/debug.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- debug.lisp 26 May 2003 04:25:55 -0000 1.26
+++ debug.lisp 12 Jun 2003 06:41:13 -0000 1.27
@@ -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)
Index: early-c.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/early-c.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- early-c.lisp 9 Dec 2002 11:54:49 -0000 1.24
+++ early-c.lisp 12 Jun 2003 06:41:13 -0000 1.25
@@ -174,6 +174,7 @@
;;; 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)
Index: ir1tran-lambda.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran-lambda.lisp,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- ir1tran-lambda.lisp 6 Jun 2003 09:09:14 -0000 1.3
+++ ir1tran-lambda.lisp 12 Jun 2003 06:41:13 -0000 1.4
@@ -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))
Index: ir1tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v
retrieving revision 1.108
retrieving revision 1.109
diff -u -d -r1.108 -r1.109
--- ir1tran.lisp 9 Jun 2003 16:21:18 -0000 1.108
+++ ir1tran.lisp 12 Jun 2003 06:41:13 -0000 1.109
@@ -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))
Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -d -r1.64 -r1.65
--- ir1util.lisp 11 Jun 2003 09:11:45 -0000 1.64
+++ ir1util.lisp 12 Jun 2003 06:41:13 -0000 1.65
@@ -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*)
Index: knownfun.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/knownfun.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- knownfun.lisp 31 Jan 2003 05:59:01 -0000 1.26
+++ knownfun.lisp 12 Jun 2003 06:41:14 -0000 1.27
@@ -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
Index: policies.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/policies.lisp,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- policies.lisp 29 Jan 2003 11:39:49 -0000 1.1
+++ policies.lisp 12 Jun 2003 06:41:14 -0000 1.2
@@ -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"))
Index: srctran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -d -r1.65 -r1.66
--- srctran.lisp 10 Jun 2003 11:08:12 -0000 1.65
+++ srctran.lisp 12 Jun 2003 06:41:14 -0000 1.66
@@ -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
;;;;
Index: sset.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/sset.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- sset.lisp 4 Jan 2003 10:12:45 -0000 1.6
+++ sset.lisp 12 Jun 2003 06:41:14 -0000 1.7
@@ -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))
|