;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10 -*- ;;;; --------------------------------------------------------------------------- ;;;; File name: genls-cache-dumper.lsp ;;;; System: FIRE ;;;; Version: V1 ;;;; Author: jeverett & kdf ;;;; Created: Tuesday Jan 30, 2001 at 11:31 by jeverett ;;;; Modified: Tuesday, November 18, 2003 at 16:58:35 by ureel ;;;; Purpose: Dump/load genls cache from disk files for speed ;;;; --------------------------------------------------------------------------- (in-package :fire) ;;; OVERVIEW ;;; ---------------------------------------------------------------------------- ;;; We cache genls from the KB in order to make structural queries ;;; quick. However, even building the cache can be expensive: 30 ;;; to 60 seconds, almost all of which is in the dbex code. ;;; John figured out that dumping the cache to disk could be a win, ;;; but his version assumed everything was static. Fine for research, ;;; not so good for shipping apps where the set of genls can change. ;;; This version handles change, not gracefully, but at least detects ;;; whether or not it has happened, and ensures that the files are not ;;; used if they are out of synch. ;;; API ;;; ---------------------------------------------------------------------------- ;;; These procedures are intended for use by developers of FIRE applications. ;;; ;;; (dump-genls-cache (&key (kb *kb*) (file-size 1000))) ;;; Create and compiles a set of files that allow the current state of the genls ;;; cache to be reconstructed by loading files when the KB is initialized in ;;; the future. This can be substantially faster: For instance, on Bender ;;; (500 mhz P3, 512MB RAM) it takes over 30 seconds to initialize the QRG-DARPA ;;; KB straight from dbex, and about 4 seconds from files. In terms of how ;;; a FIRE-based application feels on startup, this difference is major. ;;; ;;; dump-genls-cache uses the Resources directory of the KB to store the ;;; files. It creates .lsp source files as temporaries, which are destroyed ;;; immediately after compilation to save space. When it saves a set of cache ;;; files, it adds a mark to the KB in the form of a special assertion that ;;; is used on subsequent loads to tell itself that the files are safe to use. ;;; If you STORE or FORGET any genls, this mark will be removed since the cache ;;; is no longer valid, and subsequent startups will rebuild it from dbex, ;;; until a new set of files is generated. ;;; ;;; Hints: ;;; 1. When you move KB's around, be sure to grab the Resources subdirectory. ;;; Not only is this a good idea for the genls cache files, but we're also ;;; storing chainers and other data associated with a KB that we don't want ;;; to cram into BDL. ;;; 2. If you want to optimize the cache, precompute allgenls for collections ;;; that are likely to be heavily used by your application before dumping ;;; genls cache files. This will save your users time because that first ;;; call can be expensive, esp. if fairly low down in the lattice. ;;; (However, don't go overboard -- please see the note in genls-cache.lsp ;;; for just how space-hogging it can be to precompute everything!) ;;; (mark-genls-cache-files-stale ) ;;; If you want to turn off reloading from files (maybe they are ;;; are missing or corrupted), this procedure clears the marker ;;; from the KB that tells FIRE that loading is safe. This will force ;;; it to reconstruct the cache from DBEX every time. ;;; HOW IT WORKS ;;; ---------------------------------------------------------------------------- ;;; Here's the idealized version: ;;;When a KB is opened, its resource ;;;directory is checked to see if it has genls cache files. If it ;;;does, those are loaded to set up the cache. In order to track ;;;changes in the genls structure, it is updated by looking for two ;;;kinds of assertions: (newGenls ) and (deadGenls ), ;;;corresponding to genls statements that have been added and removed ;;;respectively. ;;; ;;;The newGenls and deadGenls assertions get created when STORE ;;;and RETRIEVE are used on genls statements. If there are a lot ;;;of them, it will start getting slow to use. At which point one ;;;should update the file cache. ;;; ;;;The file cache is updated by dumping forms that, when loaded, ;;;reconstruct the genls cache. Two annoyances: (1) The genls ;;;cache entries refer to each other, so we end up having to make ;;;a second pass through the system. (2) The compiler isn't happy ;;;with really large (10MB+) files, running overnight without any ;;;results. John's solution was to break it down into a set of files. ;;;Which of course means that the loader has to know about this. ;;; ;;;While the idealized version would be nice, incremental updating of the ;;;genls cache is going to take a fair amount of time to implement. ;;;Given that most applications (e.g., the COA-related systems) are going ;;;to have a fixed genls structure, we'll get a lot of value from just ;;;declaring it dirty and reconstructing. So we'll start very simple. ;;; ---------------------------------------------------------------------------- ;; **** Really need an unwind protect around here (defun dump-genls-cache-old (&key (kb *kb*) (file-size 1000)) (mark-genls-cache-files-stale kb) (nuke-genls-cache-files kb) (cache-direct-genls-if-needed kb) ;; In case not already done (let* ((counter 0) (genls-path (genls-file-path kb)) (fout (make-genls-cache-file nil genls-path counter file-size)) (*print-pretty* nil)) (unwind-protect (progn ;; Dump the cache contents (maphash #'(lambda (key value) (declare (ignore key)) (incf counter) (setq fout (make-genls-cache-file fout genls-path counter file-size)) (format fout "~%~S" (genls-cache-entry->form value))) (table (genls-cache kb))) ;; Dump the direct genls (maphash #'(lambda (key value) (incf counter) (setq fout (make-genls-cache-file fout genls-path counter file-size)) (format fout "~%(setf (gethash '~A fire::*current-direct-genls*) '~A)" key value)) (direct-genls (genls-cache kb))) ;;Dump the direct subs (maphash #'(lambda (key value) (incf counter) (setq fout (make-genls-cache-file fout genls-path counter file-size)) (format fout "~%(setf (gethash '~A fire::*current-direct-subs*) '~A)" key value)) (direct-subs (genls-cache kb)))) (close fout) (compile-genls-cache-files kb) (mark-genls-cache-files-okay kb)))) (defun dump-genls-cache (&key (kb *kb*) (file-size 1000)) "Save the genls-cache to disk." (declare (ignore file-size)) (let ((*kb* kb)) (format t "~&Marking old genls-cache files as stale.~%") (mark-genls-cache-files-stale kb) (format t "~&Deleting old genls-cache files.~%") (nuke-genls-cache-files kb) (format t "~&Generating genls-cache if needed.~%") (cache-direct-genls-if-needed kb) ;; In case not already done (format t "~&Saving genls-cache.~%") (unwind-protect (bd-save (genls-cache *kb*) (kb-resource-path *kb*) "genls-cache") (mark-genls-cache-files-okay kb)) (format t "~&Dump-genls-cache complete.~%"))) (defmethod bd-write ((thing genls-cache) sout &rest args &key (context nil) &allow-other-keys) "BDumper method to store the genls-cache." (bd-write-token bdt-genls-cache sout) (bd-write (table thing) sout :context context) (bd-write (roots thing) sout :context context) (bd-write (direct-genls thing) sout :context context) (bd-write (direct-subs thing) sout :context context) (bd-write (cache-initialized? thing) sout :context context)) (defmethod bd-read (sin (token (eql bdt-genls-cache)) &rest args &key (context nil) &allow-other-keys) "BDumper method to read the genls-cache." (let ((result (make-instance 'genls-cache))) (setf (table result) (bd-read-object sin context)) (setf (roots result) (bd-read-object sin context)) (setf (direct-genls result) (bd-read-object sin context)) (setf (direct-subs result) (bd-read-object sin context)) (setf (cache-initialized? result) (bd-read-object sin context)) result)) (defmethod bd-write ((thing genls-cache-entry) sout &rest args &key (context nil) &allow-other-keys) "BDumper method to store a genls-cache entry." (bd-write-token bdt-genls-cache-entry sout) (bd-write (predicate thing) sout :context context) (bd-write (if (listp (the-allgenls thing)) (mapcar 'predicate (the-allgenls thing)) (the-allgenls thing)) sout :context context) (bd-write (if (listp (the-allsubsets thing)) (mapcar 'predicate (the-allsubsets thing)) (the-allsubsets thing)) sout :context context) (bd-write (depth thing) sout :context context) ;;; (bd-write (cache thing) sout :context context) ) (defmethod bd-read (sin (token (eql bdt-genls-cache-entry)) &rest args &key (context nil) &allow-other-keys) "BDumper method to read a genls-cache entry." (let ((result (make-instance 'genls-cache-entry))) (setf (predicate result) (bd-read-object sin context)) (setf (the-allgenls result) (bd-read-object sin context)) (setf (the-allsubsets result) (bd-read-object sin context)) (setf (depth result) (bd-read-object sin context)) ;;; (setf (cache result) (bd-read-object sin context)) result)) (defun genls-file-path (kb) (concatenate 'string (kb-resource-path kb) "genls-cache")) (defun make-genls-cache-file (strm genls-path counter file-size) (cond ((zerop (mod counter file-size)) (when (streamp strm) (close strm)) (let* ((name (format nil "~A-~A~A" genls-path (/ counter file-size) *src-ext*)) (newstrm (open name :direction :output :if-exists :supersede :if-does-not-exist :create))) (write-cache-file-header-info newstrm) newstrm)) (t strm))) (defun write-cache-file-header-info (f-out) (format f-out "~%;;; Genls cache") (format f-out "~%(eval-when (:compile-toplevel) ~%~ (declaim (optimize (speed 3) (safety 1) (space 0) (debug 0))))~%") (format f-out "~%(in-package :data)~%") (format f-out "~%(eval-when (:compile-toplevel) ~%~ (proclaim '(special fire::*current-direct-genls* ~%~ fire::*current-direct-subs* ~%~ fire::*current-genls-cache-table* ~%~ fire::*current-genls-cache*)))")) (defun genls-cache-entry->form (gce) `(setf (gethash ',(predicate gce) fire::*current-genls-cache-table*) (make-instance 'genls-cache-entry :predicate ',(predicate gce) :allgenls ',(if (listp (the-allgenls gce)) (mapcar 'predicate (the-allgenls gce)) (the-allgenls gce)) :allsubsets ',(if (listp (the-allsubsets gce)) (mapcar 'predicate (the-allsubsets gce)) (the-allsubsets gce)) :cache fire::*current-genls-cache* :depth ,(depth gce)))) (defun compile-genls-cache-files (kb) ;;(mapc #'delete-file (directory (concat *genls-cache-path* "*.fasl"))) (let ((path (genls-file-path kb))) (dolist (fspec (directory (concatenate 'string path "*" *src-ext*))) (compile-file fspec :load-after-compile nil) (delete-genls-cache-file fspec)))) (defun nuke-genls-cache-files (kb) ;; Get rid of leftovers (let ((path (genls-file-path kb))) (dolist (fspec (directory (concatenate 'string path "*.*"))) (delete-genls-cache-file fspec)))) (defvar *dont-delete-genls-cache-file* nil) (defun delete-genls-cache-file (fspec) (unless *dont-delete-genls-cache-file* (delete-file fspec))) (eval-when (:load-toplevel :compile-toplevel) (proclaim '(special *current-direct-genls* *current-direct-subs* *current-genls-cache-table* *current-genls-cache*))) ;; Assertion for flagging whether or not the genls cache files ;; are okay or stale. Reason for making okay the positive state is ;; that if the process of reconstructing the files fails, the okay ;; marker will not be in the KB. Better to be safe and sometimes ;; slower than fast and incorrect. (defparameter *genls-cache-flag* '(data::genlsCacheStatus data::okay)) (defun genls-cache-files-stale? (kb) (not (retrieve *genls-cache-flag* :kb kb))) (defun mark-genls-cache-files-stale (kb) (forget *genls-cache-flag* :kb kb)) (defun mark-genls-cache-files-okay (kb) (store *genls-cache-flag* kb)) (defun reconstruct-genls-cache (kb) (load-genls-cache-files :kb kb) ;; Need to snap all of the pointers in the genls cache table ;; with the appropriate entries (let ((result (catch 'invalid-entry (let ((table (table (genls-cache kb)))) (maphash #'(lambda (key entry) (declare (ignore key)) (setf (cache entry) (genls-cache kb)) (when (listp (the-allgenls entry)) (setf (the-allgenls entry) (mapcar #'(lambda (pred) (careful-retrieve-entry pred table)) (the-allgenls entry)))) (when (listp (the-allsubsets entry)) (setf (the-allsubsets entry) (mapcar #'(lambda (pred) (careful-retrieve-entry pred table)) (the-allsubsets entry))))) table) :okay)))) (cond ((eq result :okay) nil) (t (mark-genls-cache-files-stale kb) (reset-genls-cache kb) (compute-genls-cache kb))))) (defun careful-retrieve-entry (pred table) (let ((entry (gethash pred table))) (cond ((genls-cache-entry? entry) entry) (t (throw 'invalid-entry :invalid-entry))))) (defun load-genls-cache-files-old (&key (kb *kb*)) (let* ((path (genls-file-path kb)) (genls-cache (get-or-create-genls-cache kb)) (*current-genls-cache* genls-cache) (*current-genls-cache-table* (table genls-cache)) (*current-direct-genls* (direct-genls genls-cache)) (*current-direct-subs* (direct-subs genls-cache))) (dolist (fspec (directory (concatenate 'string path "*" *bin-ext*))) (load fspec)))) (defun load-genls-cache-files (&key (kb *kb*)) (format t "~&Loading genls-cache....~%") (handler-bind ((file-error #'(lambda (condition) (declare (ignore condition)) (format t "~&WARNING: file-error - genls-cache not loaded.") (return-from load-genls-cache-files nil)))) (let ((cache (bd-load (kb-resource-path *kb*) "genls-cache"))) (format t "~&Done loading genls-cache.~%") (when cache (setf (genls-cache kb) cache) (setf (kb (genls-cache kb)) kb) (genls-cache kb))))) ;;;; --------------------------------------------------------------------------- ;;;; End of Code