gcl-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: [Gcl-devel] [Maxima] make-array with initial-contents in gcl is slow


From: Camm Maguire
Subject: Re: [Gcl-devel] [Maxima] make-array with initial-contents in gcl is slow
Date: Wed, 18 Jan 2012 13:00:27 -0500
User-agent: Gnus/5.13 (Gnus v5.13) Emacs/23.2 (gnu/linux)

Greetings!  And thanks for your report!

If you would cae to try out the pach below, I'd be most appreciative!

=============================================================================
Index: lsp/gcl_arraylib.lsp
===================================================================
RCS file: /sources/gcl/gcl/lsp/gcl_arraylib.lsp,v
retrieving revision 1.1.2.1
diff -u -u -r1.1.2.1 gcl_arraylib.lsp
--- lsp/gcl_arraylib.lsp        14 Sep 2003 02:30:35 -0000      1.1.2.1
+++ lsp/gcl_arraylib.lsp        18 Jan 2012 17:58:46 -0000
@@ -74,47 +74,73 @@
 
 (defun make-array (dimensions
                   &key (element-type t)
-                       (initial-element nil)
+                       initial-element
                        (initial-contents nil initial-contents-supplied-p)
                        adjustable fill-pointer
                        displaced-to (displaced-index-offset 0)
                        static)
   (when (integerp dimensions) (setq dimensions (list dimensions)))
-  (setq element-type (best-array-element-type element-type))
-  (cond ((= (length dimensions) 1)
-        (let ((x (si:make-vector element-type (car dimensions)
-                                 adjustable fill-pointer
-                                 displaced-to displaced-index-offset
-                                 static initial-element)))
-          (when initial-contents-supplied-p
-                (do ((n (car dimensions))
-                     (i 0 (1+ i)))
-                    ((>= i n))
-                  (declare (fixnum n i))
-                  (si:aset x i (elt initial-contents i))))
-          x))
-        (t
-        (let ((x
-               (make-array1
-                      (the fixnum(get-aelttype element-type))
-                       static initial-element 
-                      displaced-to (the fixnum displaced-index-offset)
-                      dimensions)))
-          (if fill-pointer (error "fill pointer for 1 dimensional arrays 
only"))
-           (unless (member 0 dimensions)
-          (when initial-contents-supplied-p
-                (do ((cursor
-                      (make-list (length dimensions)
-                                 :initial-element 0)))
-                    (nil)
-                    (declare (:dynamic-extent cursor))
-                  (aset-by-cursor x
-                                  (sequence-cursor initial-contents
-                                                   cursor)
-                                  cursor)
-                  (when (increment-cursor cursor dimensions)
-                          (return nil)))))
-            x))))
+  (setq element-type (or (upgraded-array-element-type element-type) 
'character))
+  (if (= (length dimensions) 1)
+      (let ((x (si:make-vector element-type (car dimensions) adjustable (when 
fill-pointer (car dimensions))
+                              displaced-to displaced-index-offset static 
initial-element)))
+       (when initial-contents-supplied-p
+         (replace x initial-contents))
+       (when (and fill-pointer (not (eq t fill-pointer))) (setf (fill-pointer 
x) fill-pointer))
+       x)
+    (let ((x (make-array1 (get-aelttype element-type) static initial-element 
displaced-to displaced-index-offset dimensions)))
+      (if fill-pointer (error "fill pointer for 1 dimensional arrays only"))
+      (unless (member 0 dimensions)
+       (when initial-contents-supplied-p
+         (do ((j nil t)(cursor (make-list (length dimensions) :initial-element 
0)))
+             ((when j (increment-cursor cursor dimensions)))
+             (declare (:dynamic-extent cursor))
+             (aset-by-cursor x (sequence-cursor initial-contents cursor) 
cursor))))
+      x)))
+
+;; (defun make-array (dimensions
+;;                &key (element-type t)
+;;                     (initial-element nil)
+;;                     (initial-contents nil initial-contents-supplied-p)
+;;                     adjustable fill-pointer
+;;                     displaced-to (displaced-index-offset 0)
+;;                     static)
+;;   (when (integerp dimensions) (setq dimensions (list dimensions)))
+;;   (setq element-type (best-array-element-type element-type))
+;;   (cond ((= (length dimensions) 1)
+;;      (let ((x (si:make-vector element-type (car dimensions)
+;;                               adjustable fill-pointer
+;;                               displaced-to displaced-index-offset
+;;                               static initial-element)))
+;;        (when initial-contents-supplied-p
+;;              (do ((n (car dimensions))
+;;                   (i 0 (1+ i)))
+;;                  ((>= i n))
+;;                (declare (fixnum n i))
+;;                (si:aset x i (elt initial-contents i))))
+;;        x))
+;;         (t
+;;      (let ((x
+;;             (make-array1
+;;                    (the fixnum(get-aelttype element-type))
+;;                     static initial-element 
+;;                    displaced-to (the fixnum displaced-index-offset)
+;;                    dimensions)))
+;;        (if fill-pointer (error "fill pointer for 1 dimensional arrays 
only"))
+;;            (unless (member 0 dimensions)
+;;        (when initial-contents-supplied-p
+;;              (do ((cursor
+;;                    (make-list (length dimensions)
+;;                               :initial-element 0)))
+;;                  (nil)
+;;                  (declare (:dynamic-extent cursor))
+;;                (aset-by-cursor x
+;;                                (sequence-cursor initial-contents
+;;                                                 cursor)
+;;                                cursor)
+;;                (when (increment-cursor cursor dimensions)
+;;                           (return nil)))))
+;;             x))))
 
 
 (defun increment-cursor (cursor dimensions)
Index: lsp/gcl_seqlib.lsp
===================================================================
RCS file: /sources/gcl/gcl/lsp/gcl_seqlib.lsp,v
retrieving revision 1.1.2.2
diff -u -u -r1.1.2.2 gcl_seqlib.lsp
--- lsp/gcl_seqlib.lsp  20 Mar 2004 02:00:01 -0000      1.1.2.2
+++ lsp/gcl_seqlib.lsp  18 Jan 2012 17:58:46 -0000
@@ -149,33 +149,53 @@
                     (setf (elt sequence i) item))))
 
 
-(defun replace (sequence1 sequence2
-               &key start1  end1
-                    start2 end2 )
-  (with-start-end start1 end1 sequence1
-     (with-start-end start2 end2 sequence2               
-    (if (and (eq sequence1 sequence2)
-             (> start1 start2))
-        (do* ((i 0 (f+ 1 i))
-              (l (if (<  (f- end1 start1)
-                         (f- end2 start2))
-                      (f- end1 start1)
-                      (f- end2 start2)))
-              (s1 (f+ start1  (f+ -1 l)) (f+ -1 s1))
-              (s2 (f+ start2  (f+ -1 l)) (f+ -1 s2)))
-            ((>= i l) sequence1)
-          (declare (fixnum i l s1 s2))
-          (setf (elt sequence1 s1) (elt sequence2 s2)))
-        (do ((i 0 (f+ 1 i))
-             (l (if (<  (f- end1 start1)
-                        (f- end2 start2))
-                    (f- end1 start1)
-                    (f- end2 start2)))
-             (s1 start1 (f+ 1 s1))
-             (s2 start2 (f+ 1 s2)))
-            ((>= i l) sequence1)
-          (declare (fixnum i l s1 s2))
-          (setf (elt sequence1 s1) (elt sequence2 s2)))))))
+(defun replace (s1 s2 &key (start1 0) end1 (start2 0) end2 &aux (os1 s1) s3)
+  (declare (optimize (safety 1))(notinline make-list)(dynamic-extent s3))
+  (check-type s1 sequence)
+  (check-type s2 sequence)
+  (check-type start1 seqind)
+  (check-type start2 seqind)
+  (check-type end1 (or null seqind))
+  (check-type end2 (or null seqind))
+  (when (and (eq s1 s2) (> start1 start2))
+    (setq s3 (make-list (length s2)) s2 (replace s3 s2)))
+  (let* ((lp1 (listp s1)) (lp2 (listp s2))
+        (e1 (or end1 (if lp1 array-dimension-limit (length s1))))
+        (e2 (or end2 (if lp2 array-dimension-limit (length s2)))))
+    (do ((i1 start1 (1+ i1))(i2 start2 (1+ i2))
+        (s1 (if lp1 (nthcdr start1 s1) s1) (if lp1 (cdr s1) s1))
+        (s2 (if lp2 (nthcdr start2 s2) s2) (if lp2 (cdr s2) s2)))
+       ((or (not s1) (>= i1 e1) (not s2) (>= i2 e2)) os1)
+       (let ((e2 (if lp2 (car s2) (aref s2 i2))))
+         (if lp1 (setf (car s1) e2) (setf (aref s1 i1) e2))))))
+
+;; (defun replace (sequence1 sequence2
+;;             &key start1  end1
+;;                  start2 end2 )
+;;   (with-start-end start1 end1 sequence1
+;;      (with-start-end start2 end2 sequence2            
+;;     (if (and (eq sequence1 sequence2)
+;;              (> start1 start2))
+;;         (do* ((i 0 (f+ 1 i))
+;;               (l (if (<  (f- end1 start1)
+;;                          (f- end2 start2))
+;;                       (f- end1 start1)
+;;                       (f- end2 start2)))
+;;               (s1 (f+ start1  (f+ -1 l)) (f+ -1 s1))
+;;               (s2 (f+ start2  (f+ -1 l)) (f+ -1 s2)))
+;;             ((>= i l) sequence1)
+;;           (declare (fixnum i l s1 s2))
+;;           (setf (elt sequence1 s1) (elt sequence2 s2)))
+;;         (do ((i 0 (f+ 1 i))
+;;              (l (if (<  (f- end1 start1)
+;;                         (f- end2 start2))
+;;                     (f- end1 start1)
+;;                     (f- end2 start2)))
+;;              (s1 start1 (f+ 1 s1))
+;;              (s2 start2 (f+ 1 s2)))
+;;             ((>= i l) sequence1)
+;;           (declare (fixnum i l s1 s2))
+;;           (setf (elt sequence1 s1) (elt sequence2 s2)))))))
 
 
 ;;; DEFSEQ macro.
=============================================================================

John Lapeyre <address@hidden> writes:

> In gcl make-array with :initial-contents from a list
> is poorly implemented in that the copying is O(n^2).
> A test on one machine shows that initializing a
> list of length of 5 10^4 takes 1 minute in gcl and a few ms in sbcl.
>
> This potentially affects some code in the share directory.
>
> The relevant part of the gcl code in make-array is:
>
> ((= (length dimensions) 1)
>        (let ((x (si:make-vector element-type (car dimensions)
>                                 adjustable fill-pointer
>                                 displaced-to displaced-index-offset
>                                 static initial-element)))
>          (when initial-contents-supplied-p
>                (do ((n (car dimensions))
>                     (i 0 (1+ i)))
>                    ((>= i n))
>                  (declare (fixnum n i))
>                  (si:aset x i (elt initial-contents i))))
>          x))
>
> The following passed a quick test:
>
> ((= (length dimensions) 1)
>        (let ((x (si:make-vector element-type (car dimensions)
>                                 adjustable fill-pointer
>                                 displaced-to displaced-index-offset
>                                 static initial-element)))
>          (when initial-contents-supplied-p
>              (if (listp initial-contents)
>                  (do ( (e initial-contents (cdr e))
>                         (i 0 (1+ i)))
>                      ((null e))
>                    (declare (fixnum i))
>                    (si:aset x i (car e)))
>                (do ((n (car dimensions))
>                     (i 0 (1+ i)))
>                    ((>= i n))
>                  (declare (fixnum n i))
>                  (si:aset x i (elt initial-contents i)))))
>            x))
>
> -- John Lapeyre
> _______________________________________________
> Maxima mailing list
> address@hidden
> http://www.math.utexas.edu/mailman/listinfo/maxima
>
>
>
>

-- 
Camm Maguire                                        address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah



reply via email to

[Prev in Thread] Current Thread [Next in Thread]