From: William Harold Newman Date: Wed, 1 Nov 2000 23:58:41 +0000 (+0000) Subject: 0.6.8.6: applied MNA megapatch (will be edited shortly) X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5eb97830eca716fef626c6e12429c99c9b97e3c8;p=sbcl.git 0.6.8.6: applied MNA megapatch (will be edited shortly) --- diff --git a/BUGS b/BUGS index ca875a7..158cbde 100644 --- a/BUGS +++ b/BUGS @@ -517,6 +517,24 @@ returning an array as first value always. confused and compiles a full call to %INSTANCE-TYPEP (which doesn't exist as a function) instead. +37a: + The %INSTANCE-TYPEP problem in bug 37 comes up also when compiling + and loading + (IN-PACKAGE :CL-USER) + (LOCALLY + (DECLARE (OPTIMIZE (SAFETY 3) (SPEED 2) (SPACE 2))) + (DECLAIM (FTYPE (FUNCTION (&REST T) (VALUES)) EMPTYVALUES)) + (DEFUN EMPTYVALUES (&REST REST) + (DECLARE (IGNORE REST)) + (VALUES)) + (DEFSTRUCT DUMMYSTRUCT X Y) + (DEFUN FROB-EMPTYVALUES (X) + (LET ((RES (EMPTYVALUES X X X))) + (UNLESS (TYPEP RES 'DUMMYSTRUCT) + 'EXPECTED-RETURN-VALUE)))) + (ASSERT (EQ (FROB-EMPTYVALUES 11) 'EXPECTED-RETURN-VALUE)) + + 38: DEFMETHOD doesn't check the syntax of &REST argument lists properly, accepting &REST even when it's not followed by an argument name: diff --git a/TODO b/TODO index c9dc3fe..e3a1964 100644 --- a/TODO +++ b/TODO @@ -1,4 +1,4 @@ -i Accumulation of half-understood design decisions eventually + Accumulation of half-understood design decisions eventually chokes a program as a water weed chokes a canal. By refactoring you can ensure that your full understanding of how the program should be designed is always reflected in the program. As a diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index eda9d8d..53ca135 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -828,7 +828,10 @@ is a good idea, but see SB-SYS for blurring of boundaries." "%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P" "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" - "%ARRAY-FILL-POINTER-P" "%ASIN" "%ASINH" + "%ARRAY-FILL-POINTER-P" + ;; MNA: open-coded-simple-array patch + "%ARRAY-SIMP" + "%ASIN" "%ASINH" "%ATAN" "%ATAN2" "%ATANH" "%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CLOSURE-FUNCTION" "%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK" @@ -912,6 +915,9 @@ is a good idea, but see SB-SYS for blurring of boundaries." "COMPLEX-RATIONAL-P" "COMPLEX-SINGLE-FLOAT-P" "COMPLEX-VECTOR-P" "CONSED-SEQUENCE" "CONSTANT" "CONSTANT-TYPE" "CONSTANT-TYPE-P" "CONSTANT-TYPE-TYPE" + ;; MNA: cons compound-type patch + ;; FIXIT: all commented out + ; "CONS-TYPE" "CONS-TYPE-CAR-TYPE" "CONS-TYPE-CDR-TYPE" "CONS-TYPE-P" "CONTAINING-INTEGER-TYPE" "CONTROL-STACK-POINTER-SAP" "COPY-FROM-SYSTEM-AREA" "COPY-NUMERIC-TYPE" "COPY-TO-SYSTEM-AREA" @@ -964,6 +970,9 @@ is a good idea, but see SB-SYS for blurring of boundaries." "LRA" "LRA-CODE-HEADER" "LRA-P" "MAKE-ALIEN-TYPE-TYPE" "MAKE-ARGS-TYPE" "MAKE-ARRAY-HEADER" "MAKE-ARRAY-TYPE" "MAKE-DOUBLE-FLOAT" + ;; MNA: cons compound-type patch + ;; FIXIT: all commented out + ; "MAKE-CONS-TYPE" "MAKE-FUNCTION-TYPE" "MAKE-KEY-INFO" "MAKE-LISP-OBJ" "MAKE-LONG-FLOAT" "MAKE-MEMBER-TYPE" "MAKE-NAMED-TYPE" diff --git a/src/code/class.lisp b/src/code/class.lisp index bd6d361..b296f48 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -1052,6 +1052,9 @@ :inherits (sequence mutable-sequence mutable-collection generic-sequence collection)) (cons + ;; MNA: cons compound-type patch + ;; FIXIT :all commented out + ; :translation cons :codes (#.sb!vm:list-pointer-type) :inherits (list sequence mutable-sequence mutable-collection diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 3c8c59d..480a778 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -224,6 +224,25 @@ (values-specifier-type-cache-clear)) (values)) + +;;; MNA: cons compound-type patch +;;; FIXIT: all commented out +;;;; Cons types: + +;;; The Cons-Type is used to represent cons types. +;;; +;; (defstruct (cons-type (:include ctype +;; (:class-info (type-class-or-lose 'cons))) +;; (:print-function %print-type)) +;; ;; +;; ;; The car element type. +;; (car-type *wild-type* :type ctype) +;; ;; +;; ;; The cdr element type. +;; (cdr-type *wild-type* :type ctype)) + +;; (define-type-class cons) + ;;;; KLUDGE: not clear this really belongs here, but where? ;;; Is X a fixnum in the target Lisp? diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 6cd611a..07cfe9c 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -36,8 +36,8 @@ (defun control-stack-usage () #!-x86 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap)) - control-stack-start) - #!+x86 (- control-stack-end + sb!vm:control-stack-start) + #!+x86 (- sb!vm:control-stack-end (sb!sys:sap-int (sb!c::control-stack-pointer-sap)))) (defun binding-stack-usage () diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 656bb63..44ae73a 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -311,14 +311,18 @@ ;;; Return the type of the first value indicated by Type. This is used ;;; by people who don't want to have to deal with values types. -#!-sb-fluid (declaim (freeze-type values-type) (inline single-value-type)) + +;;; MNA: fix-instance-typep-call patch +#!-sb-fluid (declaim (freeze-type values-type)) +; (inline single-value-type)) (defun single-value-type (type) (declare (type ctype type)) (cond ((values-type-p type) (or (car (args-type-required type)) - (car (args-type-optional type)) + (if (args-type-optional type) + (type-union (car (args-type-optional type)) (specifier-type 'null))) (args-type-rest type) - *universal-type*)) + (specifier-type 'null))) ((eq type *wild-type*) *universal-type*) (t @@ -358,17 +362,19 @@ (values (mapcar #'single-value-type req) (length req)))))) ;;; Return two values: +;;; MNA: fix-instance-typep-call patch ;;; 1. A list of all the positional (fixed and optional) types. -;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*. -;;; If no keywords or rest, *EMPTY-TYPE*. -(defun values-type-types (type) +;;; 2] The rest type (if any). If keywords allowed, *universal-type*. +;;; If no keywords or rest then the default-type. +(defun values-type-types (type &optional (default-type *empty-type*)) (declare (type values-type type)) (values (append (args-type-required type) (args-type-optional type)) (cond ((args-type-keyp type) *universal-type*) ((args-type-rest type)) (t - *empty-type*)))) + ;; MNA: fix-instance-typep-call patch + default-type)))) ;;; Return a list of OPERATION applied to the types in TYPES1 and ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter @@ -420,13 +426,20 @@ ;;; OPERATION returned true as its second value each time we called ;;; it. Since we approximate the intersection of VALUES types, the ;;; second value being true doesn't mean the result is exact. -(defun args-type-op (type1 type2 operation nreq) - (declare (type ctype type1 type2) (type function operation nreq)) +;;; MNA: fix-instance-typep-call patch +(defun args-type-op (type1 type2 operation nreq default-type) + ;;; MNA: fix-instance-typep-call patch + (declare (type ctype type1 type2 default-type) + (type function operation nreq)) (if (or (values-type-p type1) (values-type-p type2)) (let ((type1 (coerce-to-values type1)) (type2 (coerce-to-values type2))) - (multiple-value-bind (types1 rest1) (values-type-types type1) - (multiple-value-bind (types2 rest2) (values-type-types type2) + (multiple-value-bind (types1 rest1) + ;;; MNA: fix-instance-typep-call patch + (values-type-types type1 default-type) + (multiple-value-bind (types2 rest2) + ;;; MNA: fix-instance-typep-call patch + (values-type-types type2 default-type) (multiple-value-bind (rest rest-exact) (funcall operation rest1 rest2) (multiple-value-bind (res res-exact) @@ -447,7 +460,8 @@ :optional (if opt-last (subseq opt 0 (1+ opt-last)) ()) - :rest (if (eq rest *empty-type*) nil rest)) + ;; MNA fix-instance-typep-call patch + :rest (if (eq rest default-type) nil rest)) (and rest-exact res-exact))))))))) (funcall operation type1 type2))) @@ -468,7 +482,9 @@ ((eq type1 *empty-type*) type2) ((eq type2 *empty-type*) type1) (t - (values (args-type-op type1 type2 #'type-union #'min))))) + ;;; MNA: fix-instance-typep-call patch + (values (args-type-op type1 type2 #'type-union #'min *empty-type*))))) +;;; (defun-cached (values-type-intersection :hash-function type-cache-hash :hash-bits 8 :values 2 @@ -479,7 +495,7 @@ (cond ((eq type1 *wild-type*) (values type2 t)) ((eq type2 *wild-type*) (values type1 t)) (t - (args-type-op type1 type2 #'type-intersection #'max)))) + (args-type-op type1 type2 #'type-intersection #'max (specifier-type 'null))))) ;;; This is like TYPES-INTERSECT, except that it sort of works on ;;; VALUES types. Note that due to the semantics of @@ -1672,6 +1688,68 @@ (return (make-hairy-type :specifier spec))) (setq res int)))))) + +;;; MNA: cons compound-type patch +;;; FIXIT: all commented out + +; (define-type-class cons) + +; (def-type-translator cons (&optional car-type cdr-type) +; (make-cons-type :car-type (specifier-type car-type) +; :cdr-type (specifier-type cdr-type))) + +; (define-type-method (cons :unparse) (type) +; (let ((car-eltype (type-specifier (cons-type-car-type type))) +; (cdr-eltype (type-specifier (cons-type-cdr-type type)))) +; (cond ((and (eq car-eltype '*) (eq cdr-eltype '*)) +; 'cons) +; (t +; `(cons ,car-eltype ,cdr-eltype))))) + +; (define-type-method (cons :simple-=) (type1 type2) +; (declare (type cons-type type1 type2)) +; (and (type= (cons-type-car-type type1) (cons-type-car-type type2)) +; (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2)))) + +; (define-type-method (cons :simple-subtypep) (type1 type2) +; (declare (type cons-type type1 type2)) +; (multiple-value-bind (val-car win-car) +; (csubtypep (cons-type-car-type type1) (cons-type-car-type type2)) +; (multiple-value-bind (val-cdr win-cdr) +; (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2)) +; (if (and val-car val-cdr) +; (values t (and win-car win-cdr)) +; (values nil (or win-car win-cdr)))))) + +; ;;; CONS :simple-union method -- Internal +; ;;; +; ;;; Give up if a precise type in not possible, to avoid returning overly +; ;;; general types. +; ;;; +; (define-type-method (cons :simple-union) (type1 type2) +; (declare (type cons-type type1 type2)) +; (let ((car-type1 (cons-type-car-type type1)) +; (car-type2 (cons-type-car-type type2)) +; (cdr-type1 (cons-type-cdr-type type1)) +; (cdr-type2 (cons-type-cdr-type type2))) +; (cond ((type= car-type1 car-type2) +; (make-cons-type :car-type car-type1 +; :cdr-type (type-union cdr-type1 cdr-type2))) +; ((type= cdr-type1 cdr-type2) +; (make-cons-type :car-type (type-union cdr-type1 cdr-type2) +; :cdr-type cdr-type1))))) + +; (define-type-method (cons :simple-intersection) (type1 type2) +; (declare (type cons-type type1 type2)) +; (multiple-value-bind (int-car win-car) +; (type-intersection (cons-type-car-type type1) (cons-type-car-type type2)) +; (multiple-value-bind (int-cdr win-cdr) +; (type-intersection (cons-type-cdr-type type1) (cons-type-cdr-type type2)) +; (values (make-cons-type :car-type int-car :cdr-type int-cdr) +; (and win-car win-cdr))))) + + + ;;; Return the type that describes all objects that are in X but not ;;; in Y. If we can't determine this type, then return NIL. ;;; diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 4312df9..362bce1 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -202,6 +202,83 @@ (case-body-aux name keyform keyform-value clauses keys errorp proceedp `(,(if multi-p 'member 'or) ,@keys)))) + +;;; MNA: typecase-implicit-declarations patch + +;;; TYPECASE-BODY (interface) +;;; +;;; TYPECASE-BODY returns code for all the standard "typecase" macros. +;;; Name is the macro name, and keyform is the thing to case on. +;;; test is applied to the value of keyform and the entire first element, +;;; instead of each part, of the case branch. +;;; When errorp, no t or otherwise branch is permitted, +;;; and an ERROR form is generated. When proceedp, it is an error to +;;; omit errorp, and the ERROR form generated is executed within a +;;; RESTART-CASE allowing keyform to be set and retested. +(defun typecase-body (name keyform cases test errorp proceedp needcasesp) + (unless (or cases (not needcasesp)) + (warn "no clauses in ~S" name)) + (let* ((keyform-symbol-p (symbolp keyform)) + (keyform-value (unless keyform-symbol-p + (gensym))) + (clauses ()) + (keys ())) + (dolist (case cases) + (cond ((atom case) + (error "~S -- Bad clause in ~S." case name)) + ((memq (car case) '(t otherwise)) + (if errorp + (error 'simple-program-error + :format-control "No default clause is allowed in ~S: ~S" + :format-arguments (list name case)) + (push `(t nil ,@(rest case)) clauses))) + (t + (push (first case) keys) + (push (if keyform-symbol-p + `((,test ,keyform ',(first case)) nil + (locally + ;; this will cause a compiler-warning ... disabled + ;; for now. + ;; (declare (type ,(first case) ,keyform)) + ,@(rest case))) + `((,test ,keyform-value ',(first case)) nil + ,@(rest case))) + clauses)))) + (if keyform-symbol-p + (typecase-symbol-body-aux name keyform clauses keys errorp proceedp + (cons 'or keys)) + (case-body-aux name keyform keyform-value clauses keys errorp proceedp + (cons 'or keys))))) + +;;; TYPECASE-SYMBOL-BODY-AUX provides the expansion once CASE-BODY has groveled +;;; all the cases, iff keyform is a symbol. +(defun typecase-symbol-body-aux (name keyform clauses keys + errorp proceedp expected-type) + (if proceedp + (let ((block (gensym)) + (again (gensym))) + `(block ,block + (tagbody + ,again + (return-from + ,block + (cond ,@(nreverse clauses) + (t + (setf ,keyform + (case-body-error + ',name ',keyform ,keyform + ',expected-type ',keys))) + (go ,again)))))) + `(progn + (cond + ,@(nreverse clauses) + ,@(if errorp + `((t (error 'sb!conditions::case-failure + :name ',name + :datum ,keyform + :expected-type ',expected-type + :possibilities ',keys)))))))) + ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled ;;; all the cases. Note: it is not necessary that the resulting code ;;; signal case-failure conditions, but that's what KMP's prototype @@ -270,21 +347,21 @@ "TYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true." - (case-body 'typecase keyform cases nil 'typep nil nil nil)) + (typecase-body 'typecase keyform cases 'typep nil nil nil)) (defmacro-mundanely ctypecase (keyform &body cases) #!+sb-doc "CTYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then a correctable error is signalled." - (case-body 'ctypecase keyform cases nil 'typep t t t)) + (typecase-body 'ctypecase keyform cases 'typep t t t)) (defmacro-mundanely etypecase (keyform &body cases) #!+sb-doc "ETYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true. If no form is satisfied then an error is signalled." - (case-body 'etypecase keyform cases nil 'typep t nil t)) + (typecase-body 'etypecase keyform cases 'typep t nil t)) ;;;; WITH-FOO i/o-related macros diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index b3415d2..084fe99 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -43,6 +43,9 @@ named-type member-type array-type + ;; MNA: cons compound-type patch + ;; FIXIT: all commented out + ; cons-type sb!xc:built-in-class) (values (%typep obj type) t)) (sb!xc:class @@ -200,6 +203,10 @@ :complexp (not (typep x 'simple-array)) :element-type etype :specialized-element-type etype))) + ;; MNA: cons compound-type patch + ;; FIXIT: all commented + ; (cons + ; (make-cons-type)) (t (sb!xc:class-of x)))) diff --git a/src/code/typep.lisp b/src/code/typep.lisp index b82f92c..2c461ed 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -114,6 +114,12 @@ (dolist (type (union-type-types type)) (when (%%typep object type) (return t)))) + ;; MNA: cons compound-type patch + ;; FIXIT: all commented out +; (cons-type +; (and (consp object) +; (%%typep (car object) (cons-type-car-type type)) +; (%%typep (cdr object) (cons-type-cdr-type type)))) (unknown-type ;; dunno how to do this ANSIly -- WHN 19990413 #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host") diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index e727624..8476000 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -67,6 +67,14 @@ (+ 1 (if (numeric-type-low type) 1 0) (if (numeric-type-high type) 1 0)))) + ;; MNA: cons compound-type patch + ;; FIXIT: all commented out +; (cons-type +; (+ (type-test-cost (specifier-type 'cons)) +; (function-cost 'car) +; (type-test-cost (cons-type-car-type type)) +; (function-cost 'cdr) +; (type-test-cost (cons-type-cdr-type type)))) (t (function-cost 'typep))))) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 5a3b26f..a8acaee 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -303,6 +303,16 @@ (close (fasl-file-stream file) :abort abort-p) (values)) + +;;; MNA dump-circular hack +(defun circular-list-p (list) + (and (listp list) + (multiple-value-bind (res condition) + (ignore-errors (list-length list)) + (if condition + nil + (null res))))) + ;;;; main entries to object dumping ;;; This function deals with dumping objects that are complex enough so that @@ -320,9 +330,14 @@ (typecase x (symbol (dump-symbol x file)) (list + ;; MNA dump-circular hack + (if (circular-list-p x) + (progn + (dump-list x file) + (eq-save-object x file)) (unless (equal-check-table x file) (dump-list x file) - (equal-save-object x file))) + (equal-save-object x file)))) (layout (dump-layout x file) (eq-save-object x file)) diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index 5ec9ad5..6e6c322 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -352,6 +352,10 @@ (part-of function)) (base-char (exactly base-char)) + ;; MNA: cons compound-type patch + ;; FIXIT: all commented out +; (cons-type +; (part-of list)) (cons (part-of list)) (t diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 8ed1ba1..206590b 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -298,3 +298,10 @@ ;;;; mutator accessors (defknown mutator-self () system-area-pointer (flushable movable)) + +;;; MNA: open-coded-simple-array patch +(defun %array-simp (a) a) +(defknown %array-simp (simple-array) simple-array (movable foldable flushable)) + +(defknown %array-data-vector (simple-array) simple-array (movable foldable flushable)) +(defknown %array-simp (simple-array) simple-array (movable foldable flushable)) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index ea381c4..ad74c20 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -78,22 +78,26 @@ (declare (type (simple-array ,element-type-specifier 1) array)) (data-vector-ref array index))))) +;;; MNA: open-coded-simple-array patch (deftransform data-vector-ref ((array index) (simple-array t)) (let ((array-type (continuation-type array))) (unless (array-type-p array-type) (give-up-ir1-transform)) (let ((dims (array-type-dimensions array-type))) - (when (or (atom dims) (= (length dims) 1)) + (when (and (consp dims) (= (length dims) 1)) (give-up-ir1-transform)) - (let ((el-type (array-type-element-type array-type)) - (total-size (if (member '* dims) + (let* ((el-type (array-type-element-type array-type)) + (total-size (if (or (atom dims) (member '* dims)) '* - (reduce #'* dims)))) - `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type) - (,total-size)) - (%array-data-vector array)) - index))))) + (reduce #'* dims))) + (type-sp `(simple-array ,(type-specifier el-type) + (,total-size)))) + (if (atom dims) + `(let ((a (truly-the ,type-sp (%array-simp array)))) + (data-vector-ref a index)) + `(let ((a (truly-the ,type-sp (%array-data-vector array)))) + (data-vector-ref a index))))))) (deftransform hairy-data-vector-set ((array index new-value) (array t t) @@ -126,23 +130,26 @@ index new-value))))) +;;; MNA: open-coded-simple-array patch (deftransform data-vector-set ((array index new-value) (simple-array t t)) (let ((array-type (continuation-type array))) (unless (array-type-p array-type) (give-up-ir1-transform)) (let ((dims (array-type-dimensions array-type))) - (when (or (atom dims) (= (length dims) 1)) + (when (and (consp dims) (= (length dims) 1)) (give-up-ir1-transform)) - (let ((el-type (array-type-element-type array-type)) - (total-size (if (member '* dims) + (let* ((el-type (array-type-element-type array-type)) + (total-size (if (or (atom dims) (member '* dims)) '* - (reduce #'* dims)))) - `(data-vector-set (truly-the (simple-array ,(type-specifier el-type) - (,total-size)) - (%array-data-vector array)) - index - new-value))))) + (reduce #'* dims))) + (type-sp `(simple-array ,(type-specifier el-type) + (,total-size)))) + (if (atom dims) + `(let ((a (truly-the ,type-sp (%array-simp array)))) + (data-vector-set a index new-value)) + `(let ((a (truly-the ,type-sp (%array-data-vector array)))) + (data-vector-set a index new-value))))))) ;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8) ;;; @@ -281,3 +288,4 @@ (deftransform eql ((x y) (double-float double-float)) '(and (= (double-float-low-bits x) (double-float-low-bits y)) (= (double-float-high-bits x) (double-float-high-bits y)))) + diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index 2db6b49..fcb8570 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -159,6 +159,16 @@ (defun hairy-type-check-template-name (type) (declare (type ctype type)) (typecase type + ;; MNA: cons compound-type + ;; FIXIT: all commented out +; (cons-type +; (if (type= type (specifier-type 'cons)) +; 'sb!c:check-cons +; nil)) +; (built-in-class +; (if (type= type (specifier-type 'symbol)) +; 'sb!c:check-symbol +; nil)) (named-type (case (named-type-name type) (cons 'sb!c:check-cons) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index b285870..420f803 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1053,9 +1053,10 @@ (string= (symbol-name what) "CLASS"))) ; pcl hack (or (info :type :kind what) (and (consp what) (info :type :translator (car what))))) - (unless (policy nil (= brevity 3)) +;;; MNA - abbreviated declaration bug +;; (unless (policy nil (= brevity 3)) ;; FIXME: Is it ANSI to warn about this? I think not. - (compiler-note "abbreviated type declaration: ~S." spec)) +;; (compiler-note "abbreviated type declaration: ~S." spec)) (process-type-declaration spec res vars)) ((info :declaration :recognized what) res) @@ -1566,12 +1567,14 @@ (let ((n-supplied (gensym "N-SUPPLIED-"))) (temps n-supplied) (arg-vals n-value n-supplied) - (tests `((eq ,n-key ,keyword) + ;; MNA: non-self-eval-keyword patch + (tests `((eq ,n-key ',keyword) (setq ,n-supplied t) (setq ,n-value ,n-value-temp))))) (t (arg-vals n-value) - (tests `((eq ,n-key ,keyword) + ;; MNA: non-self-eval-keyword patch + (tests `((eq ,n-key ',keyword) (setq ,n-value ,n-value-temp))))))) (unless allowp @@ -1924,10 +1927,16 @@ (setf (entry-cleanup entry) cleanup) (prev-link entry start) (use-continuation entry dummy) - (let ((*lexenv* (make-lexenv :blocks (list (cons name (list entry cont))) + + ;; MNA - Re: two obscure bugs in CMU CL + (let* ((env-entry (list entry cont)) + (*lexenv* + (make-lexenv :blocks (list (cons name env-entry)) :cleanup cleanup))) + (push env-entry (continuation-lexenv-uses cont)) (ir1-convert-progn-body dummy cont forms)))) + ;;; We make Cont start a block just so that it will have a block ;;; assigned. People assume that when they pass a continuation into ;;; IR1-Convert as Cont, it will have a block when it is done. @@ -2007,11 +2016,15 @@ (conts)) (starts dummy) (dolist (segment (rest segments)) - (let ((tag-cont (make-continuation))) + ;; MNA - Re: two obscure bugs + (let* ((tag-cont (make-continuation)) + (tag (list (car segment) entry tag-cont))) (conts tag-cont) (starts tag-cont) (continuation-starts-block tag-cont) - (tags (list (car segment) entry tag-cont)))) + (tags tag) + (push (cdr tag) (continuation-lexenv-uses tag-cont)) + )) (conts cont) (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags)))) @@ -2425,8 +2438,9 @@ the Declarations have effect. If LOCALLY is a top-level form, then the Forms are also processed as top-level forms." (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) - (let* ((*lexenv* (process-decls decls nil nil cont))) - (ir1-convert-aux-bindings start cont forms nil nil nil)))) + (let ((*lexenv* (process-decls decls nil nil cont))) + ;;; MNA: locally patch - #'ir1-convert-progn-body gets called anyway! + (ir1-convert-progn-body start cont forms)))) ;;;; FLET and LABELS @@ -2914,7 +2928,8 @@ (ir1-convert start cont `(%%defmacro ',name ,fun ,doc))) (when sb!xc:*compile-print* - (compiler-mumble "converted ~S~%" name)))) + ;; MNA compiler message patch + (compiler-mumble "~&; converted ~S~%" name)))) (def-ir1-translator %define-compiler-macro ((name def lambda-list doc) start cont @@ -2940,7 +2955,8 @@ (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc))) (when sb!xc:*compile-print* - (compiler-mumble "converted ~S~%" name)))) + ;; MNA compiler message patch + (compiler-mumble "~&; converted ~S~%" name)))) ;;; Update the global environment to correspond to the new definition. (def-ir1-translator %defconstant ((name value doc) start cont @@ -2962,7 +2978,16 @@ ;; FIXME: ANSI says EQL, not EQUALP. Perhaps make a special ;; variant of this warning for the case where they're EQUALP, ;; since people seem to be confused about this. - (unless (equalp newval (info :variable :constant-value name)) + + ;; MNA: re-defconstant patch + (when (or (and (listp newval) + (or (null (list-length newval)) + (not (tree-equal newval + (info :variable + :constant-value name) + :test #'equalp)))) + (not (equalp newval (info :variable + :constant-value name)))) (compiler-warning "redefining constant ~S as:~% ~S" name newval))) (:global) (t @@ -3183,4 +3208,5 @@ ,@(when save-expansion `(',save-expansion))))) (when sb!xc:*compile-print* - (compiler-mumble "converted ~S~%" name)))))) + ;; MNA compiler message patch + (compiler-mumble "~&; converted ~S~%" name)))))) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 5c292b2..971eaef 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -165,6 +165,9 @@ (do-uses (node old) (delete-continuation-use node) (add-continuation-use node new)) + ;; MNA: Re: two obscure bugs in CMU CL + (dolist (lexenv-use (continuation-lexenv-uses old)) + (setf (cadr lexenv-use) new)) (reoptimize-continuation new) (values)) @@ -1428,7 +1431,9 @@ (*print-lines* *compiler-error-print-lines*) (*print-pretty* pretty)) (if pretty - (format nil " ~S~%" form) + ;;; MNA: compiler message patch + ;;; (format nil " ~S~%" form) + (format nil "~<~@; ~S~:>" (list form)) (prin1-to-string form)))) ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current error @@ -1503,7 +1508,8 @@ (cond ((= *last-message-count* 1) (when terpri (terpri *error-output*))) ((> *last-message-count* 1) - (format *error-output* "[Last message occurs ~D times.]~2%" + ;; MNA: compiler message patch + (format *error-output* "~&; [Last message occurs ~D times]~2%" *last-message-count*))) (setq *last-message-count* 0)) @@ -1536,20 +1542,30 @@ (when (pathnamep file) (note-message-repeats) (setq last nil) - (format stream "~2&file: ~A~%" (namestring file)))) + ;; MNA: compiler message patch + (format stream "~2&; file: ~A~%" (namestring file)))) (unless (and last (equal in (compiler-error-context-context last))) (note-message-repeats) (setq last nil) - (format stream "~2&in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}~%" in)) + ;; MNA: compiler message patch + (format stream "~&") + (pprint-logical-block (stream nil :per-line-prefix "; ") + (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in)) + (format stream "~%")) + (unless (and last (string= form (compiler-error-context-original-source last))) (note-message-repeats) (setq last nil) - (write-string form stream)) + ;; MNA: compiler message patch + (format stream "~&") + (pprint-logical-block (stream nil :per-line-prefix "; ") + (format stream " ~A" form)) + (format stream "~&")) (unless (and last (equal enclosing @@ -1557,7 +1573,8 @@ (when enclosing (note-message-repeats) (setq last nil) - (format stream "--> ~{~<~%--> ~1:;~A~> ~}~%" enclosing))) + ;; MNA: compiler message patch + (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing))) (unless (and last (equal source (compiler-error-context-source last))) @@ -1565,12 +1582,17 @@ (when source (note-message-repeats) (dolist (src source) - (write-line "==>" stream) - (write-string src stream)))))) + ;; MNA: compiler message patch + (format stream "~&") + (write-string "; ==>" stream) + (format stream "~&") + (pprint-logical-block (stream nil :per-line-prefix "; ") + (write-string src stream))))))) (t + (format stream "~&") (note-message-repeats) (setq *last-format-string* nil) - (format stream "~2&"))) + (format stream "~&"))) (setq *last-error-context* context) @@ -1582,7 +1604,11 @@ (let ((*print-level* *compiler-error-print-level*) (*print-length* *compiler-error-print-length*) (*print-lines* *compiler-error-print-lines*)) - (format stream "~&~?~&" format-string format-args)))) + ;; MNA: compiler message patch + (format stream "~&") + (pprint-logical-block (stream nil :per-line-prefix "; ") + (format stream "~&~?" format-string format-args)) + (format stream "~&")))) (incf *last-message-count*) (values)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index a28f61f..442b43a 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -122,7 +122,10 @@ ;;; Mumble conditional on *COMPILE-PROGRESS*. (defun maybe-mumble (&rest foo) (when *compile-progress* - (apply #'compiler-mumble foo))) + ;; MNA: compiler message patch + (compiler-mumble "~&") + (pprint-logical-block (*error-output* nil :per-line-prefix "; ") + (apply #'compiler-mumble foo)))) (deftype object () '(or fasl-file core-object null)) @@ -225,19 +228,22 @@ (zerop *compiler-warning-count*) (zerop *compiler-style-warning-count*) (zerop *compiler-note-count*))) + ;; MNA: compiler message patch + (format *error-output* "~&") + (pprint-logical-block (*error-output* nil :per-line-prefix "; ") (compiler-mumble - "~2&compilation unit ~:[finished~;aborted~]~ + "compilation unit ~:[finished~;aborted~]~ ~[~:;~:*~& caught ~D fatal ERROR condition~:P~]~ ~[~:;~:*~& caught ~D ERROR condition~:P~]~ ~[~:;~:*~& caught ~D WARNING condition~:P~]~ ~[~:;~:*~& caught ~D STYLE-WARNING condition~:P~]~ - ~[~:;~:*~& printed ~D note~:P~]~2%" + ~[~:;~:*~& printed ~D note~:P~]" abort-p *aborted-compilation-unit-count* *compiler-error-count* *compiler-warning-count* *compiler-style-warning-count* - *compiler-note-count*))) + *compiler-note-count*)))) ;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P ;;; FAILURE-P), where BODY-VALUE is the first value of the body, and @@ -491,7 +497,8 @@ (return nil))))))) (when sb!xc:*compile-print* - (compiler-mumble "~&~:[~;byte ~]compiling ~A: " + ;; MNA: compiler message patch + (compiler-mumble "~&; ~:[~;byte ~]compiling ~A: " *byte-compiling* (component-name component))) @@ -934,12 +941,15 @@ (compiler-error "bad FILE-COMMENT form: ~S" form)) (let ((file (first (source-info-current-file *source-info*)))) (cond ((file-info-comment file) - (compiler-warning "ignoring extra file comment:~% ~S" form)) + ;; MNA: compiler message patch + (pprint-logical-block (*error-output* nil :per-line-prefix "; ") + (compiler-warning "Ignoring extra file comment:~% ~S." form))) (t (let ((comment (coerce (second form) 'simple-string))) (setf (file-info-comment file) comment) (when sb!xc:*compile-verbose* - (compiler-mumble "~&FILE-COMMENT: ~A~2&" comment))))))) + ;; MNA: compiler message patch + (compiler-mumble "~&; FILE-COMMENT: ~A~2&" comment))))))) ;;; Force any pending top-level forms to be compiled and dumped so that they ;;; will be evaluated in the correct package environment. Dump the form to be @@ -1379,7 +1389,8 @@ (*compiler-error-bailout* #'(lambda () (compiler-mumble - "~2&fatal error, aborting compilation~%") + ;; MNA: compiler message patch + "~2&; fatal error, aborting compilation~%") (return-from sub-compile-file (values nil t t)))) (*current-path* nil) (*last-source-context* nil) @@ -1439,18 +1450,20 @@ (defun start-error-output (source-info) (declare (type source-info source-info)) (dolist (x (source-info-files source-info)) - (compiler-mumble "compiling file ~S (written ~A):~%" + ;; MNA: compiler message patch + (compiler-mumble "~&; compiling file ~S (written ~A):~%" (namestring (file-info-name x)) (sb!int:format-universal-time nil (file-info-write-date x) :style :government :print-weekday nil :print-timezone nil))) - (compiler-mumble "~%") (values)) + (defun finish-error-output (source-info won) (declare (type source-info source-info)) - (compiler-mumble "~&compilation ~:[aborted after~;finished in~] ~A~&" + ;; MNA: compiler message patch + (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&" won (elapsed-time-to-string (- (get-universal-time) @@ -1535,7 +1548,8 @@ (close-fasl-file fasl-file (not compile-won)) (setq output-file-name (pathname (fasl-file-stream fasl-file))) (when (and compile-won sb!xc:*compile-verbose*) - (compiler-mumble "~2&~A written~%" (namestring output-file-name)))) + ;; MNA: compiler message patch + (compiler-mumble "~2&; ~A written~%" (namestring output-file-name)))) (when sb!xc:*compile-verbose* (finish-error-output source-info compile-won))) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index a96deb2..90be478 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -124,7 +124,17 @@ ;; CONTINUATION-TYPE-CHECK instead of the %'ed slot accessor. (%type-check t :type (member t nil :deleted :no-check :error)) ;; Something or other that the back end annotates this continuation with. - (info nil)) + + ;; MNA: Re: two obscure bugs in CMU CL + (info nil) + ;; + ;; Uses of this continuation in the lexical environment. They are recorded + ;; so that when one continuation is substituted for another the environment + ;; may be updated properly. + ;; MNAFIX + (lexenv-uses nil :type list) +) + (def!method print-object ((x continuation) stream) (print-unreadable-object (x stream :type t :identity t))) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 6a18bcf..d8e2ac0 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -138,6 +138,26 @@ `(cdr ,(frob (1- n)))))) (frob n)))) +;;; MNA: cons compound-type patch +;;; FIXIT: all commented out + +; ;;;; CONS assessor derive type optimizers. + +; (defoptimizer (car derive-type) ((cons)) +; (let ((type (continuation-type cons))) +; (cond ((eq type (specifier-type 'null)) +; (specifier-type 'null)) +; ((cons-type-p type) +; (cons-type-car-type type))))) + +; (defoptimizer (cdr derive-type) ((cons)) +; (let ((type (continuation-type cons))) +; (cond ((eq type (specifier-type 'null)) +; (specifier-type 'null)) +; ((cons-type-p type) +; (cons-type-cdr-type type))))) + + ;;;; arithmetic and numerology (def-source-transform plusp (x) `(> ,x 0)) @@ -2482,6 +2502,28 @@ (frob logior) (frob logxor)) +;; MNA: defoptimizer for integer-length patch +(defoptimizer (integer-length derive-type) ((x)) + (let ((x-type (continuation-type x))) + (when (and (numeric-type-p x-type) + (csubtypep x-type (specifier-type 'integer))) + ;; If the X is of type (INTEGER LO HI), then the integer-length + ;; of X is (INTEGER (min lo hi) (max lo hi), basically. Be + ;; careful about LO or HI being NIL, though. Also, if 0 is + ;; contained in X, the lower bound is obviously 0. + (flet ((null-or-min (a b) + (and a b (min (integer-length a) + (integer-length b)))) + (null-or-max (a b) + (and a b (max (integer-length a) + (integer-length b))))) + (let* ((min (numeric-type-low x-type)) + (max (numeric-type-high x-type)) + (min-len (null-or-min min max)) + (max-len (null-or-max min max))) + (when (ctypep 0 x-type) + (setf min-len 0)) + (specifier-type `(integer ,(or min-len '*) ,(or max-len '*)))))))) ) ; PROGN ;;;; miscellaneous derive-type methods diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index c0a9e2b..c634cda 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -734,6 +734,10 @@ (fresh-line stream) + ;; MNA: compiler message patch + (setf location-column-width (+ 2 location-column-width)) + (princ "; " stream) + ;; print the location ;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but ;; usually avoids any consing] @@ -780,11 +784,13 @@ (with-print-restrictions (dolist (note (dstate-notes dstate)) (format stream "~Vt; " *disassem-note-column*) + ;; MNA: compiler message patch + (pprint-logical-block (stream nil :per-line-prefix "; ") (etypecase note (string (write-string note stream)) (function - (funcall note stream))) + (funcall note stream)))) (terpri stream)) (fresh-line stream) (setf (dstate-notes dstate) nil))) @@ -1588,6 +1594,7 @@ (declare (type (or function symbol cons) object) (type (or (member t) stream) stream) (type (member t nil) use-labels)) + (pprint-logical-block (*standard-output* nil :per-line-prefix "; ") (let ((fun (compiled-function-or-lose object))) (if (typep fun 'sb!kernel:byte-function) (sb!c:disassem-byte-fun fun) @@ -1595,7 +1602,7 @@ (disassemble-function (fun-self fun) :stream stream :use-labels use-labels))) - (values)) + (values))) (defun disassemble-memory (address length diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index b0160e4..1b48fea 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -298,6 +298,30 @@ `(typep ,n-obj ',(type-specifier x))) types))))))) +;;; MNA: cons compound-type patch +;;; FIXIT: all commented out +; ;;; Source-Transform-Cons-Typep +; ;;; +; ;;; If necessary recurse to check the cons type. +; ;;; +; (defun source-transform-cons-typep (object type) +; (let* ((car-type (cons-type-car-type type)) +; (cdr-type (cons-type-cdr-type type))) +; (let ((car-test-p (not (or (type= car-type *wild-type*) +; (type= car-type (specifier-type t))))) +; (cdr-test-p (not (or (type= cdr-type *wild-type*) +; (type= cdr-type (specifier-type t)))))) +; (if (and (not car-test-p) (not cdr-test-p)) +; `(consp ,object) +; (once-only ((n-obj object)) +; `(and (consp ,n-obj) +; ,@(if car-test-p +; `((typep (car ,n-obj) +; ',(type-specifier car-type)))) +; ,@(if cdr-test-p +; `((typep (cdr ,n-obj) +; ',(type-specifier cdr-type)))))))))) + ;;; Return the predicate and type from the most specific entry in ;;; *TYPE-PREDICATES* that is a supertype of TYPE. (defun find-supertype-predicate (type) @@ -495,6 +519,10 @@ `(%instance-typep ,object ,spec)) (array-type (source-transform-array-typep object type)) + ;; MNA: cons compound-type patch + ;; FIXIT: all commented +; (cons-type +; (source-transform-cons-typep object type)) (t nil))) `(%typep ,object ,spec))) (values nil t))) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 90da787..faa9b0c 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1016,7 +1016,8 @@ bootstrapping. (cadar var)) (values (make-keyword (car var)) (car var))) - `((,key (get-key-arg1 ,keyword ,args-tail)) + ;; MNA: non-self-eval-keyword patch + `((,key (get-key-arg1 ',keyword ,args-tail)) (,variable (if (consp ,key) (car ,key) ,(cadr var)))))) @@ -1027,7 +1028,8 @@ bootstrapping. (cadar var)) (values (make-keyword (car var)) (car var))) - `((,key (get-key-arg1 ,keyword ,args-tail)) + ;; MNA: non-self-eval-keyword patch + `((,key (get-key-arg1 ',keyword ,args-tail)) (,(caddr var) ,key) (,variable (if (consp ,key) (car ,key) diff --git a/src/runtime/x86-arch.c b/src/runtime/x86-arch.c index aaad2a1..e599077 100644 --- a/src/runtime/x86-arch.c +++ b/src/runtime/x86-arch.c @@ -236,7 +236,7 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context) * seems to be no point in doing that, since we're just * going to lose(..) anyway. */ fake_foreign_function_call(context); - lose("%%primitive halt called; the party is over."); + lose("%%PRIMITIVE HALT called; the party is over."); case trap_Error: case trap_Cerror: diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 9a01572..38aebc8 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1,6 +1,6 @@ (cl:in-package :cl-user) -;;; Exercise a compiler bug by (crashing the compiler). +;;; Exercise a compiler bug (by crashing the compiler). ;;; ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG ;;; (2000-09-06 on cmucl-imp). @@ -25,3 +25,21 @@ (fun1) nil)))) + +;;; Exercise a compiler bug (by crashing the compiler). +;;; +;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on +;;; cmucl-imp, and Martin Atzmueller applied it to SBCL. +(funcall (compile nil + '(lambda (x) + (or (integerp x) + (block used-by-some-y? + (flet ((frob (stk) + (dolist (y stk) + (unless (rejected? y) + (return-from used-by-some-y? t))))) + (declare (inline frob)) + (frob (rstk x)) + (frob (mrstk x))) + nil)))) + 13) diff --git a/version.lisp-expr b/version.lisp-expr index f8ac268..a00c6b9 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.8.5" +"0.6.8.6"