From 9f926721993baa5711eaf00d7c314924f269f3d2 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Mon, 11 Jun 2001 20:56:45 +0000 Subject: [PATCH] 0.6.12.30: fixed another overflow for big buffers (in GENESIS, when #!+SB-SHOW, when reading) started getting rid of %PRIMITIVE SB!C:BYTE-BLT in favor of SB!KERNEL:%BYTE-BLT deleted unused %SP-REVERSE-FIND-CHARACTER-WITH-ATTRIBUTE, %SP-BYTE-BLT, and %SP-FIND-CHARACTER-WITH-ATTRIBUTE merged MNA prepare-for-inline-type-tests patches (sbcl-devel 2001-06-11) --- package-data-list.lisp-expr | 10 +-- src/code/bit-bash.lisp | 11 +-- src/code/debug-var-io.lisp | 4 +- src/code/fd-stream.lisp | 29 +++---- src/code/mipsstrops.lisp | 29 ------- src/code/stream.lisp | 34 +++----- src/code/target-misc.lisp | 3 + src/compiler/copyprop.lisp | 158 ++++++++++++++++++++----------------- src/compiler/generic/vm-fndb.lisp | 8 ++ src/compiler/generic/vm-tran.lisp | 39 ++++++--- tests/type.impure.lisp | 143 +++++++++++++++++++++++++++++---- version.lisp-expr | 2 +- 12 files changed, 284 insertions(+), 186 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index f602ee6..1ea1a16 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -172,7 +172,7 @@ "ANY" "ARGUMENT-COUNT-ERROR" "ASSEMBLE-FILE" "ATTRIBUTES" "ATTRIBUTES-INTERSECTION" "ATTRIBUTES-UNION" "ATTRIBUTES=" "BIND" - "BYTE-BLT" ; doesn't logically belong here, but is name of VOP.. + "BYTE-BLT" "CALL" "CALL-LOCAL" "CALL-NAMED" "CALL-OUT" "CALL-VARIABLE" "CALLEE-NFP-TN" "CALLEE-RETURN-PC-TN" "CASE-BODY" "CATCH-BLOCK" "CHECK-CONS" @@ -953,7 +953,9 @@ is a good idea, but see SB-SYS for blurring of boundaries." "BIT-BASH-XOR" "BIT-INDEX" "BOGUS-ARGUMENT-TO-VALUES-LIST-ERROR" "BOOLE-CODE" - "BYTE-SPECIFIER" "CALLABLE" "CASE-BODY-ERROR" + "BYTE-SPECIFIER" + "%BYTE-BLT" + "CALLABLE" "CASE-BODY-ERROR" "CHARPOS" "CHECK-FOR-CIRCULARITY" "CHECK-TYPE-ERROR" "CLOSED-FLAME" @@ -1442,9 +1444,7 @@ and even SB-VM seem to have become somewhat blurred over the years." ;; FIXME: %PRIMITIVE shouldn't be here. (I now know that %SYS ;; is for OS-dependent stuff. %PRIMITIVE should probably be in ;; SB!KERNEL.) - "%PRIMITIVE" "%SP-BYTE-BLT" "%SP-FIND-CHARACTER" - "%SP-FIND-CHARACTER-WITH-ATTRIBUTE" - "%SP-REVERSE-FIND-CHARACTER-WITH-ATTRIBUTE" + "%PRIMITIVE" "%SP-FIND-CHARACTER" "%STANDARD-CHAR-P" "*LONG-SITE-NAME*" "*SHORT-SITE-NAME*" "*STDERR*" "*STDIN*" diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index 1753747..589968b 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -505,11 +505,12 @@ (declare (type (simple-array (unsigned-byte 8) 1) bv)) (declare (type sap sap)) (declare (type fixnum offset)) - ;; FIXME: Actually it looks as though this, and most other calls - ;; to COPY-TO-SYSTEM-AREA, could be written more concisely with BYTE-BLT. - ;; Except that the DST-END-DST-START convention for the length is confusing. - ;; Perhaps I could rename BYTE-BLT to BYTE-BLIT and replace the - ;; DST-END argument with an N-BYTES argument? + ;; FIXME: Actually it looks as though this, and most other calls to + ;; COPY-TO-SYSTEM-AREA, could be written more concisely with + ;; %BYTE-BLT. Except that the DST-END-DST-START convention for the + ;; length is confusing. Perhaps I could rename %BYTE-BLT to + ;; %BYTE-BLIT (and correspondingly rename the corresponding VOP) and + ;; replace the DST-END argument with an N-BYTES argument? (copy-to-system-area bv (* sb!vm:vector-data-offset sb!vm:word-bits) sap diff --git a/src/code/debug-var-io.lisp b/src/code/debug-var-io.lisp index 6a61e26..087b46c 100644 --- a/src/code/debug-var-io.lisp +++ b/src/code/debug-var-io.lisp @@ -70,7 +70,7 @@ (once-only ((len `(read-var-integer ,vec ,index))) (once-only ((res `(make-string ,len))) `(progn - (%primitive byte-blt ,vec ,index ,res 0 ,len) + (%byte-blt ,vec ,index ,res 0 ,len) (incf ,index ,len) ,res)))) @@ -93,6 +93,6 @@ (once-only ((n-bytes bytes)) (once-only ((n-res `(make-array (* ,n-bytes 8) :element-type 'bit))) `(progn - (%primitive byte-blt ,vec ,index ,n-res 0 ,n-bytes) + (%byte-blt ,vec ,index ,n-res 0 ,n-bytes) (incf ,index ,n-bytes) ,n-res)))) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 6df3f9f..9c835c1 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -575,7 +575,7 @@ (car entry) (caddr entry)))))) -;;; Returns a string constructed from the sap, start, and end. +;;; Return a string constructed from SAP, START, and END. (defun string-from-sap (sap start end) (declare (type index start end)) (let* ((length (- end start)) @@ -585,9 +585,11 @@ (* length sb!vm:byte-bits)) string)) -;;; the N-BIN method for FD-STREAMs. This blocks in UNIX-READ. It is -;;; generally used where there is a definite amount of reading to be -;;; done, so blocking isn't too problematical. +;;; the N-BIN method for FD-STREAMs +;;; +;;; Note that this blocks in UNIX-READ. It is generally used where +;;; there is a definite amount of reading to be done, so blocking +;;; isn't too problematical. (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p) (declare (type fd-stream stream)) (declare (type index start requested)) @@ -598,23 +600,16 @@ (head (fd-stream-ibuf-head stream)) (tail (fd-stream-ibuf-tail stream)) (available (- tail head)) - (this-copy (min remaining-request available)) + (n-this-copy (min remaining-request available)) (this-start (+ start total-copied)) + (this-end (+ this-start n-this-copy)) (sap (fd-stream-ibuf-sap stream))) (declare (type index remaining-request head tail available)) - (declare (type index this-copy)) + (declare (type index n-this-copy)) ;; Copy data from stream buffer into user's buffer. - (if (typep buffer 'system-area-pointer) - (system-area-copy sap (* head sb!vm:byte-bits) - buffer (* this-start sb!vm:byte-bits) - (* this-copy sb!vm:byte-bits)) - (copy-from-system-area sap (* head sb!vm:byte-bits) - buffer (+ (* this-start sb!vm:byte-bits) - (* sb!vm:vector-data-offset - sb!vm:word-bits)) - (* this-copy sb!vm:byte-bits))) - (incf (fd-stream-ibuf-head stream) this-copy) - (incf total-copied this-copy) + (%byte-blt sap head buffer this-start this-end) + (incf (fd-stream-ibuf-head stream) n-this-copy) + (incf total-copied n-this-copy) ;; Maybe we need to refill the stream buffer. (cond (;; If there were enough data in the stream buffer, we're done. (= total-copied requested) diff --git a/src/code/mipsstrops.lisp b/src/code/mipsstrops.lisp index c2798d1..5acc918 100644 --- a/src/code/mipsstrops.lisp +++ b/src/code/mipsstrops.lisp @@ -93,35 +93,6 @@ `(char-code (char-ref ,index)))) ,@body)))) -;;; The codes of the characters of STRING from START to END are used -;;; as indices into the TABLE, which is a U-Vector of 8-bit bytes. -;;; When the number picked up from the table bitwise ANDed with MASK -;;; is non-zero, the current index into the STRING is returned. -;;; -;;; (This corresponds to SCANC on the Vax.) -(defun %sp-find-character-with-attribute (string start end table mask) - (declare (type (simple-array (unsigned-byte 8) (256)) table) - (type (or simple-string system-area-pointer) string) - (fixnum start end mask)) - (maybe-sap-maybe-string (string) - (do ((index start (1+ index))) - ((>= index end) nil) - (declare (fixnum index)) - (unless (zerop (logand (aref table (byte-ref index)) mask)) - (return index))))) - -;;; like %SP-FIND-CHARACTER-WITH-ATTRIBUTE, only sdrawkcaB -(defun %sp-reverse-find-character-with-attribute (string start end table mask) - (declare (type (or simple-string system-area-pointer) string) - (fixnum start end mask) - (type (array (unsigned-byte 8) (256)) table)) - (maybe-sap-maybe-string (string) - (do ((index (1- end) (1- index))) - ((< index start) nil) - (declare (fixnum index)) - (unless (zerop (logand (aref table (byte-ref index)) mask)) - (return index))))) - ;;; Search STRING for the CHARACTER from START to END. If the ;;; character is found, the corresponding index into STRING is ;;; returned, otherwise NIL is returned. diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 696e65e..5828180 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -455,17 +455,13 @@ numbytes eof-error-p)) ((<= numbytes num-buffered) - (%primitive sb!c:byte-blt - in-buffer - index - buffer - start - (+ start numbytes)) + (%byte-blt in-buffer index + buffer start (+ start numbytes)) (setf (lisp-stream-in-index stream) (+ index numbytes)) numbytes) (t (let ((end (+ start num-buffered))) - (%primitive sb!c:byte-blt in-buffer index buffer start end) + (%byte-blt in-buffer index buffer start end) (setf (lisp-stream-in-index stream) +in-buffer-length+) (+ (funcall (lisp-stream-n-bin stream) stream @@ -1284,12 +1280,8 @@ (let* ((new-length (* current 2)) (new-workspace (make-string new-length))) (declare (simple-string new-workspace)) - (%primitive sb!c:byte-blt - workspace - start - new-workspace - 0 - current) + (%byte-blt workspace start + new-workspace 0 current) (setf workspace new-workspace) (setf offset-current current) (set-array-header buffer workspace new-length @@ -1314,12 +1306,8 @@ (let* ((new-length (+ (the fixnum (* current 2)) string-len)) (new-workspace (make-string new-length))) (declare (simple-string new-workspace)) - (%primitive sb!c:byte-blt - workspace - dst-start - new-workspace - 0 - current) + (%byte-blt workspace dst-start + new-workspace 0 current) (setf workspace new-workspace) (setf offset-current current) (setf offset-dst-end dst-end) @@ -1331,12 +1319,8 @@ new-length nil)) (setf (fill-pointer buffer) dst-end)) - (%primitive sb!c:byte-blt - string - start - workspace - offset-current - offset-dst-end))) + (%byte-blt string start + workspace offset-current offset-dst-end))) dst-end)) (defun fill-pointer-misc (stream operation &optional arg1 arg2) diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index 9519b6e..20ea613 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -122,3 +122,6 @@ (setf *standard-output* (third old-streams)) (setf *error-output* (fourth old-streams))))) (values)) + +(defun %byte-blt (src src-start dst dst-start dst-end) + (%byte-blt src src-start dst dst-start dst-end)) diff --git a/src/compiler/copyprop.lisp b/src/compiler/copyprop.lisp index 3bae557..41f886c 100644 --- a/src/compiler/copyprop.lisp +++ b/src/compiler/copyprop.lisp @@ -13,55 +13,59 @@ (in-package "SB!C") -;;; In copy propagation, we manipulate sets of TNs. We only consider TNs whose -;;; sole write is by a MOVE VOP. This allows us to use a degenerate version of -;;; reaching definitions: since each such TN has only one definition, the TN -;;; can stand for the definition. We can get away with this simplification, -;;; since the TNs that would be subject to copy propagation are nearly always -;;; single-writer (mostly temps allocated to ensure evaluation order is -;;; perserved). Only TNs written by MOVEs are interesting, since all we do -;;; with this information is delete spurious MOVEs. +;;; In copy propagation, we manipulate sets of TNs. We only consider +;;; TNs whose sole write is by a MOVE VOP. This allows us to use a +;;; degenerate version of reaching definitions: since each such TN has +;;; only one definition, the TN can stand for the definition. We can +;;; get away with this simplification, since the TNs that would be +;;; subject to copy propagation are nearly always single-writer +;;; (mostly temps allocated to ensure evaluation order is perserved). +;;; Only TNs written by MOVEs are interesting, since all we do with +;;; this information is delete spurious MOVEs. ;;; -;;; There are additional semantic constraints on whether a TN can be considered -;;; to be a copy. See TN-IS-A-COPY-OF. +;;; There are additional semantic constraints on whether a TN can be +;;; considered to be a copy. See TN-IS-A-COPY-OF. ;;; -;;; If a TN is in the IN set for a block, that TN is a copy of a TN which still -;;; has the same value it had at the time the move was done. Any reference -;;; to a TN in the IN set can be replaced with a reference to the TN moved -;;; from. When we delete all reads of such a TN, we can delete the MOVE VOP. -;;; IN is computed as the intersection of OUT for all the predecessor blocks. +;;; If a TN is in the IN set for a block, that TN is a copy of a TN +;;; which still has the same value it had at the time the move was +;;; done. Any reference to a TN in the IN set can be replaced with a +;;; reference to the TN moved from. When we delete all reads of such a +;;; TN, we can delete the MOVE VOP. IN is computed as the intersection +;;; of OUT for all the predecessor blocks. ;;; -;;; In this flow analysis scheme, the KILL set is the set of all interesting -;;; TNs where the copied TN is modified by the block (in any way.) +;;; In this flow analysis scheme, the KILL set is the set of all +;;; interesting TNs where the copied TN is modified by the block (in +;;; any way.) ;;; -;;; GEN is the set of all interesting TNs that are copied in the block (whose -;;; write appears in the block.) +;;; GEN is the set of all interesting TNs that are copied in the block +;;; (whose write appears in the block.) ;;; ;;; OUT is (union (difference IN KILL) GEN) ;;; If TN is subject to copy propagation, then return the TN it is a copy ;;; of, otherwise NIL. ;;; -;;; We also only consider TNs where neither the TN nor the copied TN are wired -;;; or restricted. If we extended the life of a wired or restricted TN, -;;; register allocation might fail, and we can't substitute arbitrary things -;;; for references to wired or restricted TNs, since the reader may be -;;; expencting the argument to be in a particular place (as in a passing -;;; location.) +;;; We also only consider TNs where neither the TN nor the copied TN +;;; are wired or restricted. If we extended the life of a wired or +;;; restricted TN, register allocation might fail, and we can't +;;; substitute arbitrary things for references to wired or restricted +;;; TNs, since the reader may be expencting the argument to be in a +;;; particular place (as in a passing location.) ;;; -;;; The TN must be a :NORMAL TN. Other TNs might have hidden references or be -;;; otherwise bizarre. +;;; The TN must be a :NORMAL TN. Other TNs might have hidden +;;; references or be otherwise bizarre. ;;; -;;; A TN is also inelegible if it has interned name, policy is such that we -;;; would dump it in the debug vars, and speed is not 3. +;;; A TN is also inelegible if it has interned name, policy is such +;;; that we would dump it in the debug vars, and speed is not 3. ;;; -;;; The SCs of the TN's primitive types is a subset of the SCs of the copied -;;; TN. Moves between TNs of different primitive type SCs may need to be -;;; changed into coercions, so we can't squeeze them out. The reason for -;;; testing for subset of the SCs instead of the same primitive type is -;;; that this test lets T be substituted for LIST, POSITIVE-FIXNUM for FIXNUM, -;;; etc. Note that more SCs implies fewer possible values, or a subtype -;;; relationship, since more SCs implies more possible representations. +;;; The SCs of the TN's primitive types is a subset of the SCs of the +;;; copied TN. Moves between TNs of different primitive type SCs may +;;; need to be changed into coercions, so we can't squeeze them out. +;;; The reason for testing for subset of the SCs instead of the same +;;; primitive type is that this test lets T be substituted for LIST, +;;; POSITIVE-FIXNUM for FIXNUM, etc. Note that more SCs implies fewer +;;; possible values, or a subtype relationship, since more SCs implies +;;; more possible representations. (defun tn-is-copy-of (tn) (declare (type tn tn)) (declare (inline subsetp)) @@ -85,10 +89,11 @@ (or (= speed 3) (< debug 2))))) arg-tn))))))) -;;; Init the sets in Block for copy propagation. To find Gen, we just look -;;; for MOVE vops, and then see whether the result is a eligible copy TN. To -;;; find Kill, we must look at all VOP results, seeing whether any of the -;;; reads of the written TN are copies for eligible TNs. +;;; Init the sets in Block for copy propagation. To find Gen, we just +;;; look for MOVE vops, and then see whether the result is a eligible +;;; copy TN. To find Kill, we must look at all VOP results, seeing +;;; whether any of the reads of the written TN are copies for eligible +;;; TNs. (defun init-copy-sets (block) (declare (type cblock block)) (let ((kill (make-sset)) @@ -117,9 +122,10 @@ (setf (block-gen block) gen)) (values)) -;;; Do the flow analysis step for copy propagation on Block. We rely on OUT -;;; being initialized to GEN, and use SSET-UNION-OF-DIFFERENCE to incrementally -;;; build the union in OUT, rather than replacing OUT each time. +;;; Do the flow analysis step for copy propagation on Block. We rely +;;; on OUT being initialized to GEN, and use SSET-UNION-OF-DIFFERENCE +;;; to incrementally build the union in OUT, rather than replacing OUT +;;; each time. (defun copy-flow-analysis (block) (declare (type cblock block)) (let* ((pred (block-pred block)) @@ -131,10 +137,11 @@ (defevent copy-deleted-move "Copy propagation deleted a move.") -;;; Return true if Arg is a reference to a TN that we can copy propagate to. -;;; In addition to dealing with copy chains (as discussed below), we also throw -;;; out references that are arguments to a local call, since IR2tran introduces -;;; tempes in that context to preserve parallel assignment semantics. +;;; Return true if ARG is a reference to a TN that we can copy +;;; propagate to. In addition to dealing with copy chains (as +;;; discussed below), we also discard references that are arguments +;;; to a local call, since IR2tran introduces temps in that context +;;; to preserve parallel assignment semantics. (defun ok-copy-ref (vop arg in original-copy-of) (declare (type vop vop) (type tn arg) (type sset in) (type hash-table original-copy-of)) @@ -151,38 +158,41 @@ (error "Couldn't find REF?")) (length (template-arg-types info)))))))) -;;; Make use of the result of flow analysis to eliminate copies. We scan -;;; the VOPs in block, propagating copies and keeping our IN set in sync. +;;; Make use of the result of flow analysis to eliminate copies. We +;;; scan the VOPs in block, propagating copies and keeping our IN set +;;; in sync. ;;; ;;; Original-Copy-Of is an EQ hash table that we use to keep track of -;;; renamings when there are copy chains, i.e. copies of copies. When we see -;;; copy of a copy, we enter the first copy in the table with the second copy -;;; as a key. When we see a reference to a TN in a copy chain, we can only -;;; substitute the first copied TN for the reference when all intervening -;;; copies in the copy chain are also available. Otherwise, we just leave the -;;; reference alone. It is possible that we might have been able to reference -;;; one of the intermediate copies instead, but that copy might have already -;;; been deleted, since we delete the move immediately when the references go -;;; to zero. +;;; renamings when there are copy chains, i.e. copies of copies. When +;;; we see copy of a copy, we enter the first copy in the table with +;;; the second copy as a key. When we see a reference to a TN in a +;;; copy chain, we can only substitute the first copied TN for the +;;; reference when all intervening copies in the copy chain are also +;;; available. Otherwise, we just leave the reference alone. It is +;;; possible that we might have been able to reference one of the +;;; intermediate copies instead, but that copy might have already been +;;; deleted, since we delete the move immediately when the references +;;; go to zero. ;;; -;;; To understand why we always can to the substitution when the copy chain -;;; recorded in the Original-Copy-Of table hits NIL, note that we make an entry -;;; in the table iff we change the arg of a copy. If an entry is not in the -;;; table, it must be that we hit a move which *originally* referenced our -;;; Copy-Of TN. If all the intervening copies reach our reference, then -;;; Copy-Of must reach the reference. +;;; To understand why we always can to the substitution when the copy +;;; chain recorded in the Original-Copy-Of table hits NIL, note that +;;; we make an entry in the table iff we change the arg of a copy. If +;;; an entry is not in the table, it must be that we hit a move which +;;; *originally* referenced our Copy-Of TN. If all the intervening +;;; copies reach our reference, then Copy-Of must reach the reference. ;;; -;;; Note that due to our restricting copies to single-writer TNs, it will -;;; always be the case that when the first copy in a chain reaches the -;;; reference, all intervening copies reach also reach the reference. We -;;; don't exploit this, since we have to work backward from the last copy. +;;; Note that due to our restricting copies to single-writer TNs, it +;;; will always be the case that when the first copy in a chain +;;; reaches the reference, all intervening copies reach also reach the +;;; reference. We don't exploit this, since we have to work backward +;;; from the last copy. ;;; -;;; In this discussion, we are really only playing with the tail of the true -;;; copy chain for which all of the copies have already had PROPAGATE-COPIES -;;; done on them. But, because we do this pass in DFO, it is virtually always -;;; the case that we will process earlier copies before later ones. In -;;; perverse cases (non-reducible flow graphs), we just miss some optimization -;;; opportinities. +;;; In this discussion, we are really only playing with the tail of +;;; the true copy chain for which all of the copies have already had +;;; PROPAGATE-COPIES done on them. But, because we do this pass in +;;; DFO, it is virtually always the case that we will process earlier +;;; copies before later ones. In perverse cases (non-reducible flow +;;; graphs), we just miss some optimization opportinities. (defun propagate-copies (block original-copy-of) (declare (type cblock block) (type hash-table original-copy-of)) (let ((in (block-in block))) diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 8ed1ba1..833ceac 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/src/compiler/generic/vm-fndb.lisp @@ -257,6 +257,14 @@ (simple-unboxed-array (*)) index index) null ()) + +;;; (not really a bit-bashing routine, but starting to take over from +;;; bit-bashing routines in byte-sized copies as of sbcl-0.6.12.29:) +(defknown %byte-blt + ((or (simple-unboxed-array (*)) system-area-pointer) index + (or (simple-unboxed-array (*)) system-area-pointer) index index) + null + ()) ;;;; code/function/fdefn object manipulation routines diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 672b1a2..2156e05 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -244,7 +244,7 @@ (setf (%raw-bits result-bit-array index) (32bit-logical-not (%raw-bits bit-array index)))))) -;;;; primitive translator for BYTE-BLT +;;;; BYTE-BLT (def-primitive-translator byte-blt (src src-start dst dst-start dst-end) @@ -253,20 +253,37 @@ ;; FIXME: CMU CL had a hairier implementation of this. It had the ;; small problem that it didn't work for large (>16M) values of ;; SRC-START or DST-START. However, it might have been more - ;; efficient. In particular, I haven't checked how much the foreign - ;; function call costs us here. My guess is that if the overhead is - ;; acceptable for SQRT and COS, it's acceptable here, but this - ;; should probably be checked. -- WHN - (once-only ((dst-start dst-start)) - `(flet ((sap (thing) + ;; efficient. In particular, I don't really know how much the + ;; foreign function call costs us here. My guess is that if the + ;; overhead is acceptable for SQRT and COS, it's acceptable here, + ;; but this should probably be checked. -- WHN + (once-only ((src-start src-start) + (dst-start dst-start)) + `(flet ((->sap (thing) (etypecase thing (system-area-pointer thing) + ;; FIXME: The code here rather relies on the simple + ;; unboxed array here having byte-sized entries. That + ;; should be asserted explicitly, I just haven't found + ;; a concise way of doing it. (It would be nice to + ;; declare it in the DEFKNOWN too.) ((simple-unboxed-array (*)) (vector-sap thing))))) - (declare (inline sap)) + (declare (inline ->sap)) (without-gcing - (memmove (sap+ (sap ,dst) ,dst-start) - (sap+ (sap ,src) ,src-start) - (- ,dst-end ,dst-start)))))) + (memmove (sap+ (->sap ,dst) ,dst-start) + (sap+ (->sap ,src) ,src-start) + (- ,dst-end ,dst-start))) + nil))) + +;;; FIXME: The old CMU CL code used various COPY-TO/FROM-SYSTEM-AREA +;;; stuff (with all the associated bit-index cruft and overflow +;;; issues) even for byte moves. In SBCL, we're converting to byte +;;; moves as problems are discovered with the old code, and this is +;;; currently (ca. sbcl-0.6.12.30) the main interface for code in +;;; SB!KERNEL and SB!SYS (e.g. i/o code). It's not clear that it's the +;;; ideal interface, though, and it probably deserves some thought. +(deftransform %byte-blt ((a1 a2 a3 a4 a5) (t t t t t)) + '(%primitive byte-blt a1 a2 a3 a4 a5)) ;;;; transforms for EQL of floating point values diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 1036aff..467ec14 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -96,26 +96,135 @@ (assert (not (subtypep 'symbol 'keyword))) (assert (subtypep 'ratio 'real)) (assert (subtypep 'ratio 'number)) + +;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to allow +;;;; inline type tests for CONDITIONs and STANDARD-OBJECTs, and generally +;;;; be nicer, and Martin Atzmueller ported the patches. +;;;; They look nice but they're nontrivial enough that it's not obvious +;;;; from inspection that everything is OK. Let's make sure that things +;;;; still basically work. -;;; Pierre Mai rewrote the CMU CL type test system to allow inline -;;; type tests for CONDITIONs and STANDARD-OBJECTs, and generally be -;;; nicer, and Martin Atzmueller ported the patches. They look nice -;;; but they're nontrivial enough that it's not obvious from -;;; inspection that everything is OK. Let's make sure that things -;;; still basically work. -(defstruct foo1) -(defstruct (foo2 (:include foo1)) +;; structure type tests setup +(defstruct structure-foo1) +(defstruct (structure-foo2 (:include structure-foo1)) x) -(defstruct (foo3 (:include foo2))) -(defstruct (foo4 (:include foo3)) +(defstruct (structure-foo3 (:include structure-foo2))) +(defstruct (structure-foo4 (:include structure-foo3)) y z) -(assert (typep (make-foo3) 'foo2)) -(assert (not (typep (make-foo1) 'foo4))) -(assert (null (ignore-errors (setf (foo2-x (make-foo1)) 11)))) -;;; (More tests here would be nice before merging the patches. More -;;; tests for STRUCTURE-OBJECT, tests for CONDITION, tests for -;;; STANDARD-OBJECT, compiled tests to make sure that the inline -;;; versions of the tests work..) + +;; structure-class tests setup +(defclass structure-class-foo1 () () (:metaclass cl:structure-class)) +(defclass structure-class-foo2 (structure-class-foo1) + () (:metaclass cl:structure-class)) +(defclass structure-class-foo3 (structure-class-foo2) + () (:metaclass cl:structure-class)) +(defclass structure-class-foo4 (structure-class-foo3) + () (:metaclass cl:structure-class)) + +;; standard-class tests setup +(defclass standard-class-foo1 () () (:metaclass cl:standard-class)) +(defclass standard-class-foo2 (standard-class-foo1) + () (:metaclass cl:standard-class)) +(defclass standard-class-foo3 (standard-class-foo2) + () (:metaclass cl:standard-class)) +(defclass standard-class-foo4 (standard-class-foo3) + () (:metaclass cl:standard-class)) + +;; condition tests setup +(define-condition condition-foo1 (condition) ()) +(define-condition condition-foo2 (condition-foo1) ()) +(define-condition condition-foo3 (condition-foo2) ()) +(define-condition condition-foo4 (condition-foo3) ()) + +(fmakunbound 'test-inline-type-tests) +(defun test-inline-type-tests () + ;; structure type tests + (assert (typep (make-structure-foo3) 'structure-foo2)) + (assert (not (typep (make-structure-foo1) 'structure-foo4))) + (assert (null (ignore-errors + (setf (structure-foo2-x (make-structure-foo1)) 11)))) + + ;; structure-class tests + (assert (typep (make-instance 'structure-class-foo3) + 'structure-class-foo2)) + (assert (not (typep (make-instance 'structure-class-foo1) + 'structure-class-foo4))) + (assert (null (ignore-errors + (setf (slot-value (make-instance 'structure-class-foo1) 'x) + 11)))) + + ;; standard-class tests + (assert (typep (make-instance 'standard-class-foo3) + 'standard-class-foo2)) + (assert (not (typep (make-instance 'standard-class-foo1) + 'standard-class-foo4))) + (assert (null (ignore-errors + (setf (slot-value (make-instance 'standard-class-foo1) 'x) + 11)))) + + ;; condition tests + (assert (typep (make-condition 'condition-foo3) + 'condition-foo2)) + (assert (not (typep (make-condition 'condition-foo1) + 'condition-foo4))) + (assert (null (ignore-errors + (setf (slot-value (make-condition 'condition-foo1) 'x) + 11)))) + + (assert (eq (car (sb-kernel:class-direct-superclasses (find-class + 'simple-condition))) + (find-class 'condition))) + + (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class + 'simple-condition))) + (sb-pcl:find-class 'condition))) + (assert (null (set-difference + (sb-pcl:class-direct-subclasses (sb-pcl:find-class + 'simple-condition)) + (mapcar #'sb-pcl:find-class '(simple-type-error simple-error + sb-int:simple-style-warning))))) + ;; precedence lists + (assert (equal (sb-pcl:class-precedence-list + (sb-pcl:find-class 'simple-condition)) + (mapcar #'sb-pcl:find-class '(simple-condition condition + sb-kernel:instance t)))) + + ;; stream classes + (assert (null (sb-kernel:class-direct-superclasses (find-class + 'fundamental-stream)))) + (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class + 'fundamental-stream)) + (mapcar #'sb-pcl:find-class '(standard-object stream)))) + (assert (null (set-difference + (sb-pcl:class-direct-subclasses (sb-pcl:find-class + 'fundamental-stream)) + (mapcar #'sb-pcl:find-class '(fundamental-binary-stream + fundamental-character-stream + fundamental-output-stream + fundamental-input-stream))))) + (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class + 'fundamental-stream)) + (mapcar #'sb-pcl:find-class '(fundamental-stream + standard-object + sb-pcl::std-object + sb-pcl::slot-object + stream + sb-kernel:instance + t)))) + (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class + 'fundamental-stream)) + (mapcar #'sb-pcl:find-class '(fundamental-stream + standard-object + sb-pcl::std-object + sb-pcl::slot-object stream + sb-kernel:instance t))))) + +;;; inline-type tests: +;;; Test the interpreted version. +(test-inline-type-tests) +;;; Test the compiled version. +(compile nil #'test-inline-type-tests) +(test-inline-type-tests) ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index c233468..d78a06a 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.12.29" +"0.6.12.30" -- 1.7.10.4