From: William Harold Newman Date: Thu, 9 Nov 2000 16:03:32 +0000 (+0000) Subject: 0.6.8.12: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b1de52969f584c63d43fb35da4a8a6a4e0e619f0;p=sbcl.git 0.6.8.12: removed "MNA: open-coded-simple-array patch" Argh! typecase-implicit-declarations doesn't add declarations after all.. just a messy no-op! And when I rewrite it to 'work', I finally notice it's a fundamentally broken idea. Gads. Delete it (and hope for real fix for #62). left small rewrites in CASE-BODY: Naming quantities is good. exported SB-KERNEL:%PUTHASH so DEFUN sees DEFKNOWN & vice versa removed bogus FOLDABLEness from hash table accessors --- diff --git a/BUGS b/BUGS index 346ace7..4898018 100644 --- a/BUGS +++ b/BUGS @@ -753,13 +753,31 @@ Error in function C::GET-LAMBDA-TO-COMPILE: (DECLARE (TYPE (SIMPLE-ARRAY SINGLE-FLOAT) X)) ..)) ..) - is redundant. However, it doesn't. As a quick fix to work around - the problem, sbcl-0.6.8.10 was patched to automatically add the - appropriate declarations in the macroexpansion of TYPECASE and - related macros (thanks to Martin Atzmueller porting Juan Jose - Garcia Ripoll's CMU CL patch). But the underlying compiler problem - really should be fixed instead, and at that time the workarounds - in the TYPECASE-ish expansions should be removed. + is redundant. However, as reported by Juan Jose Garcia Ripoll for + CMU CL, it sometimes doesn't. Adding declarations is a pretty good + workaround for the problem for now, but can't be done by the TYPECASE + macros themselves, since it's too hard for the macro to detect + assignments to the variable within the clause. + Note: The compiler *is* smart enough to do the type inference in + many cases. This case, derived from a couple of MACROEXPAND-1 + calls on Ripoll's original test case, + (DEFUN NEGMAT (A) + (DECLARE (OPTIMIZE SPEED (SAFETY 0))) + (COND ((TYPEP A '(SIMPLE-ARRAY SINGLE-FLOAT)) NIL + (LET ((LENGTH (ARRAY-TOTAL-SIZE A))) + (LET ((I 0) (G2554 LENGTH)) + (DECLARE (TYPE REAL G2554) (TYPE REAL I)) + (TAGBODY + SB-LOOP::NEXT-LOOP + (WHEN (>= I G2554) (GO SB-LOOP::END-LOOP)) + (SETF (ROW-MAJOR-AREF A I) (- (ROW-MAJOR-AREF A I))) + (GO SB-LOOP::NEXT-LOOP) + SB-LOOP::END-LOOP)))))) + demonstrates the problem; but the problem goes away if the TAGBODY + and GO forms are removed (leaving the SETF in ordinary, non-looping + code), or if the TAGBODY and GO forms are retained, but the + assigned value becomes 0.0 instead of (- (ROW-MAJOR-AREF A I)). + KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 40135c4..cbbaa3d 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -837,8 +837,6 @@ is a good idea, but see SB-SYS for blurring of boundaries." "%ARRAY-DISPLACED-P" "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" "%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" @@ -853,7 +851,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." "%MAP" "%MAP-TO-SIMPLE-VECTOR-ARITY-1" "%MAP-TO-LIST-ARITY-1" "%MAP-TO-NIL-ON-SEQUENCE" "%MAP-TO-NIL-ON-SIMPLE-VECTOR" "%MAP-TO-NIL-ON-VECTOR" "%MASK-FIELD" "%NEGATE" "%POW" - "%RAW-BITS" "%RAW-REF-COMPLEX-DOUBLE" + "%PUTHASH" "%RAW-BITS" "%RAW-REF-COMPLEX-DOUBLE" "%RAW-REF-COMPLEX-LONG" "%RAW-REF-COMPLEX-SINGLE" "%RAW-REF-DOUBLE" "%RAW-REF-LONG" diff --git a/src/code/boot-extensions.lisp b/src/code/boot-extensions.lisp index 5506411..b4eabcc 100644 --- a/src/code/boot-extensions.lisp +++ b/src/code/boot-extensions.lisp @@ -26,7 +26,7 @@ ;;; a helper function for various macros which expect clauses of a ;;; given length, etc. ;;; -;;; KLUDGE: This implementation will hang on circular list structure. +;;; FIXME: This implementation will hang on circular list structure. ;;; Since this is an error-checking utility, i.e. its job is to deal ;;; with screwed-up input, it'd be good style to fix it so that it can ;;; deal with circular list structure. diff --git a/src/code/macros.lisp b/src/code/macros.lisp index c07cc9e..8fb9125 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -180,19 +180,17 @@ (eval-when (:compile-toplevel :load-toplevel :execute) -;;; CASE-BODY (interface) -;;; -;;; CASE-BODY returns code for all the standard "case" macros. Name is -;;; the macro name, and keyform is the thing to case on. Multi-p +;;; CASE-BODY returns code for all the standard "case" macros. NAME is +;;; the macro name, and KEYFORM is the thing to case on. MULTI-P ;;; indicates whether a branch may fire off a list of keys; otherwise, ;;; a key that is a list is interpreted in some way as a single key. -;;; When multi-p, test is applied to the value of keyform and each key -;;; for a given branch; otherwise, 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. +;;; When MULTI-P, TEST is applied to the value of KEYFORM and each key +;;; for a given branch; otherwise, 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 case-body (name keyform cases multi-p test errorp proceedp needcasesp) (unless (or cases (not needcasesp)) (warn "no clauses in ~S" name)) @@ -200,105 +198,33 @@ (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))) - ((and multi-p (listp (first case))) - (setf keys (append (first case) keys)) - (push `((or ,@(mapcar #'(lambda (key) + (unless (list-of-length-at-least-p case 1) + (error "~S -- bad clause in ~S" case name)) + (destructuring-bind (keyoid &rest forms) case + (cond ((memq keyoid '(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 ,@forms) clauses))) + ((and multi-p (listp keyoid)) + (setf keys (append keyoid keys)) + (push `((or ,@(mapcar (lambda (key) `(,test ,keyform-value ',key)) - (first case))) - nil ,@(rest case)) - clauses)) - (t - (push (first case) keys) - (push `((,test ,keyform-value - ',(first case)) nil ,@(rest case)) clauses)))) + keyoid)) + nil + ,@forms) + clauses)) + (t + (push keyoid keys) + (push `((,test ,keyform-value ',keyoid) + nil + ,@forms) + clauses))))) (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 @@ -367,21 +293,21 @@ "TYPECASE Keyform {(Type Form*)}* Evaluates the Forms in the first clause for which TYPEP of Keyform and Type is true." - (typecase-body 'typecase keyform cases 'typep nil nil nil)) + (case-body 'typecase keyform cases nil '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." - (typecase-body 'ctypecase keyform cases 'typep t t t)) + (case-body 'ctypecase keyform cases nil '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." - (typecase-body 'etypecase keyform cases 'typep t nil t)) + (case-body 'etypecase keyform cases nil 'typep t nil t)) ;;;; WITH-FOO i/o-related macros diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 71dedbc..b397990 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -119,10 +119,10 @@ (process-pid proc)) (defun process-kill (proc signal &optional (whom :pid)) - "Hand SIGNAL to PROC. If whom is :pid, use the kill Unix system call. If - whom is :process-group, use the killpg Unix system call. If whom is - :pty-process-group deliver the signal to whichever process group is currently - in the foreground." + "Hand SIGNAL to PROC. If WHOM is :PID, use the kill Unix system call. If + WHOM is :PROCESS-GROUP, use the killpg Unix system call. If WHOM is + :PTY-PROCESS-GROUP deliver the signal to whichever process group is + currently in the foreground." (let ((pid (ecase whom ((:pid :process-group) (process-pid proc)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index c3251fd..4f90a81 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -735,17 +735,17 @@ (flushable unsafe)) (defknown hash-table-p (t) boolean (movable foldable flushable)) (defknown gethash (t hash-table &optional t) (values t boolean) - (foldable flushable unsafe)) + (flushable unsafe)) ; not FOLDABLE, since hash table contents can change (defknown %puthash (t hash-table t) t (unsafe)) (defknown remhash (t hash-table) boolean ()) -(defknown maphash (callable hash-table) null (foldable flushable call)) +(defknown maphash (callable hash-table) null (flushable call)) (defknown clrhash (hash-table) hash-table ()) -(defknown hash-table-count (hash-table) index (foldable flushable)) +(defknown hash-table-count (hash-table) index (flushable)) (defknown hash-table-rehash-size (hash-table) (or (integer 1) (float (1.0))) (foldable flushable)) (defknown hash-table-rehash-threshold (hash-table) (real 0 1) (foldable flushable)) -(defknown hash-table-size (hash-table) index (foldable flushable)) +(defknown hash-table-size (hash-table) index (flushable)) (defknown hash-table-test (hash-table) symbol (foldable flushable)) (defknown sxhash (t) (integer 0 #.sb!vm:*target-most-positive-fixnum*) (foldable flushable)) diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 206590b..8ed1ba1 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -298,10 +298,3 @@ ;;;; 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 8ee4ef3..a78cf36 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -78,28 +78,22 @@ (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))) - ;; FIXME: How could this happen? Doesn't the limitation to arg - ;; type SIMPLE-ARRAY guarantee that ARRAY-TYPE is an ARRAY-TYPE? (unless (array-type-p array-type) (give-up-ir1-transform)) (let ((dims (array-type-dimensions array-type))) - (when (and (consp dims) (= (length dims) 1)) + (when (or (atom dims) (= (length dims) 1)) (give-up-ir1-transform)) - (let* ((el-type (array-type-element-type array-type)) - (total-size (if (or (atom dims) (member '* dims)) - '* - (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))))))) + (let ((el-type (array-type-element-type array-type)) + (total-size (if (member '* dims) + '* + (reduce #'* dims)))) + `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type) + (,total-size)) + (%array-data-vector array)) + index))))) (deftransform hairy-data-vector-set ((array index new-value) (array t t) @@ -132,28 +126,23 @@ index new-value))))) -;;; MNA: open-coded-simple-array patch (deftransform data-vector-set ((array index new-value) - (simple-array t t)) + (simple-array t t)) (let ((array-type (continuation-type array))) - ;; FIXME: How could this happen? Doesn't the limitation to arg - ;; type SIMPLE-ARRAY guarantee that ARRAY-TYPE is an ARRAY-TYPE? (unless (array-type-p array-type) (give-up-ir1-transform)) (let ((dims (array-type-dimensions array-type))) - (when (and (consp dims) (= (length dims) 1)) - (give-up-ir1-transform)) - (let* ((el-type (array-type-element-type array-type)) - (total-size (if (or (atom dims) (member '* dims)) - '* - (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))))))) + (when (or (atom dims) (= (length dims) 1)) + (give-up-ir1-transform)) + (let ((el-type (array-type-element-type array-type)) + (total-size (if (member '* dims) + '* + (reduce #'* dims)))) + `(data-vector-set (truly-the (simple-array ,(type-specifier el-type) + (,total-size)) + (%array-data-vector array)) + index + new-value))))) ;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8) ;;; diff --git a/version.lisp-expr b/version.lisp-expr index 85b9aec..f278aa8 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.11" +"0.6.8.12"