From bd54cbf7d9240695362f61ca12c803e5c286ab58 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 19 Mar 2001 22:51:53 +0000 Subject: [PATCH] Change file folders to store their messages in a vector rather than a list. The linear-time lookup was killing performance on large folders. --- v7/src/imail/imail-file.scm | 74 +++++++++++++++++------------------- v7/src/imail/imail-rmail.scm | 11 +++--- v7/src/imail/imail-umail.scm | 13 ++++--- 3 files changed, 47 insertions(+), 51 deletions(-) diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index be3400866..677b184d2 100644 --- 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 )) - (length (file-folder-messages folder))) + (vector-length (file-folder-messages folder))) (define-method %get-message ((folder ) index) - (list-ref (file-folder-messages folder) index)) + (vector-ref (file-folder-messages folder) index)) (define-method %append-message ((message ) (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 )) (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 ) criteria) (cond ((string? criteria) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index 332224452..243100838 100644 --- 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 ) (url )) (let ((pathname (file-url-pathname url))) diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index 06a9245c0..afde17565 100644 --- 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 ) 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 ) (url )) (let ((port (open-binary-output-file (file-url-pathname url) #t))) -- 2.25.1