Date: Saturday, December 11, 2010 @ 17:39:46 Author: rtoy Path: /project/cmucl/cvsroot/src/code
Modified: intl.lisp
Speed up building on sparc. Time taken is now almost half! This was caused by all the calls to stat in PROBE-FILE in LOCATE-DOMAIN-FILE for files that did not exist. The default locale was C, so every message lookup was causing many stat's to non-exist files. (There were over 1000 calls/sec on a 750 MHz sparc!)
So we cache all the calls to PROBE-FILE in LOCATE-DOMAIN-FILE. But just in case, we also allow the user to get at the hash table to examine it (GET-DOMAIN-FILE-CACHE) and also allow the user to clear it (CLEAR-DOMAIN-FILE-CACHE) in case new translations are added without restarting lisp.
-----------+ intl.lisp | 70 ++++++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 45 insertions(+), 25 deletions(-)
Index: src/code/intl.lisp diff -u src/code/intl.lisp:1.8 src/code/intl.lisp:1.9 --- src/code/intl.lisp:1.8 Tue Jul 13 23:13:20 2010 +++ src/code/intl.lisp Sat Dec 11 17:39:46 2010 @@ -1,6 +1,6 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*-
-;;; $Revision: 1.8 $ +;;; $Revision: 1.9 $ ;;; Copyright 1999-2010 Paul Foley (mycroft@actrix.gen.nz) ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining @@ -23,7 +23,7 @@ ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.8 2010-07-14 03:13:20 rtoy Rel $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.9 2010-12-11 22:39:46 rtoy Exp $")
(in-package "INTL")
@@ -79,29 +79,49 @@ (ash (the (unsigned-byte 8) (read-byte stream)) 8) (the (unsigned-byte 8) (read-byte stream))))
-(defun locate-domain-file (domain locale locale-dir) - ;; The default locale-dir includes search lists. If we get called - ;; before the search lists are initialized, we lose. The search - ;; lists are initialized in environment-init, which sets - ;; *environment-list-initialized*. This way, we return NIL to - ;; indicate there's no domain file to use. - (when lisp::*environment-list-initialized* - (flet ((path (locale base) - (merge-pathnames (make-pathname :directory (list :relative locale - "LC_MESSAGES") - :name domain :type "mo") - base))) - (let ((locale (or (gethash locale *locale-aliases*) locale))) - (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) - (let ((probe - (or (probe-file (path locale base)) - (let ((dot (position #. locale))) - (and dot (probe-file (path (subseq locale 0 dot) base)))) - (let ((at (position #@ locale))) - (and at (probe-file (path (subseq locale 0 at) base)))) - (let ((us (position #_ locale))) - (and us (probe-file (path (subseq locale 0 us) base))))))) - (when probe (return probe)))))))) +;; If the domain file doesn't exist because the locale isn't +;; supported, we end up doing a huge number of stats looking for a +;; non-existent file everytime a translation is needed. This is +;; really expensive. So create a cache to hold the results. +(let ((domain-file-cache (make-hash-table :test 'equal))) + (defun get-domain-file-cache () + ;; Mostly for debugging to let the user get at the cache. + domain-file-cache) + (defun clear-domain-file-cache () + ;; Mostly for debugging. But also useful if we now have installed + ;; some new translations. + (clrhash domain-file-cache)) + (defun locate-domain-file (domain locale locale-dir) + ;; The default locale-dir includes search lists. If we get called + ;; before the search lists are initialized, we lose. The search + ;; lists are initialized in environment-init, which sets + ;; *environment-list-initialized*. This way, we return NIL to + ;; indicate there's no domain file to use. + (when lisp::*environment-list-initialized* + (flet ((path (locale base) + (merge-pathnames (make-pathname :directory (list :relative locale + "LC_MESSAGES") + :name domain :type "mo") + base)) + (memoized-probe-file (p) + ;; Cache the results of probe-file and return the + ;; cached value when possible. + (multiple-value-bind (value foundp) + (gethash p domain-file-cache) + (if foundp + value + (setf (gethash p domain-file-cache) (probe-file p)))))) + (let ((locale (or (gethash locale *locale-aliases*) locale))) + (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) + (let ((probe + (or (memoized-probe-file (path locale base)) + (let ((dot (position #. locale))) + (and dot (memoized-probe-file (path (subseq locale 0 dot) base)))) + (let ((at (position #@ locale))) + (and at (memoized-probe-file (path (subseq locale 0 at) base)))) + (let ((us (position #_ locale))) + (and us (memoized-probe-file (path (subseq locale 0 us) base))))))) + (when probe (return probe)))))))))
(defun find-encoding (domain) (when (null (domain-entry-encoding domain))