Change file folders to store their messages in a vector rather than a

list.  The linear-time lookup was killing performance on large
folders.

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index be34008660c8963be3302f0869c87e228da48d93..677b184d21ab6fb21013014fa541330a7e3a429e 100644 (file)
--- a/v7/src/imail/imail-file.scm
+++ b/v7/src/imail/imail-file.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-file.scm,v 1.60 2001/03/19 19:32:58 cph Exp $
+;;; $Id: imail-file.scm,v 1.61 2001/03/19 22:51:48 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -157,7 +157,7 @@
        (if (not (eq? 'UNKNOWN messages))
           (begin
             (set-file-folder-messages! folder 'UNKNOWN)
-            (for-each detach-message! messages)))))))
+            (for-each-vector-element messages detach-message!)))))))
 
 (define (discard-file-folder-xstring folder)
   (without-interrupts
@@ -167,10 +167,10 @@
      (set-file-folder-file-modification-count! folder #f))))
 
 (define-method folder-length ((folder <file-folder>))
-  (length (file-folder-messages folder)))
+  (vector-length (file-folder-messages folder)))
 
 (define-method %get-message ((folder <file-folder>) index)
-  (list-ref (file-folder-messages folder) index))
+  (vector-ref (file-folder-messages folder) index))
 
 (define-method %append-message ((message <message>) (url <file-url>))
   (let ((folder (get-memoized-folder url)))
@@ -181,21 +181,11 @@
             (set-file-folder-messages!
              folder
              (let ((messages (file-folder-messages folder)))
-               (if (pair? messages)
-                   (begin
-                     (let loop
-                         ((prev messages)
-                          (this (cdr messages))
-                          (index 1))
-                       (if (pair? this)
-                           (loop this (cdr this) (fix:+ index 1))
-                           (begin
-                             (attach-message! message folder index)
-                             (set-cdr! prev (list message)))))
-                     messages)
-                   (begin
-                     (attach-message! message folder 0)
-                     (list message))))))))
+               (let ((n (vector-length messages)))
+                 (let ((messages (vector-grow messages (fix:+ n 1))))
+                   (attach-message! message folder n)
+                   (vector-set! messages n message)
+                   messages)))))))
        (append-message-to-file message url))))
 
 (define-generic make-message-copy (message folder))
