From: Cyrus H. <sl...@us...> - 2006-04-22 03:08:18
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5900/src/compiler Modified Files: Tag: lutex-branch target-disassem.lisp seqtran.lisp proclaim.lisp locall.lisp ir1util.lisp ir1tran.lisp ir1tran-lambda.lisp ir1-translators.lisp info-functions.lisp fndb.lisp float-tran.lisp debug-dump.lisp ctype.lisp constraint.lisp Log Message: 0.9.11.45.lutex-branch.32 * merging 0.9.11.45 changes onto the lutex branch Index: target-disassem.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/target-disassem.lisp,v retrieving revision 1.53 retrieving revision 1.53.2.1 diff -u -d -r1.53 -r1.53.2.1 --- target-disassem.lisp 7 Feb 2006 17:44:45 -0000 1.53 +++ target-disassem.lisp 22 Apr 2006 03:08:07 -0000 1.53.2.1 @@ -1957,9 +1957,9 @@ (unless (typep address 'address) (return-from maybe-note-assembler-routine nil)) (let ((name (or + (find-assembler-routine address) #!+linkage-table - (sb!sys:sap-foreign-symbol (sb!sys:int-sap address)) - (find-assembler-routine address)))) + (sb!sys:sap-foreign-symbol (sb!sys:int-sap address))))) (unless (null name) (note (lambda (stream) (if note-address-p Index: seqtran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/seqtran.lisp,v retrieving revision 1.62 retrieving revision 1.62.6.1 diff -u -d -r1.62 -r1.62.6.1 --- seqtran.lisp 14 Jul 2005 18:57:01 -0000 1.62 +++ seqtran.lisp 22 Apr 2006 03:08:07 -0000 1.62.6.1 @@ -161,7 +161,7 @@ (process-vector `(array-dimension ,into 0)))) (when found-vector-p (bindings `(length (min ,@(vector-lengths)))) - (tests `(= index length))) + (tests `(>= index length))) `(do (,@(bindings)) ((or ,@(tests)) ,result) (declare ,@(declarations)) Index: proclaim.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/proclaim.lisp,v retrieving revision 1.32 retrieving revision 1.32.6.1 diff -u -d -r1.32 -r1.32.6.1 --- proclaim.lisp 14 Jul 2005 18:57:01 -0000 1.32 +++ proclaim.lisp 22 Apr 2006 03:08:07 -0000 1.32.6.1 @@ -172,7 +172,7 @@ (dolist (name args) (unless (symbolp name) (error "can't declare a non-symbol as SPECIAL: ~S" name)) - (when (constantp name) + (when (sb!xc:constantp name) (error "can't declare a constant as SPECIAL: ~S" name)) (with-single-package-locked-error (:symbol name "globally declaring ~A special")) Index: locall.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v retrieving revision 1.73 retrieving revision 1.73.4.1 diff -u -d -r1.73 -r1.73.4.1 --- locall.lisp 16 Aug 2005 10:44:41 -0000 1.73 +++ locall.lisp 22 Apr 2006 03:08:07 -0000 1.73.4.1 @@ -274,7 +274,8 @@ ;;; do LET conversion here. (defun locall-analyze-fun-1 (fun) (declare (type functional fun)) - (let ((refs (leaf-refs fun))) + (let ((refs (leaf-refs fun)) + (local-p t)) (dolist (ref refs) (let* ((lvar (node-lvar ref)) (dest (when lvar (lvar-dest lvar)))) @@ -286,9 +287,12 @@ (convert-call-if-possible ref dest) (unless (eq (basic-combination-kind dest) :local) - (reference-entry-point ref))) + (reference-entry-point ref) + (setq local-p nil))) (t - (reference-entry-point ref))))))) + (reference-entry-point ref) + (setq local-p nil)))))) + (when local-p (note-local-functional fun))) (values)) Index: ir1util.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v retrieving revision 1.105 retrieving revision 1.105.6.1 diff -u -d -r1.105 -r1.105.6.1 --- ir1util.lisp 14 Jul 2005 18:57:00 -0000 1.105 +++ ir1util.lisp 22 Apr 2006 03:08:07 -0000 1.105.6.1 @@ -1015,6 +1015,17 @@ (values)) +(defun note-local-functional (fun) + (declare (type functional fun)) + (when (and (leaf-has-source-name-p fun) + (eq (leaf-source-name fun) (functional-debug-name fun))) + (let ((name (leaf-source-name fun))) + (let ((defined-fun (gethash name *free-funs*))) + (when (and defined-fun + (defined-fun-p defined-fun) + (eq (defined-fun-functional defined-fun) fun)) + (remhash name *free-funs*)))))) + ;;; Do stuff to delete the semantic attachments of a REF node. When ;;; this leaves zero or one reference, we do a type dispatch off of ;;; the leaf to determine if a special action is appropriate. Index: ir1tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v retrieving revision 1.140 retrieving revision 1.140.2.1 diff -u -d -r1.140 -r1.140.2.1 --- ir1tran.lisp 27 Feb 2006 11:07:31 -0000 1.140 +++ ir1tran.lisp 22 Apr 2006 03:08:07 -0000 1.140.2.1 @@ -929,15 +929,15 @@ ;;; If a LAMBDA-VAR being bound, we intersect the type with the var's ;;; type, otherwise we add a type restriction on the var. If a symbol ;;; macro, we just wrap a THE around the expansion. -(defun process-type-decl (decl res vars) +(defun process-type-decl (decl res vars context) (declare (list decl vars) (type lexenv res)) (let ((type (compiler-specifier-type (first decl)))) (collect ((restr nil cons) (new-vars nil cons)) (dolist (var-name (rest decl)) (when (boundp var-name) - (compiler-assert-symbol-home-package-unlocked - var-name "declaring the type of ~A")) + (program-assert-symbol-home-package-unlocked + context var-name "declaring the type of ~A")) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var (lexenv-find var-name vars) @@ -992,15 +992,15 @@ ;;; declarations for functions being bound, we must also deal with ;;; declarations that constrain the type of lexically apparent ;;; functions. -(defun process-ftype-decl (spec res names fvars) +(defun process-ftype-decl (spec res names fvars context) (declare (type list names fvars) (type lexenv res)) (let ((type (compiler-specifier-type spec))) (collect ((res nil cons)) (dolist (name names) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "declaring the ftype of ~A")) + (program-assert-symbol-home-package-unlocked + context name "declaring the ftype of ~A")) (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) (cond (found @@ -1020,11 +1020,12 @@ ;;; special declaration is instantiated by throwing a special variable ;;; into the variables if BINDING-FORM-P is NIL, or otherwise into ;;; *POST-BINDING-VARIABLE-LEXENV*. -(defun process-special-decl (spec res vars binding-form-p) +(defun process-special-decl (spec res vars binding-form-p context) (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) - (compiler-assert-symbol-home-package-unlocked name "declaring ~A special") + (program-assert-symbol-home-package-unlocked + context name "declaring ~A special") (let ((var (find-in-bindings vars name))) (etypecase var (cons @@ -1201,18 +1202,18 @@ ;;; Process a single declaration spec, augmenting the specified LEXENV ;;; RES. Return RES and result type. VARS and FVARS are as described ;;; PROCESS-DECLS. -(defun process-1-decl (raw-spec res vars fvars binding-form-p) +(defun process-1-decl (raw-spec res vars fvars binding-form-p context) (declare (type list raw-spec vars fvars)) (declare (type lexenv res)) (let ((spec (canonized-decl-spec raw-spec)) (result-type *wild-type*)) (values (case (first spec) - (special (process-special-decl spec res vars binding-form-p)) + (special (process-special-decl spec res vars binding-form-p context)) (ftype (unless (cdr spec) (compiler-error "no type specified in FTYPE declaration: ~S" spec)) - (process-ftype-decl (second spec) res (cddr spec) fvars)) + (process-ftype-decl (second spec) res (cddr spec) fvars context)) ((inline notinline maybe-inline) (process-inline-decl spec res fvars)) ((ignore ignorable) @@ -1233,7 +1234,7 @@ :handled-conditions (process-unmuffle-conditions-decl spec (lexenv-handled-conditions res)))) (type - (process-type-decl (cdr spec) res vars)) + (process-type-decl (cdr spec) res vars context)) (values (unless *suppress-values-declaration* (let ((types (cdr spec))) @@ -1268,8 +1269,8 @@ ;;; ;;; This is also called in main.lisp when PROCESS-FORM handles a use ;;; of LOCALLY. -(defun process-decls (decls vars fvars &key (lexenv *lexenv*) - (binding-form-p nil)) +(defun process-decls (decls vars fvars &key + (lexenv *lexenv*) (binding-form-p nil) (context :compile)) (declare (list decls vars fvars)) (let ((result-type *wild-type*) (*post-binding-variable-lexenv* nil)) @@ -1278,7 +1279,7 @@ (unless (consp spec) (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) (multiple-value-bind (new-env new-result-type) - (process-1-decl spec lexenv vars fvars binding-form-p) + (process-1-decl spec lexenv vars fvars binding-form-p context) (setq lexenv new-env) (unless (eq new-result-type *wild-type*) (setq result-type Index: ir1tran-lambda.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran-lambda.lisp,v retrieving revision 1.29 retrieving revision 1.29.2.1 diff -u -d -r1.29 -r1.29.2.1 --- ir1tran-lambda.lisp 5 Jan 2006 14:04:25 -0000 1.29 +++ ir1tran-lambda.lisp 22 Apr 2006 03:08:07 -0000 1.29.2.1 @@ -463,22 +463,27 @@ ;; problems: hidden references should not be established to ;; lambdas of kind NIL should not have (otherwise the compiler ;; might let-convert or delete them) and to variables. - (let ((name (or debug-name source-name)) - (defaults (if supplied-p (list default nil) (list default)))) + (let ((name (or debug-name source-name))) (if (or force supplied-p-p ; this entry will be of kind NIL (and (lambda-p ep) (eq (lambda-kind ep) nil))) (convert-optional-entry ep default-vars default-vals - defaults + (if supplied-p (list default nil) (list default)) name) - (delay - (register-entry-point - (convert-optional-entry (force ep) - default-vars default-vals - defaults - name) - res)))))) + (let* ((default `',(constant-form-value default)) + (defaults (if supplied-p (list default nil) (list default)))) + ;; DEFAULT can contain a reference to a + ;; to-be-optimized-away function/block/tag, so better to + ;; reduce code now (but we possibly lose syntax checking + ;; in an unreachable code). + (delay + (register-entry-point + (convert-optional-entry (force ep) + default-vars default-vals + defaults + name) + res))))))) ;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES. ;;; ENTRY-VARS and ENTRY-VALS describe the fixed arguments. REST is Index: ir1-translators.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v retrieving revision 1.71 retrieving revision 1.71.2.1 diff -u -d -r1.71 -r1.71.2.1 --- ir1-translators.lisp 27 Feb 2006 13:12:35 -0000 1.71 +++ ir1-translators.lisp 22 Apr 2006 03:08:08 -0000 1.71.2.1 @@ -284,8 +284,8 @@ (unless (symbolp name) (fail "The local macro name ~S is not a symbol." name)) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local macro")) + (program-assert-symbol-home-package-unlocked + context name "binding ~A as a local macro")) (unless (listp arglist) (fail "The local macro argument list ~S is not a list." arglist)) @@ -335,8 +335,8 @@ (unless (symbolp name) (fail "The local symbol macro name ~S is not a symbol." name)) (when (or (boundp name) (eq (info :variable :kind name) :macro)) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local symbol-macro")) + (program-assert-symbol-home-package-unlocked + context name "binding ~A as a local symbol-macro")) (let ((kind (info :variable :kind name))) (when (member kind '(:special :constant)) (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" @@ -590,8 +590,8 @@ (vals (second spec))))))) (dolist (name (names)) (when (eq (info :variable :kind name) :macro) - (compiler-assert-symbol-home-package-unlocked - name "lexically binding symbol-macro ~A"))) + (program-assert-symbol-home-package-unlocked + :compile name "lexically binding symbol-macro ~A"))) (values (vars) (vals)))) (def-ir1-translator let ((bindings &body body) start next result) @@ -683,8 +683,8 @@ (let ((name (first def))) (check-fun-name name) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local function")) + (program-assert-symbol-home-package-unlocked + :compile name "binding ~A as a local function")) (names name) (multiple-value-bind (forms decls) (parse-body (cddr def)) (defs `(lambda ,(second def) Index: info-functions.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/info-functions.lisp,v retrieving revision 1.28 retrieving revision 1.28.2.1 diff -u -d -r1.28 -r1.28.2.1 --- info-functions.lisp 27 Feb 2006 13:12:35 -0000 1.28 +++ info-functions.lisp 22 Apr 2006 03:08:08 -0000 1.28.2.1 @@ -231,8 +231,11 @@ (fun-name-block-name x)))))) (structure (typecase x - (symbol (when (eq (info :type :kind x) :instance) - (values (info :type :documentation x)))))) + (symbol (cond + ((eq (info :type :kind x) :instance) + (values (info :type :documentation x))) + ((info :typed-structure :info x) + (values (info :typed-structure :documentation x))))))) (type (typecase x (structure-class (values (info :type :documentation (class-name x)))) @@ -259,9 +262,13 @@ (case doc-type (variable (setf (info :variable :documentation name) string)) (function (setf (info :function :documentation name) string)) - (structure (if (eq (info :type :kind name) :instance) - (setf (info :type :documentation name) string) - (error "~S is not the name of a structure type." name))) + (structure (cond + ((eq (info :type :kind name) :instance) + (setf (info :type :documentation name) string)) + ((info :typed-structure :info name) + (setf (info :typed-structure :documentation name) string)) + (t + (error "~S is not a structure name." name)))) (type (setf (info :type :documentation name) string)) (setf (setf (info :setf :documentation name) string)) (t Index: fndb.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v retrieving revision 1.115 retrieving revision 1.115.2.1 diff -u -d -r1.115 -r1.115.2.1 --- fndb.lisp 5 Jan 2006 11:18:00 -0000 1.115 +++ fndb.lisp 22 Apr 2006 03:08:08 -0000 1.115.2.1 @@ -981,7 +981,7 @@ (defknown readtablep (t) boolean (movable foldable flushable)) (defknown set-syntax-from-char - (character character &optional (or readtable null) readtable) (eql t) + (character character &optional readtable (or readtable null)) (eql t) ()) (defknown set-macro-character (character callable &optional t readtable) Index: float-tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/float-tran.lisp,v retrieving revision 1.37 retrieving revision 1.37.6.1 diff -u -d -r1.37 -r1.37.6.1 --- float-tran.lisp 14 Jul 2005 18:52:38 -0000 1.37 +++ float-tran.lisp 22 Apr 2006 03:08:08 -0000 1.37.6.1 @@ -267,24 +267,30 @@ ;;; defined range. Quite useful if we want to convert some type of ;;; bounded integer into a float. (macrolet - ((frob (fun type) + ((frob (fun type most-negative most-positive) (let ((aux-name (symbolicate fun "-DERIVE-TYPE-AUX"))) `(progn - (defun ,aux-name (num) - ;; When converting a number to a float, the limits are - ;; the same. - (let* ((lo (bound-func (lambda (x) - (coerce x ',type)) - (numeric-type-low num))) - (hi (bound-func (lambda (x) - (coerce x ',type)) - (numeric-type-high num)))) - (specifier-type `(,',type ,(or lo '*) ,(or hi '*))))) + (defun ,aux-name (num) + ;; When converting a number to a float, the limits are + ;; the same. + (let* ((lo (bound-func (lambda (x) + (if (< x ,most-negative) + ,most-negative + (coerce x ',type))) + (numeric-type-low num))) + (hi (bound-func (lambda (x) + (if (< ,most-positive x ) + ,most-positive + (coerce x ',type))) + (numeric-type-high num)))) + (specifier-type `(,',type ,(or lo '*) ,(or hi '*))))) - (defoptimizer (,fun derive-type) ((num)) - (one-arg-derive-type num #',aux-name #',fun)))))) - (frob %single-float single-float) - (frob %double-float double-float)) + (defoptimizer (,fun derive-type) ((num)) + (one-arg-derive-type num #',aux-name #',fun)))))) + (frob %single-float single-float + most-negative-single-float most-positive-single-float) + (frob %double-float double-float + most-negative-double-float most-positive-double-float)) ) ; PROGN ;;;; float contagion Index: debug-dump.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/debug-dump.lisp,v retrieving revision 1.40 retrieving revision 1.40.2.1 diff -u -d -r1.40 -r1.40.2.1 --- debug-dump.lisp 7 Dec 2005 15:24:41 -0000 1.40 +++ debug-dump.lisp 22 Apr 2006 03:08:08 -0000 1.40.2.1 @@ -331,7 +331,7 @@ (declare (type index flags)) (when minimal (setq flags (logior flags compiled-debug-var-minimal-p)) - (unless tn + (unless (and tn (tn-offset tn)) (setq flags (logior flags compiled-debug-var-deleted-p)))) (when (and (or (eq kind :environment) (and (eq kind :debug-environment) @@ -349,7 +349,7 @@ (vector-push-extend name buffer) (unless (zerop id) (vector-push-extend id buffer))) - (if tn + (if (and tn (tn-offset tn)) (vector-push-extend (tn-sc-offset tn) buffer) (aver minimal)) (when save-tn Index: ctype.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ctype.lisp,v retrieving revision 1.33 retrieving revision 1.33.6.1 diff -u -d -r1.33 -r1.33.6.1 --- ctype.lisp 14 Jul 2005 18:52:37 -0000 1.33 +++ ctype.lisp 22 Apr 2006 03:08:08 -0000 1.33.6.1 @@ -632,8 +632,8 @@ ((lambda-var-arg-info arg) (let* ((info (lambda-var-arg-info arg)) (default (arg-info-default info)) - (def-type (when (constantp default) - (ctype-of (eval default))))) + (def-type (when (sb!xc:constantp default) + (ctype-of (constant-form-value default))))) (ecase (arg-info-kind info) (:keyword (let* ((key (arg-info-key info)) Index: constraint.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/constraint.lisp,v retrieving revision 1.28 retrieving revision 1.28.2.1 diff -u -d -r1.28 -r1.28.2.1 --- constraint.lisp 17 Mar 2006 17:31:30 -0000 1.28 +++ constraint.lisp 22 Apr 2006 03:08:08 -0000 1.28.2.1 @@ -310,49 +310,39 @@ (aver (eql (numeric-type-class x) 'float)) (aver (eql (numeric-type-class y) 'float)) - #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) x - #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) + #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (labels ((exclude (x) (cond ((not x) nil) (or-equal x) - (greater - (if (consp x) - (car x) - x)) (t (if (consp x) x (list x))))) (bound (x) (if greater (numeric-type-low x) (numeric-type-high x))) - (max-lower-bound (x y) - ;; Both X and Y are not null. Find the max. - (let ((res (max (type-bound-number x) (type-bound-number y)))) - ;; An open lower bound is greater than a close - ;; lower bound because the open bound doesn't - ;; contain the bound, so choose an open lower - ;; bound. - (set-bound res (or (consp x) (consp y))))) - (min-upper-bound (x y) - ;; Same as above, but for the min of upper bounds - ;; Both X and Y are not null. Find the min. - (let ((res (min (type-bound-number x) (type-bound-number y)))) - ;; An open upper bound is less than a closed - ;; upper bound because the open bound doesn't - ;; contain the bound, so choose an open lower - ;; bound. - (set-bound res (or (consp x) (consp y)))))) + (tighter-p (x ref) + (cond ((null x) nil) + ((null ref) t) + ((and or-equal + (= (type-bound-number x) (type-bound-number ref))) + ;; X is tighter if REF is not an open bound and X is + (and (not (consp ref)) (consp x))) + (greater + (< (type-bound-number ref) (type-bound-number x))) + (t + (> (type-bound-number ref) (type-bound-number x)))))) (let* ((x-bound (bound x)) (y-bound (exclude (bound y))) (new-bound (cond ((not x-bound) y-bound) ((not y-bound) x-bound) - (greater - (max-lower-bound x-bound y-bound)) + ((tighter-p y-bound x-bound) + y-bound) (t - (min-upper-bound x-bound y-bound))))) + x-bound)))) (if greater (modified-numeric-type x :low new-bound) (modified-numeric-type x :high new-bound))))) |