From 397b000303e15df61661d9726126ee99ee10d9c6 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 8 Aug 2001 15:06:17 +0000 Subject: [PATCH] 0.pre7.3: moved more contrib/*-extras.lisp stuff to main system.. ..INDEX-OR-MINUS-1 ..FILL ..COERCE --- contrib/compiler-extras.lisp | 44 ----------------------------- package-data-list.lisp-expr | 1 + src/code/coerce.lisp | 4 +++ src/code/deftypes-for-target.lisp | 9 +++++- src/compiler/seqtran.lisp | 20 ++++++++++---- src/compiler/typetran.lisp | 55 ++++++++----------------------------- version.lisp-expr | 2 +- 7 files changed, 41 insertions(+), 94 deletions(-) diff --git a/contrib/compiler-extras.lisp b/contrib/compiler-extras.lisp index 421ad18..15fa799 100644 --- a/contrib/compiler-extras.lisp +++ b/contrib/compiler-extras.lisp @@ -25,27 +25,8 @@ (in-package "SB-C") -(deftype index-or-minus-1 () `(integer -1 ,(1- most-positive-fixnum))) - (declaim (optimize (speed 1) (space 2))) -(deftransform fill ((seq item &key (start 0) (end (length seq))) - (vector t &key (:start t) (:end index)) - * - :policy (> speed space)) - "open code" - (let ((element-type (upgraded-element-type-specifier-or-give-up seq))) - `(with-array-data ((data seq) - (start start) - (end end)) - (declare (type (simple-array ,element-type 1) data)) - (do ((i start (1+ i))) - ((= i end) seq) - (declare (type index i)) - ;; WITH-ARRAY-DATA does our range checks once and for all, so - ;; it'd be wasteful to check again on every AREF. - (declare (optimize (safety 0))) - (setf (aref data i) item))))) ;;; TO DO for DEFTRANSFORM FILL: ;;; ?? This DEFTRANSFORM, and the old DEFTRANSFORMs, should only ;;; apply when SPEED > SPACE. @@ -102,31 +83,6 @@ (incf index2)))))) seq1))) -(setf (function-info-transforms (info :function :info 'coerce)) nil) -(deftransform coerce ((x type) (* *) * :when :both) - (unless (constant-continuation-p type) - (give-up-ir1-transform)) - (let ((tspec (specifier-type (continuation-value type)))) - (if (csubtypep (continuation-type x) tspec) - 'x - ;; Note: The THE here makes sure that specifiers like - ;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR. - `(the ,(continuation-value type) - ,(cond - ((csubtypep tspec (specifier-type 'double-float)) - '(%double-float x)) - ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed")) - ((csubtypep tspec (specifier-type 'float)) - '(%single-float x)) - ((csubtypep tspec (specifier-type 'simple-vector)) - '(coerce-to-simple-vector x)) ; FIXME: needs DEFKNOWN return type - (t - (give-up-ir1-transform))))))) -(defun coerce-to-simple-vector (x) - (if (simple-vector-p x) - x - (replace (make-array (length x)) x))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; setting up for POSITION/FIND stuff diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index dd2495e..bf2ca3e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1039,6 +1039,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "HAIRY-TYPE-CHECK-TEMPLATE-NAME" "HAIRY-TYPE-SPECIFIER" "HANDLE-CIRCULARITY" "IGNORE-IT" "ILL-BIN" "ILL-BOUT" "ILL-IN" "ILL-OUT" + "INDEX-OR-MINUS-1" "INDEX-TOO-LARGE-ERROR" "*!INITIAL-ASSEMBLER-ROUTINES*" "*!INITIAL-FDEFN-OBJECTS*" "*!INITIAL-FOREIGN-SYMBOLS*" diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index 7b8a2fc..dc97323 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -128,6 +128,10 @@ (etypecase object (list (list-to-bit-vector* object)) (vector (vector-to-bit-vector* object)))) +(defun coerce-to-simple-vector (x) + (if (simple-vector-p x) + x + (replace (make-array (length x)) x))) (defun coerce-to-vector (object output-type-spec) (etypecase object (list (list-to-vector* object output-type-spec)) diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp index 50bee46..9efcd36 100644 --- a/src/code/deftypes-for-target.lisp +++ b/src/code/deftypes-for-target.lisp @@ -98,7 +98,8 @@ (sb!xc:deftype simple-bit-vector (&optional size) `(simple-array bit (,size))) -;;;; some private types that we use in defining the standard functions +;;;; some private types that we use in defining the standard functions, +;;;; or implementing declarations in standard compiler transforms ;;; a type specifier (sb!xc:deftype type-specifier () '(or list symbol sb!xc:class)) @@ -125,6 +126,12 @@ (sb!xc:deftype logical-host-designator () '(or host string)) +;;; like INDEX, but augmented with -1 (useful when using the index +;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with +;;; an implementation which terminates the loop by testing for the +;;; index leaving the loop range) +(sb!xc:deftype index-or-minus-1 () `(integer -1 ,(1- most-positive-fixnum))) + ;;; a thing returned by the irrational functions. We assume that they ;;; never compute a rational result. (sb!xc:deftype irrational () diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 05066fa..6e39e29 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -296,12 +296,22 @@ (T (setq splice x))))) (deftransform fill ((seq item &key (start 0) (end (length seq))) - (simple-array t &key (:start t) (:end index))) + (vector t &key (:start t) (:end index)) + * + :policy (> speed space)) "open code" - '(do ((i start (1+ i))) - ((= i end) seq) - (declare (type index i)) - (setf (aref seq i) item))) + (let ((element-type (upgraded-element-type-specifier-or-give-up seq))) + `(with-array-data ((data seq) + (start start) + (end end)) + (declare (type (simple-array ,element-type 1) data)) + (do ((i start (1+ i))) + ((= i end) seq) + (declare (type index i)) + ;; WITH-ARRAY-DATA did our range checks once and for all, so + ;; it'd be wasteful to check again on every AREF. + (declare (optimize (safety 0))) + (setf (aref data i) item))))) (deftransform position ((item list &key (test #'eql)) (t list)) "open code" diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 25e3cf9..e569f47 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -542,54 +542,23 @@ ;;;; coercion -;;; old working version (deftransform coerce ((x type) (* *) * :when :both) (unless (constant-continuation-p type) (give-up-ir1-transform)) (let ((tspec (specifier-type (continuation-value type)))) (if (csubtypep (continuation-type x) tspec) 'x + ;; Note: The THE here makes sure that specifiers like + ;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR. `(the ,(continuation-value type) - ,(cond ((csubtypep tspec (specifier-type 'double-float)) - '(%double-float x)) - ;; FIXME: If LONG-FLOAT is to be supported, we - ;; need to pick it off here before falling through - ;; to %SINGLE-FLOAT. - ((csubtypep tspec (specifier-type 'float)) - '(%single-float x)) - (t - (give-up-ir1-transform))))))) + ,(cond + ((csubtypep tspec (specifier-type 'double-float)) + '(%double-float x)) + ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed")) + ((csubtypep tspec (specifier-type 'float)) + '(%single-float x)) + ((csubtypep tspec (specifier-type 'simple-vector)) + '(coerce-to-simple-vector x)) + (t + (give-up-ir1-transform))))))) -;;; KLUDGE: new broken version -- 20000504 -;;; FIXME: should be fixed or deleted -#+nil -(deftransform coerce ((x type) (* *) * :when :both) - (unless (constant-continuation-p type) - (give-up-ir1-transform)) - (let ((tspec (specifier-type (continuation-value type)))) - (if (csubtypep (continuation-type x) tspec) - 'x - `(if #+nil (typep x type) #-nil nil - x - (the ,(continuation-value type) - ,(cond ((csubtypep tspec (specifier-type 'double-float)) - '(%double-float x)) - ;; FIXME: If LONG-FLOAT is to be supported, - ;; we need to pick it off here before falling - ;; through to %SINGLE-FLOAT. - ((csubtypep tspec (specifier-type 'float)) - '(%single-float x)) - #+nil - ((csubtypep tspec (specifier-type 'list)) - '(coerce-to-list x)) - #+nil - ((csubtypep tspec (specifier-type 'string)) - '(coerce-to-simple-string x)) - #+nil - ((csubtypep tspec (specifier-type 'bit-vector)) - '(coerce-to-bit-vector x)) - #+nil - ((csubtypep tspec (specifier-type 'vector)) - '(coerce-to-vector x type)) - (t - (give-up-ir1-transform)))))))) diff --git a/version.lisp-expr b/version.lisp-expr index 1564d8a..ca1ccf5 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -16,4 +16,4 @@ ;;; four numeric fields, is used for versions which aren't released ;;; but correspond only to CVS tags or snapshots. -"0.pre7.2" +"0.pre7.3" -- 1.7.10.4