@@ -204,27 +194,31 @@
 (define-method expunge-deleted-messages ((folder <file-folder>))
   (without-interrupts
    (lambda ()
-     (let find-first ((messages (file-folder-messages folder)) (prev #f))
-       (if (pair? messages)
-          (if (message-deleted? (car messages))
-              (let loop
-                  ((messages messages)
-                   (prev prev)
-                   (index (message-index (car messages))))
-                (if (pair? messages)
-                    (let ((next (cdr messages)))
-                      (if (message-deleted? (car messages))
-                          (begin
-                            (detach-message! (car messages))
-                            (if prev
-                                (set-cdr! prev next)
-                                (set-file-folder-messages! folder next))
-                            (folder-modified! folder 'EXPUNGE index)
-                            (loop next prev index))
-                          (begin
-                            (set-message-index! (car messages) index)
-                            (loop (cdr messages) messages (+ index 1)))))))
-              (find-first (cdr messages) messages)))))))
+     (let ((messages (file-folder-messages folder)))
+       (let ((n (vector-length messages)))
+        (let ((n-deleted
+               (let loop ((i 0) (n-deleted 0))
+                 (if (fix:< i n)
+                     (loop (fix:+ i 1)
+                           (if (message-deleted? (vector-ref messages i))
+                               (fix:+ n-deleted 1)
+                               n-deleted))
+                     n-deleted))))
+          (if (fix:> n-deleted 0)
+              (let ((messages* (make-vector (- n n-deleted))))
+                (let loop ((i 0) (i* 0))
+                  (if (fix:< i n)
+                      (let ((m (vector-ref messages i)))
+                        (if (message-deleted? m)
+                            (begin
+                              (detach-message! m)
+                              (folder-modified! folder 'EXPUNGE i*)
+                              (loop (fix:+ i 1) i*))
+                            (begin
+                              (set-message-index! m i*)
+                              (vector-set! messages* i* m)
+                              (loop (fix:+ i 1) (fix:+ i* 1)))))))
+                (set-file-folder-messages! folder messages*)))))))))
 
 (define-method search-folder ((folder <file-folder>) criteria)
   (cond ((string? criteria)

diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 332224452b9a4c19341a271130d430617d93e6a4..243100838f205cb17090a951c90a58ba3664d0ac 100644 (file)
--- a/v7/src/imail/imail-rmail.scm
+++ b/v7/src/imail/imail-rmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-rmail.scm,v 1.59 2001/03/19 22:26:01 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.60 2001/03/19 22:51:50 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -53,7 +53,7 @@
   (if (file-exists? (file-url-pathname url))
       (error:bad-range-argument url 'CREATE-FOLDER))
   (let ((folder (make-rmail-folder url)))
-    (set-file-folder-messages! folder '())
+    (set-file-folder-messages! folder '#())
     (set-rmail-folder-header-fields!
      folder
      (compute-rmail-folder-header-fields folder))
@@ -133,7 +133,7 @@
                (begin
                  (attach-message! message folder index)
                  (loop line (+ index 1) (cons message messages)))
-               (reverse! messages))))))))
+               (list->vector (reverse! messages)))))))))
 
 (define (read-rmail-prolog port)
   (if (not (rmail-prolog-start-line? (read-required-line port)))
@@ -242,8 +242,9 @@
   (call-with-binary-output-file pathname
     (lambda (port)
       (write-rmail-file-header (rmail-folder-header-fields folder) port)
-      (for-each (lambda (message) (write-rmail-message message port))
-               (file-folder-messages folder)))))
+      (for-each-vector-element (file-folder-messages folder)
+       (lambda (message)
+         (write-rmail-message message port))))))
 
 (define-method append-message-to-file ((message <message>) (url <rmail-url>))
   (let ((pathname (file-url-pathname url)))

diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 06a9245c09d44058dad19a3ba6c94c9b78e9aef1..afde1756530c1e61d7ff46a28c3fc75ccf64a86a 100644 (file)
--- a/v7/src/imail/imail-umail.scm
+++ b/v7/src/imail/imail-umail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-umail.scm,v 1.41 2001/03/19 19:33:03 cph Exp $
+;;; $Id: imail-umail.scm,v 1.42 2001/03/19 22:51:53 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -53,7 +53,7 @@
   (if (file-exists? (file-url-pathname url))
       (error:bad-range-argument url 'CREATE-FOLDER))
   (let ((folder (make-umail-folder url)))
-    (set-file-folder-messages! folder '())
+    (set-file-folder-messages! folder '#())
     (set-file-folder-file-modification-time! folder (get-universal-time))
     (set-file-folder-file-modification-count!
      folder
@@ -103,7 +103,7 @@
     (lambda (port)
       (let ((from-line (read-line port)))
        (if (eof-object? from-line)
-           '()
+           '#()
            (begin
              (if (not (umail-delimiter? from-line))
                  (error "Malformed unix mail file:" port))
@@ -121,7 +121,7 @@
                    (let ((messages (cons message messages)))
                      (if from-line
                          (loop from-line (+ index 1) messages)
-                         (reverse! messages))))))))))))
+                         (list->vector (reverse! messages)))))))))))))
 
 (define (read-umail-message folder from-line port delimiter?)
   (let ((h-start (xstring-port/position port)))
@@ -166,8 +166,9 @@
 (define-method write-file-folder ((folder <umail-folder>) pathname)
   (call-with-binary-output-file pathname
     (lambda (port)
-      (for-each (lambda (message) (write-umail-message message #t port))
-               (file-folder-messages folder)))))
+      (for-each-vector-element (file-folder-messages folder)
+       (lambda (message)
+         (write-umail-message message #t port))))))
 
 (define-method append-message-to-file ((message <message>) (url <umail-url>))
   (let ((port (open-binary-output-file (file-url-pathname url) #t)))