[Sbcl-commits] CVS: sbcl/src/compiler array-tran.lisp,1.48,1.49 seqtran.lisp,1.44,1.45

[Alexey D. <ade...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv26689/src/compiler

Modified Files:
	array-tran.lisp seqtran.lisp 
Log Message:
0.8.0.65:
        * SB-CLTL2: first try on VARIABLE-INFORMATION;

        * MAKE-ARRAY: infer array size in complex case;

        * second look at CONCATENATE optimization: create new START
          variable for each sequence. It would be nice to write a
          regression test for

           (time (compile nil
                          '(lambda ()
                            (list (concatenate 'string
                                   "qqqqqqqqqqqqqqqqqqqqqq"
                                   "tttttttttttttttttttttttttt"
                                   "wwwwwwwwwwwwwwwwwwwwwwwwwwww")))))


Index: array-tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/array-tran.lisp,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -d -r1.48 -r1.49
--- array-tran.lisp	10 Jun 2003 11:08:12 -0000	1.48
+++ array-tran.lisp	13 Jun 2003 09:04:21 -0000	1.49
@@ -111,11 +111,10 @@
 (defoptimizer (%with-array-data derive-type) ((array start end))
   (let ((atype (continuation-type array)))
     (when (array-type-p atype)
-      (values-specifier-type
-       `(values (simple-array ,(type-specifier
-				(array-type-specialized-element-type atype))
-			      (*))
-		index index index)))))
+      (specifier-type
+       `(simple-array ,(type-specifier
+                       (array-type-specialized-element-type atype))
+                     (*))))))
 
 (defoptimizer (array-row-major-index derive-type) ((array &rest indices))
   (assert-array-rank array (length indices))
@@ -140,9 +139,7 @@
                     (continuation-value element-type))
                    (t
                     '*))
-            ,(cond ((not simple)
-                    '*)
-                   ((constant-continuation-p dims)
+            ,(cond ((constant-continuation-p dims)
                     (let ((val (continuation-value dims)))
                       (if (listp val) val (list val))))
                    ((csubtypep (continuation-type dims)

Index: seqtran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/seqtran.lisp,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -d -r1.44 -r1.45
--- seqtran.lisp	3 May 2003 18:26:54 -0000	1.44
+++ seqtran.lisp	13 Jun 2003 09:04:21 -0000	1.45
@@ -721,33 +721,31 @@
 			   (t &rest simple-string)
 			   simple-string
 			   :policy (< safety 3))
-  (collect ((lets)
-	    (forms)
-	    (all-lengths)
-	    (args))
-    (dolist (seq sequences)
-      (declare (ignorable seq))
-      (let ((n-seq (gensym))
-	    (n-length (gensym)))
-	(args n-seq)
-	(lets `(,n-length (the index (* (length ,n-seq) sb!vm:n-byte-bits))))
-	(all-lengths n-length)
-	(forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
-			       res start
-			       ,n-length))
-	(forms `(setq start (opaque-identity (+ start ,n-length))))))
-    `(lambda (rtype ,@(args))
-       (declare (ignore rtype))
-       ;; KLUDGE
-       (flet ((opaque-identity (x) x))
-	 (declare (notinline opaque-identity))
-	 (let* (,@(lets)
-		  (res (make-string (truncate (the index (+ ,@(all-lengths)))
-					      sb!vm:n-byte-bits)))
-		  (start ,vector-data-bit-offset))
-	   (declare (type index start ,@(all-lengths)))
-	   ,@(forms)
-	   res)))))
+  (loop for rest-seqs on sequences
+        for n-seq = (gensym "N-SEQ")
+        for n-length = (gensym "N-LENGTH")
+        for start = vector-data-bit-offset then next-start
+        for next-start = (gensym "NEXT-START")
+        collect n-seq into args
+        collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets
+        collect n-length into all-lengths
+        collect next-start into starts
+        collect `(bit-bash-copy ,n-seq ,vector-data-bit-offset
+                                res ,start ,n-length)
+                into forms
+        collect `(setq ,next-start (+ ,start ,n-length)) into forms
+        finally
+        (return
+          `(lambda (rtype ,@args)
+             (declare (ignore rtype))
+             (let* (,@lets
+                      (res (make-string (truncate (the index (+ ,@all-lengths))
+                                                  sb!vm:n-byte-bits))))
+               (declare (type index ,@all-lengths))
+               (let (,@(mapcar (lambda (name) `(,name 0)) starts))
+                 (declare (type index ,@starts))
+                 ,@forms)
+               res)))))
 
 ;;;; CONS accessor DERIVE-TYPE optimizers