├── src ├── widths.lisp ├── utils.lisp ├── array.lisp ├── package.lisp ├── finalize.lisp ├── fixed-string.lisp ├── iterator.lisp ├── struct.lisp ├── gc.lisp ├── mop.lisp ├── rewrite-gc.lisp ├── types.lisp ├── box.lisp ├── mtagmap.lisp ├── transaction.lisp └── class.lisp ├── manardb-test.asd ├── t ├── mptr.lisp ├── suite.lisp ├── class.lisp ├── symbol.lisp ├── box.lisp ├── gc.lisp └── tree.lisp ├── README.md ├── manardb.asd └── doc ├── index.html └── api.html /src/widths.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defconstant +mptr-bits+ 64) 4 | (defconstant +mtag-bits+ 8) 5 | (defconstant +mtags+ (ash 1 +mtag-bits+)) 6 | (defconstant +mindex-bits+ (- +mptr-bits+ +mtag-bits+)) 7 | 8 | (defconstant +word-length+ 8) 9 | (deftype word () 10 | `(unsigned-byte 64)) 11 | -------------------------------------------------------------------------------- /manardb-test.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem manardb-test 2 | :components 3 | ((:module :t 4 | :components ((:file "suite") 5 | (:file "gc" :depends-on ("tree")) 6 | (:file "class" :depends-on ("suite")) 7 | (:file "symbol" :depends-on ("suite")) 8 | (:file "box" :depends-on ("suite")) 9 | (:file "tree" :depends-on ("suite"))) 10 | )) 11 | :depends-on (manardb stefil)) -------------------------------------------------------------------------------- /t/mptr.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb.test) 2 | 3 | (stefil:in-suite manardb-test) 4 | 5 | (stefil:deftest make-mptr-all () 6 | (loop for mtag below +mtags+ 7 | do (loop 8 | repeat 1000 9 | for mindex = (random (ash 1 +mindex-bits+)) 10 | for mptr = (make-mptr mtag mindex) 11 | do 12 | (stefil:is (= (mptr-index mptr) mindex)) 13 | (stefil:is (= (mptr-tag mptr) mtag))))) 14 | 15 | -------------------------------------------------------------------------------- /t/suite.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:manardb.test 2 | (:export #:test-all-manardb) 3 | (:use #:cl #:manardb #:stefil #:iter)) 4 | 5 | (in-package #:manardb.test) 6 | 7 | (defsuite manardb-test) 8 | 9 | (defun test-all-manardb (&key (cleanup t) (function 'manardb-test)) 10 | (let ((dir (format nil "/tmp/manardb-test-~36R/" (random most-positive-fixnum (make-random-state t)))) 11 | (*mmap-may-allocate* t)) 12 | (use-mmap-dir dir) 13 | (unwind-protect 14 | (funcall function) 15 | (when cleanup 16 | (ignore-errors (osicat:delete-directory-and-files dir :if-does-not-exist nil)))))) 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | manardb is a portable (across Lisps on Linux) memory mapped database for Common Lisp. 2 | === 3 | It frees one from the garbage collector but stays within MOP. 4 | 5 | See its [homepage at MSI](http://cl-www.msi.co.jp/projects/manardb/index.html) 6 | 7 | Testing 8 | === 9 | 10 | > (asdf:operate 'asdf:load-op 'manardb-test) 11 | > (manardb.test:test-all-manardb) 12 | # 13 | 14 | Credits 15 | === 16 | 17 | By MSI 18 | 19 | Thanks to Pascal Costanza for MOP conformance and other advice. 20 | 21 | This project has found bugs in all Lisp implementations tested (Allegro, 22 | Lispworks, SBCL, and ClozureCL). Prize goes to SBCL for correctness as 23 | the bug (slot-value didn't work) was already fixed in a newer version. 24 | -------------------------------------------------------------------------------- /src/utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defmacro defun-speedy (name lambda-list &body body &environment env) 4 | (declare (ignorable env)) 5 | `(progn 6 | (declaim (inline ,name)) 7 | #+lispworks ,@(when env `((declaim (notinline ,name)))) 8 | ;; Lispworks 5.1 cannot inline things with macrolet lexical scope! 9 | (defun ,name ,lambda-list 10 | (declare (optimize speed)) 11 | ,@body))) 12 | 13 | (defun force-class (class-specifer) 14 | (typecase class-specifer 15 | (class class-specifer) 16 | (t 17 | (find-class class-specifer)))) 18 | 19 | (defmacro cassert (test-form &optional places string &rest args) 20 | (declare (ignore places));; XXX 21 | `(unless ,test-form 22 | (cerror "Ignore the assertion" ,(or string (format nil "Assertion ~S failed" test-form)) ,@args))) 23 | -------------------------------------------------------------------------------- /manardb.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | (asdf:defsystem manardb 4 | :version "0.1.20090911" 5 | :licence "LLGPL" 6 | :components 7 | ((:module :src 8 | :components ( 9 | (:file "package") 10 | (:file "widths" :depends-on ("package")) 11 | (:file "utils" :depends-on ("package")) 12 | (:file "mtagmap" :depends-on ("widths" "struct" "mop")) 13 | (:file "mop" :depends-on ("struct")) 14 | (:file "struct" :depends-on ("utils" "widths")) 15 | (:file "class" :depends-on ("mop" "mtagmap")) 16 | (:file "types" :depends-on ("class")) 17 | (:file "array" :depends-on ("types")) 18 | (:file "gc" :depends-on ("finalize")) 19 | (:file "rewrite-gc" :depends-on ("gc")) 20 | (:file "box" :depends-on ("types")) 21 | (:file "finalize" :depends-on ("box")) 22 | (:file "iterator" :depends-on ("class")) 23 | (:file "fixed-string" :depends-on ("box")) 24 | (:file "transaction" :depends-on ("finalize")) 25 | ))) 26 | :depends-on (alexandria osicat iterate closer-mop cl-irregsexp)) 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /src/array.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | ;; XXX doesn't work on specialised arrays 4 | (defun-speedy marray-ref (marray i) 5 | "Like aref, but for memory mapped arrays" 6 | (declare (type mindex i)) 7 | (mptr-to-lisp-object (dw (mptr-pointer (marray-base marray)) i))) 8 | 9 | (defun-speedy (setf marray-ref) (new marray i) 10 | (declare (type mindex i)) 11 | (let ((new (lisp-object-to-mptr new))) 12 | (setf (dw (mptr-pointer (marray-base marray)) i) 13 | new)) 14 | new) 15 | 16 | 17 | (defclause-sequence in-marray index-of-marray 18 | :access-fn 'marray-ref 19 | :size-fn 'marray-length 20 | :sequence-type 'marray 21 | :element-type t 22 | :element-doc-string "Elements of an marray" 23 | :index-doc-string "Indices of marray") 24 | 25 | 26 | (defun marray-to-list (marray) 27 | "Converts a memory mapped array to a Lisp list; nil is converted to nil" 28 | (when marray 29 | (iter (for c in-marray marray) 30 | (collect c)))) 31 | (defun list-to-marray (list) 32 | "Converts a Lisp list to a memory-mapped array object; nil is converted to nil" 33 | (when list 34 | (make-marray (length list) :initial-contents list))) 35 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:manardb 2 | (:export 3 | #:mptr 4 | #:mm-metaclass 5 | #:mm-object 6 | #:defmmclass 7 | #:*mmap-base-pathname* 8 | #:*mmap-may-allocate* 9 | #:close-all-mmaps 10 | #:open-all-mmaps 11 | #:wipe-all-mmaps 12 | #:print-all-mmaps 13 | #:doclass 14 | #:dosubclasses 15 | #:retrieve-all-instances 16 | #:count-all-instances 17 | 18 | #:mptr-to-lisp-object 19 | #:lisp-object-to-mptr 20 | #:lisp-object-to-mptr-impl 21 | 22 | #:marray 23 | #:make-marray 24 | #:marray-ref 25 | #:marray-length 26 | #:index-of-marray 27 | #:in-marray 28 | 29 | #:gc 30 | #:rewrite-gc 31 | 32 | #:make-mm-fixed-string 33 | #:mm-fixed-string-value 34 | 35 | #:with-transaction 36 | #:use-mmap-dir 37 | #:clean-mmap-dir 38 | 39 | #:with-object-cache 40 | #:with-cached-slots 41 | 42 | #:marray-to-list 43 | #:list-to-marray 44 | 45 | #:meq 46 | #:direct-slot-numeric-maref ;; XXXX to delete when we have time for something better 47 | ) 48 | ;; #+sbcl (:import-from #:sb-pcl #:reader-function #:writer-function) 49 | (:use #:iterate #:closer-common-lisp)) 50 | -------------------------------------------------------------------------------- /t/class.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb.test) 2 | 3 | (stefil:in-suite manardb-test) 4 | 5 | (stefil:deftest test-simple-defclass () 6 | (eval `(defclass test-empty-class () 7 | () 8 | (:metaclass mm-metaclass))) 9 | 10 | (eval `(defclass test-byte-class () 11 | ((slot :type (unsigned-byte 8))) 12 | (:metaclass mm-metaclass))) 13 | 14 | (eval `(defclass test-boxed-class () 15 | ((slot :initform 1)) 16 | (:metaclass mm-metaclass))) 17 | ) 18 | 19 | (stefil:deftest test-create-two-slot-class () 20 | (eval 21 | `(manardb:defmmclass two-slot () 22 | ((basic-slot :initarg :basic-slot :initform (error "Please provide a value for the basic slot")) 23 | (marray :initarg :marray :initform 24 | (manardb:make-marray 25 | 1000 26 | :initial-element 27 | nil)))))) 28 | 29 | (stefil:deftest test-nil-slots-are-not-created () 30 | (test-create-two-slot-class) 31 | (let ((m (make-instance 'two-slot :basic-slot nil))) 32 | (stefil:is (not (slot-value m 'basic-slot))) 33 | m)) 34 | 35 | (stefil:deftest test-create-instance-of-two-slot (&optional (vals (list nil 0 :keyword "string"))) 36 | (test-create-two-slot-class) 37 | (loop for val in vals do 38 | (let ((m (make-instance 'two-slot :basic-slot val :marray val))) 39 | (stefil:is (equalp val (slot-value m 'marray))) 40 | (stefil:is (equalp val (slot-value m 'basic-slot)))))) 41 | -------------------------------------------------------------------------------- /t/symbol.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb.test) 2 | 3 | (stefil:in-suite manardb-test) 4 | 5 | (stefil:deftest symbol-tag-is-zero-test () 6 | (stefil:is (= (manardb::mm-metaclass-tag (find-class 'manardb::mm-symbol)) 0))) 7 | 8 | (stefil:deftest store-keyword-test () 9 | (loop for keyword in '(:keyword :key :errorp) 10 | for mptr = (lisp-object-to-mptr keyword) 11 | do (stefil:is (eq keyword (mptr-to-lisp-object mptr))) 12 | (stefil:is (= mptr (lisp-object-to-mptr keyword))))) 13 | 14 | (stefil:deftest store-all-symbols-test (&optional 15 | (packages (list (find-package '#:cl) 16 | (find-package '#:manardb)))) 17 | (macrolet ((do-all-syms ((var) &body body) 18 | (alexandria:with-gensyms (package) 19 | `(loop for ,package in packages do 20 | (do-all-symbols (,var ,package) 21 | ,@body))))) 22 | (stefil:without-test-progress-printing ;;; too much progress 23 | (let ((table (make-hash-table))) 24 | (flet ((add (sym mptr) 25 | (let ((orig (gethash sym table))) 26 | (when orig 27 | (stefil:is (= orig mptr))) 28 | (setf (gethash sym table) mptr)))) 29 | (do-all-syms (sym) 30 | (add sym (lisp-object-to-mptr sym))) 31 | (iter (for (sym mptr) in table) 32 | (stefil:is (= mptr (lisp-object-to-mptr sym)))) 33 | (do-all-syms (sym) 34 | (stefil:is (eq sym (mptr-to-lisp-object (lisp-object-to-mptr sym))))) 35 | (iter (for (sym mptr) in table) 36 | (stefil:is (eq sym (mptr-to-lisp-object mptr)))) 37 | (do-all-syms (sym) 38 | (add sym (lisp-object-to-mptr sym)))))))) 39 | 40 | -------------------------------------------------------------------------------- /t/box.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb.test) 2 | 3 | (stefil:in-suite manardb-test) 4 | 5 | (defun box-unbox (object) 6 | (mptr-to-lisp-object (lisp-object-to-mptr object))) 7 | 8 | (stefil:deftest box-numbers-test () 9 | (loop for num in '(0 1 -1 255 -127 -128 1000 1000000000 -10000000) 10 | do (stefil:is (= (box-unbox num) num)))) 11 | 12 | 13 | (stefil:deftest unbox-nil-test () 14 | (stefil:is (eq nil (mptr-to-lisp-object 0))) 15 | (stefil:is (= 0 (lisp-object-to-mptr nil)))) 16 | 17 | (stefil:deftest box-cons-test () 18 | (loop repeat 10 19 | for cons = nil then (cons cons nil) 20 | do (stefil:is (equal cons (box-unbox cons)))) 21 | 22 | (loop for list in '((1 2 box fail (x y)) (1 . 2) (((nil . 2))) (((1 2 3 (3)) 1) 1 2 2 . ( 1 2 . 3)) ) 23 | do (stefil:is (equal list (box-unbox list))))) 24 | 25 | (stefil:deftest box-unspecialized-array-test () 26 | (loop for array in (list 27 | (make-array 0) 28 | (make-array 10 :element-type t :initial-element nil)) 29 | do 30 | (stefil:is (equalp array (box-unbox array))))) 31 | 32 | (stefil:deftest box-numeric-array-test () 33 | (loop for (limit type) in `((256 (unsigned-byte 8)) 34 | (,(ash 1 9) (unsigned-byte 64)) 35 | (,(ash 1 31) (unsigned-byte 64)) 36 | (,(ash 1 30) (signed-byte 64)) 37 | (,most-positive-double-float double-float) 38 | (,most-positive-single-float single-float)) 39 | do (loop for len in '(2 1 10 100 1000 10000) do 40 | (let ((array (make-array len :element-type type))) 41 | (loop for i below len do 42 | (setf (aref array i) (random limit))) 43 | (stefil:is (equalp array (box-unbox array))))))) 44 | 45 | (stefil:deftest box-string-test () 46 | (loop for string in '("" "a" "one two three" #.(string (code-char 1000))) do 47 | (stefil:is (string= string (box-unbox string))))) 48 | -------------------------------------------------------------------------------- /src/finalize.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defun finalize-all-mmaps () 4 | (loop for m across *mtagmaps* 5 | when m 6 | do (mtagmap-finalize m))) 7 | 8 | (defun clear-caches-hard () 9 | (loop for package in (list-all-packages) do 10 | (do-all-symbols (sym package) 11 | (remf (symbol-plist sym) 'mm-symbol)))) 12 | 13 | (defun clear-caches () 14 | (loop for sym in *stored-symbols* 15 | for removed = (remprop sym 'mm-symbol) 16 | do (assert removed)) 17 | 18 | #- (and) (loop for package in (list-all-packages) do 19 | (do-all-symbols (sym package) 20 | (assert (not (get sym 'mm-symbol))))) 21 | 22 | (setf *stored-symbols* nil)) 23 | 24 | (defun close-all-mmaps () 25 | "Closes the datastore, unmapping and closing all files. Afterwards, a new datastore can be opened in a different locaiton." 26 | (clear-caches) 27 | 28 | (loop for m across *mtagmaps* do 29 | (when m (mtagmap-close m)))) 30 | 31 | (defun open-all-mmaps () 32 | "Maps the datastore into memory." 33 | (finalize-all-mmaps) 34 | (assert (or (not (mtagmap-closed-p (mtagmap 0))) (not *stored-symbols*))) 35 | 36 | (loop for m across *mtagmaps* do 37 | (when m 38 | (when (mtagmap-closed-p m) 39 | (mtagmap-open m)) 40 | (mtagmap-check m)))) 41 | 42 | (defun shrink-all-mmaps () 43 | "Truncate all mmaps to smallest size (rounded up to the nearest page) which can contain all their data." 44 | (loop for m across *mtagmaps* do 45 | (when (and m (not (mtagmap-closed-p m))) 46 | (mtagmap-shrink m)))) 47 | 48 | 49 | (defun wipe-all-mmaps () 50 | "Delete all objects from all classes." 51 | (clear-caches) 52 | (loop for m across *mtagmaps* 53 | when (and m (not (mtagmap-closed-p m))) 54 | do 55 | (setf (mtagmap-next m) (mtagmap-first-index m)) 56 | (mtagmap-shrink m))) 57 | 58 | (defun print-all-mmaps (&optional (stream *standard-output*)) 59 | "Describe the state of the datastore" 60 | (loop for m across *mtagmaps* 61 | when (and m (not (mtagmap-closed-p m))) 62 | do (format stream "~&~A~%" m))) 63 | 64 | (define-lisp-object-to-mptr) 65 | 66 | 67 | -------------------------------------------------------------------------------- /src/fixed-string.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defun mm-fixed-string-uncropper (string original-length) 4 | (declare (ignore original-length)) 5 | (concatenate 'string string "...")) 6 | 7 | (defvar *mm-fixed-string-uncropper* 'mm-fixed-string-uncropper) 8 | 9 | (defun mm-fixed-string-value (mfs) 10 | "The string stored in the fixed length string MFS. If the string was cropped, then append ... to the stored value. 11 | 12 | Can be set with setf. If the new value is too long then it will be silently cropped. 13 | " 14 | (with-pointer-slots (cropped-length length) 15 | ((mm-object-pointer mfs) mm-fixed-string) 16 | (let ((base-string (cl-irregsexp.bytestrings:force-string 17 | (subseq 18 | (cl-irregsexp.bytestrings:force-byte-vector 19 | (tag-general-unbox-array (mptr-tag (ptr mfs)) (mptr-index (ptr mfs)))) 20 | 0 21 | (min cropped-length length))))) 22 | (if (> cropped-length length) 23 | (funcall *mm-fixed-string-uncropper* base-string cropped-length) 24 | base-string)))) 25 | 26 | (with-constant-tag-for-class (element-tag boxed-byte) 27 | (defun-speedy make-mm-fixed-string (length &key value) 28 | "Create a fixed length string object of size LENGTH; stores into it the string in VALUE if given. 29 | 30 | A fixed length string allows string objects to be modified in the 31 | datastore without allocating more space. 32 | " 33 | (let ((mfs (make-instance 'mm-fixed-string 34 | :length length 35 | :base (make-mptr element-tag 36 | (mtagmap-alloc (mtagmap element-tag) 37 | (* length #.(stored-type-size '(unsigned-byte 8)))))))) 38 | (when value 39 | (mm-fixed-string-store mfs value)) 40 | mfs))) 41 | 42 | (defun mm-fixed-string-store (mfs string) 43 | (with-pointer-slots (cropped-length length base) 44 | ((mm-object-pointer mfs) mm-fixed-string) 45 | (let ((bv (cl-irregsexp.bytestrings:force-byte-vector string)) (ptr (mptr-pointer base))) 46 | (setf cropped-length (length bv)) 47 | (loop for x across bv 48 | for i below length 49 | do (setf (d ptr i (unsigned-byte 8)) x)))) 50 | mfs) 51 | 52 | (defun (setf mm-fixed-string-value) (string mfs) 53 | (mm-fixed-string-store mfs string) 54 | string) 55 | 56 | -------------------------------------------------------------------------------- /t/gc.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb.test) 2 | 3 | (stefil:in-suite manardb-test) 4 | 5 | (stefil:deftest test-gc-nil (&key (gc 'gc)) 6 | (with-transaction (:message "GC") 7 | (loop repeat 10 do 8 | (simple-tree-create-test) 9 | (stefil:is (plusp (count-all-instances 'tree))) 10 | (funcall gc nil) 11 | (stefil:is (zerop (count-all-instances 'tree)))))) 12 | 13 | (stefil:deftest test-gc-one (&key (genval "GC") (gc 'gc)) 14 | (with-transaction (:message "GC one") 15 | (funcall gc nil) 16 | (let ((obj (simple-tree-create-test genval))) 17 | (loop repeat 10 do 18 | (gc (list (lisp-object-to-mptr obj))) 19 | (stefil:is (= 1 (count-all-instances 'tree))) 20 | (simple-tree-consistency-test obj genval))))) 21 | 22 | (defun test-gc-marray (&key (first t) (len 10) (depth 6) (gc 'gc) (gc-repeat 5) print) 23 | (assert (evenp len)) 24 | (with-transaction (:message "GC marray") 25 | (funcall gc nil) 26 | (let* ((list (loop repeat len collect (test-make-complex-tree depth))) 27 | (count (count-all-instances 'tree))) 28 | 29 | (labels ( 30 | (remaining () 31 | (let ((remaining (remove-if 'tree-parent (retrieve-all-instances 'tree)))) 32 | (stefil:is (= (length remaining) len)) 33 | (when print (format t "~&Remaining = ~A~%" remaining)) 34 | remaining)) 35 | 36 | (consistent () 37 | (stefil:without-test-progress-printing ;;; too much progress 38 | (mapcar 'test-consistency-of-complex-tree (remaining))) 39 | (stefil:is (= count (count-all-instances 'tree))))) 40 | 41 | (consistent) 42 | 43 | (loop repeat gc-repeat do 44 | (gc (remaining)) 45 | (consistent))) 46 | 47 | 48 | 49 | (test-gc-marray-half :first first :count count :list list :gc gc :gc-repeat gc-repeat :print print)))) 50 | 51 | (defun test-gc-marray-half (&key first count list gc (gc-repeat 5) print) 52 | (let ((half (if first 53 | (subseq list 0 (/ (length list) 2)) 54 | (loop for x on list by #'cddr collect (second x))))) 55 | (funcall gc half) 56 | (stefil:is (= count (* 2 (count-all-instances 'tree)))) 57 | 58 | (flet ((remaining () 59 | (let ((remaining (remove-if 'tree-parent (retrieve-all-instances 'tree)))) 60 | (stefil:is (= (length half) (length remaining))) 61 | (when print (format t "~&Remaining = ~A~%" remaining)) 62 | remaining))) 63 | (stefil:without-test-progress-printing ;;; too much progress 64 | (mapcar 'test-consistency-of-complex-tree (remaining))) 65 | (loop repeat gc-repeat 66 | do 67 | (funcall gc (remaining)) 68 | (stefil:is (= count (* 2 (count-all-instances 'tree)))) 69 | (stefil:without-test-progress-printing ;;; too much progress 70 | (mapcar 'test-consistency-of-complex-tree (remaining))))))) 71 | 72 | 73 | (stefil:deftest test-rewrite-gc () 74 | (test-gc-marray :gc (lambda (seq) (rewrite-gc seq)))) 75 | 76 | (stefil:deftest test-gc () 77 | (test-gc-marray :first nil) 78 | (test-gc-marray :first t )) 79 | -------------------------------------------------------------------------------- /src/iterator.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defmacro doclass ((var class-specifier &key fresh-instances reverse) &body body) 4 | "For each object in the memory-mapped datastore of class denoted by 5 | CLASS-SPECIFIER (evaluated), lexically bind VAR to a Lisp 6 | object representing that object around BODY and execute it. 7 | 8 | FRESH-INSTANCES (generalized boolean, not evaluated), if true means 9 | means that a fresh Lisp object will be created for each datastore 10 | object -- by default a single Lisp object is instantiated and it is 11 | modified destructively to point to each object in the class. 12 | 13 | REVERSE (generalized boolean, not evaluated), if true means that 14 | objects will be iterated in order from newest to oldest. If false (default), 15 | they are iterated from oldest to newest. 16 | 17 | Also see dosubclasses. 18 | " 19 | (alexandria:with-unique-names (tag class mtagmap 20 | last-index first-index instantiator len 21 | index) 22 | `(let* ((,class (force-class ,class-specifier)) 23 | (,tag (mm-metaclass-tag ,class)) 24 | (,len (mm-metaclass-len ,class))) 25 | (declare (type mindex ,len)) 26 | (when ,tag ; if finalize-inheritance has not yet been called 27 | (let ((,mtagmap (mtagmap ,tag))) 28 | (unless (mtagmap-closed-p ,mtagmap) 29 | (let* ((,instantiator (mtagmap-instantiator ,mtagmap)) 30 | (,last-index (mtagmap-last-index ,mtagmap)) 31 | (,first-index (mtagmap-first-index ,mtagmap))) 32 | (declare (type mindex ,last-index ,first-index)) 33 | (when (> ,last-index ,first-index) 34 | (decf ,last-index ,len) 35 | (let ((,index ,(if reverse `,last-index `,first-index))) 36 | (loop ,(if fresh-instances `for `with) ,var = (funcall ,instantiator ,index) 37 | do (let ,(when fresh-instances `((,var ,var))) ,@body) 38 | (when (= ,index ,(if reverse `,first-index `,last-index)) 39 | (return)) 40 | (,(if reverse `decf `incf) ,index ,len) 41 | ,@(unless fresh-instances `((setf (%ptr ,var) (make-mptr ,tag ,index)))))))))))))) 42 | 43 | (defun mm-subclasses (class) 44 | (remove-duplicates 45 | (list* class (loop for c in (class-direct-subclasses class) 46 | when (typep class 'mm-metaclass) 47 | appending (mm-subclasses c))))) 48 | 49 | (defmacro dosubclasses ((var class-specifier &rest options) &body body) 50 | "For the class itself and each subclass of the class denoted by CLASS-SPECIFIER (evaluated) run doclass." 51 | (alexandria:with-unique-names (one-class class) 52 | `(flet ((,one-class (,class) 53 | (doclass (,var ,class ,@options) 54 | ,@body))) 55 | (loop for ,class in (mm-subclasses (force-class ,class-specifier)) 56 | do (,one-class ,class))))) 57 | 58 | (defun retrieve-all-instances (class) 59 | "Returns a list of all instances of CLASS." 60 | (let (ret) 61 | (dosubclasses (p class :fresh-instances t) 62 | (push p ret)) 63 | ret)) 64 | 65 | (defun count-all-instances (class) 66 | "Return a count of the number of instances of the class denoted by CLASS and any subclasses of it." 67 | (loop for c in (mm-subclasses (force-class class)) 68 | for m = (mm-metaclass-mtagmap c) 69 | summing 70 | (if (mtagmap-closed-p m) 71 | 0 72 | (mtagmap-count m)))) 73 | 74 | -------------------------------------------------------------------------------- /t/tree.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb.test) 2 | 3 | (stefil:in-suite manardb-test) 4 | 5 | (defmmclass tree () 6 | ((numval :type (unsigned-byte 50) :initform 666 :initarg :numval) 7 | (general-val :initform 'gen-val :initarg :general-val :accessor tree-general-val) 8 | (id :initform (random (ash 1 40)) :type (unsigned-byte 40) :accessor tree-id) 9 | (val :initarg :val :accessor tree-val) 10 | (left :type tree :initform nil :accessor tree-left) 11 | (right :type tree :initform nil :accessor tree-right) 12 | (parent :initarg :parent 13 | :initform nil 14 | :accessor tree-parent) 15 | (temporary-slot :persistent nil))) 16 | 17 | (defmethod print-object ((tree tree) stream) 18 | (print-unreadable-object (tree stream :type t) 19 | (format stream "id ~A ptr ~A" (tree-id tree) (lisp-object-to-mptr tree)) 20 | (loop for slot in '(left right parent) 21 | do (format stream " ~A ~A" 22 | slot (lisp-object-to-mptr (slot-value tree slot)))) 23 | (format stream " children ~A" (marray-to-list (tree-val tree))))) 24 | 25 | (stefil:deftest create-tree-class-test () 26 | (stefil:is (find-class 'tree))) 27 | 28 | (stefil:deftest simple-tree-create-test (&optional (gen-val "This is a string")) 29 | (create-tree-class-test) 30 | (let ((tree (make-instance 'tree :general-val gen-val))) 31 | (setf (tree-left tree) tree) 32 | (setf (tree-right (tree-left tree)) 'right) 33 | (stefil:is (eq 'right (tree-right (tree-left tree)))) 34 | (setf (tree-left (tree-left tree)) nil) 35 | (stefil:is (eq nil (tree-left tree))) 36 | (setf (tree-val tree) (make-marray 10 :initial-element tree)) 37 | 38 | (simple-tree-consistency-test tree gen-val) 39 | tree)) 40 | 41 | (stefil:deftest simple-tree-consistency-test (tree gen-val) 42 | (stefil:is (not (slot-boundp tree 'temporary-slot))) 43 | (stefil:is (eq (tree-right tree) 'right)) 44 | (stefil:is (equalp (slot-value tree 'numval) 666)) 45 | (stefil:is (equalp (tree-general-val tree) gen-val)) 46 | (stefil:is (not (eq (tree-general-val tree) gen-val))) 47 | (stefil:is (= 10 (marray-length (tree-val tree)))) 48 | (iter (for a in-marray (tree-val tree)) 49 | (stefil:is (meq a tree)))) 50 | 51 | (stefil:deftest symbol-slot-tree-create-test (&optional (symbol :keyword)) 52 | (create-tree-class-test) 53 | (let ((tree (make-instance 'tree :val symbol))) 54 | (stefil:is (eq symbol (funcall 'tree-val tree))) 55 | (stefil:is (eq symbol (slot-value tree 'val))) 56 | (stefil:is (eq 'gen-val (slot-value tree 'general-val))) 57 | tree)) 58 | 59 | 60 | (stefil:deftest test-make-complex-tree (&optional (depth 3) parent) 61 | (cond ((plusp depth) 62 | (let ((tree 63 | (make-instance 'tree :numval depth :parent parent))) 64 | (setf (slot-value tree 'temporary-slot) :complex) 65 | (setf (tree-val tree) 66 | (let ((m (make-marray depth))) 67 | (loop for i below depth 68 | for last-tree = nil then new-tree 69 | for new-tree = (funcall 'test-make-complex-tree (1- depth) tree) 70 | do 71 | (when last-tree 72 | (setf (tree-right last-tree) new-tree) 73 | (setf (tree-left new-tree) last-tree)) 74 | (setf (marray-ref m i) 75 | new-tree)) 76 | m)) 77 | (test-consistency-of-complex-tree tree depth) 78 | (stefil:is (eq (slot-value tree 'temporary-slot) :complex)) 79 | tree)) 80 | (t 81 | 'leaf))) 82 | 83 | (stefil:deftest test-consistency-of-complex-tree (tree &optional (depth (slot-value tree 'numval)) (parent nil parent-given-p)) 84 | (let ((marray (tree-val tree))) 85 | (stefil:is (= depth (slot-value tree 'numval))) 86 | (when parent-given-p 87 | (stefil:is (meq parent (slot-value tree 'parent)))) 88 | (loop for i below depth 89 | for last-ref = nil then ref 90 | for ref = (marray-ref marray i) 91 | do 92 | (cond ((= 1 depth) 93 | (stefil:is (eq 'leaf ref))) 94 | (t 95 | (stefil:is (typep ref 'tree)) 96 | (stefil:is (not (slot-boundp ref 'temporary-slot))) 97 | (when last-ref 98 | (stefil:is (not (meq ref (tree-right ref)))) 99 | (stefil:is (meq ref (tree-right last-ref))) 100 | (stefil:is (meq (tree-left ref) last-ref))) 101 | (funcall 'test-consistency-of-complex-tree ref (1- depth) tree)))))) 102 | -------------------------------------------------------------------------------- /src/struct.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defvar *mmap-pathname-defaults*) 4 | (defvar *mmap-base-pathname*) 5 | (setf (documentation '*mmap-base-pathname* 'variable) 6 | "The base path in which the datastore files are to be found.") 7 | (defvar *mmap-sharing* osicat-posix:MAP-SHARED) 8 | (defvar *mmap-protection* (logior osicat-posix:PROT-READ osicat-posix:PROT-WRITE)) 9 | (defvar *mmap-may-allocate* t 10 | "If this is not true, and an attempt is made to extend a memory mapped region, an error will be signalled.") 11 | 12 | (deftype mptr () 13 | "A representation of a location in the memory mapped datastore. 14 | Remains constant across remappings of the memory mapped regions to different offsets in physical memory." 15 | `(unsigned-byte ,+mptr-bits+)) 16 | 17 | (deftype mtag () 18 | `(unsigned-byte ,+mtag-bits+)) 19 | 20 | (deftype mindex () 21 | `(unsigned-byte ,+mindex-bits+)) 22 | 23 | (deftype machine-pointer () 24 | (type-of (cffi:null-pointer)) 25 | #+allegro 26 | (progn 27 | `(unsigned-byte 32) 28 | #+64bit `(unsigned-byte 64))) 29 | 30 | (defun stored-cffi-type (type) 31 | (let ((cffi-type 32 | (alexandria:switch (type :test 'subtypep) 33 | ('(unsigned-byte 8) :unsigned-char) 34 | ('(unsigned-byte 64) :unsigned-long-long) 35 | ('(signed-byte 64) :long-long) 36 | ('single-float :float) 37 | ('double-float :double)))) 38 | cffi-type)) 39 | 40 | (defun stored-type-size (type) 41 | (cffi:foreign-type-size (or (stored-cffi-type type) (stored-cffi-type 'mptr)))) 42 | 43 | (defmacro d (machine-pointer &optional (index 0) (type '(unsigned-byte 8))) 44 | `(cffi:mem-aref ,machine-pointer ,(stored-cffi-type type) ,index)) 45 | 46 | (defmacro dw (machine-pointer &optional (index 0)) 47 | `(d ,machine-pointer ,index mptr)) 48 | 49 | (defun-speedy mptr-tag (mptr) 50 | (declare (type mptr mptr) (optimize (safety 0))) 51 | (the mtag (logand mptr (1- (ash 1 +mtag-bits+))))) ; Allegro 8.1 is too stupid to optimize ldb 52 | 53 | (declaim (ftype (function (mptr) (mindex)) mptr-index)) 54 | (defun-speedy mptr-index (mptr) 55 | (declare (type mptr mptr) (optimize (safety 0))) 56 | (the mindex (ash mptr (- +mtag-bits+)))) 57 | 58 | (declaim (ftype (function (mtag mindex) mptr) make-mptr)) 59 | (defun-speedy make-mptr (tag index) 60 | (declare (type mtag tag) (type mindex index)) 61 | (the mptr (logior (ash index +mtag-bits+) tag))) 62 | 63 | (deftype mm-instantiator () 64 | `(function (mindex) t) 65 | 66 | ;; Allegro 8.1 has a horrible bug with function type specifiers and `the' 67 | #+allegro `function 68 | ) 69 | 70 | (deftype mm-walk-func () 71 | `(function (mptr mptr mindex) t) 72 | 73 | ;; Allegro 8.1 has a horrible bug with function type specifiers and `the' 74 | #+allegro `function 75 | ) 76 | 77 | (declaim (inline mtagmap-ptr mtagmap-len mtagmap-elem-len)) 78 | 79 | (defstruct mtagmap 80 | (fd -1 :type fixnum) 81 | (ptr (cffi:null-pointer) :type machine-pointer) 82 | (len 0 :type mindex) 83 | 84 | class 85 | layout 86 | instantiator 87 | walker 88 | (elem-len 0 :type mindex)) 89 | 90 | (deftype mtagmaps-array () 91 | `(simple-array (or mtagmap null) (,+mtags+))) 92 | 93 | (defvar *mtagmaps* (the mtagmaps-array (make-array +mtags+ :initial-element nil :element-type 94 | '(or mtagmap null)))) 95 | (declaim (type mtagmaps-array *mtagmaps*)) 96 | 97 | (defun-speedy mtagmap (mtag) 98 | (declare (type mtag mtag)) 99 | (aref (the mtagmaps-array *mtagmaps*) mtag)) 100 | 101 | (defun (setf mtagmap) (val mtag) 102 | (check-type mtag mtag) 103 | (check-type val (or null mtagmap)) 104 | (setf (aref (the mtagmaps-array *mtagmaps*) mtag) val)) 105 | 106 | (defmacro mm-instantiator-for-tag (mtag) 107 | `(the mm-instantiator (mtagmap-instantiator (the mtagmap (mtagmap ,mtag))))) 108 | 109 | (defun next-available-tag () 110 | (loop for i from 0 111 | thereis (unless (mtagmap i) i))) 112 | 113 | (defun-speedy mpointer (mtag mindex) 114 | (declare (type mtag mtag) (type mindex mindex)) 115 | (cffi:inc-pointer (mtagmap-ptr (the mtagmap (mtagmap mtag))) mindex)) 116 | 117 | (defun-speedy mptr-pointer (mptr) 118 | (mpointer (mptr-tag mptr) (mptr-index mptr))) 119 | 120 | (defun-speedy mptr-to-lisp-object (mptr) 121 | "Deference the object at location MPTR in the memory mapped datastore and create a Lisp representation of it." 122 | (funcall (the mm-instantiator (mm-instantiator-for-tag (mptr-tag mptr))) 123 | (mptr-index mptr))) 124 | 125 | -------------------------------------------------------------------------------- /doc/index.html: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | manardb 7 | 8 | 9 | 10 | 11 |
12 |

manardb

13 | 14 |

Fast, persistent, memory-mapped Lisp object store

15 |
16 | 17 |

Introduction

18 | 19 |

Manardb provides persistent classes (integrated into the 20 | object system via the meta-object protocol), stored efficiently 21 | in memory mapped regions. It features transactions, two 22 | different garbage collection mechanisms (to clean up 23 | unreferenced objects in the datastore), in-place modification of 24 | arrays, efficient in-place numeric typed slots, and the ability 25 | to transparently serialise Lisp objects of many types (lists, 26 | vectors, floats, integers, symbols, strings).

27 | 28 |

It allows Common Lisp programs to efficiently access in-memory 29 | representations of large numbers of persistent objects without 30 | putting pressure on the Lisp garbage collector.

31 | 32 |

Concurrency

33 | 34 |

Multiple concurrent readers and writers can access the database 35 | without problems; both multiple threads and multiple processes 36 | work fine. However, they have to either arrange not allocate new 37 | objects (by using fixed-size numeric-typed slots, and 38 | fixed-length strings) or ensure via some locking mechanism that 39 | only one thread can allocate at a time, and all processes update 40 | their mappings after an allocation. Additionally, they must 41 | ensure that writers do not conflict together or confuse 42 | readers.

43 | 44 |

Alternatively, they could use the race free transaction 45 | support. (Readers continue to refer to an old snapshot until 46 | they explicitly reload the database.)

47 | 48 |

Efficiency

49 | 50 |

According to our benchmarks, when instantiating a object 51 | with two slots one million times, manardb is about seven times 52 | faster than AllegroCache 2.1.11 on Allegro 8.1, and about fifteen 53 | times faster than AllegroCache on SBCL 1.0.31. It is more than 54 | ten times faster to iterate over the 1M objects created and sum 55 | the values of one numeric slot on Allegro Lisp, and about one 56 | hundred times faster on SBCL.

57 | 58 |

Portability

59 | 60 |

Manardb works on Common Lisp implementations on Linux. We 61 | have tested SBCL 1.0.31 and Allegro 8.1, and lightly tested 62 | Lispworks and ClozureCL. 63 | 64 |

It uses the mremap system call so is restricted to Linux. It 65 | would be trivial to change the mremap to a munmap, followed by 66 | mmap on other UN*X like platforms, as manardb is already 67 | prepared for the base address of the mapping to change. 68 | 69 |

Using it

70 | 71 |

Start 72 | Lisp. Get asdf-install. 73 |

74 | 75 | 
 76 |       CL-USER> (asdf-install:install 'manardb)
 77 |       CL-USER> (asdf:operate 'asdf:load-op 'manardb)
 78 |
79 | 80 | 
 81 | CL-USER> (defclass foo ()
 82 |   ((next :initform nil)
 83 |    (val :initarg :val :accessor foo-val :type (unsigned-byte 32)))
 84 |   (:metaclass manardb:mm-metaclass))
 85 | #<MM-METACLASS FOO>
 86 |
87 | 88 |

The API is documented.

89 | 90 |

Downloads

91 | 92 |

Downloads

93 | 94 |

Git development tree access

95 | 96 |

git clone 97 | http://cl-www.msi.co.jp/projects/manardb/manardb.git

98 | 99 |

Future directions

100 | 101 |

manardb is just starting out. It hasn't tapped the full 102 | potential of this approach. There are many ways to improve it.

103 | 104 | 119 | 120 | 121 | 122 | -------------------------------------------------------------------------------- /src/gc.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defun gc-compact (offsets-table) 4 | (loop for mtagmap across *mtagmaps* 5 | for offsets across offsets-table 6 | for tag from 0 7 | when offsets 8 | do 9 | (let ((elem-len (mtagmap-elem-len mtagmap)) (cur-offset (mtagmap-first-index mtagmap))) 10 | (loop for new-offset across offsets 11 | for old-offset from (mtagmap-first-index mtagmap) by elem-len 12 | do 13 | (unless (zerop new-offset) 14 | (assert (= cur-offset new-offset)) 15 | (assert (>= old-offset new-offset)) 16 | (osicat-posix:memmove (mpointer tag new-offset) (mpointer tag old-offset) elem-len) 17 | (setf cur-offset (+ new-offset elem-len)))) 18 | (setf (mtagmap-next mtagmap) cur-offset)))) 19 | 20 | (defun gc-calc-new-offsets (mtagmap table) 21 | (when table 22 | (let ((offsets (make-array (length table) :element-type 'mindex :initial-element 0)) 23 | (next (mtagmap-first-index mtagmap)) 24 | (elem-len (mtagmap-elem-len mtagmap))) 25 | (loop for refs across table 26 | for i from 0 27 | do (when refs 28 | (setf (aref offsets i) next) 29 | (incf next elem-len))) 30 | offsets))) 31 | 32 | (defun gc-rewrite-pointers-and-compact (refs-table) 33 | (clear-caches) 34 | (let ((offsets-table (map 'vector 'gc-calc-new-offsets *mtagmaps* refs-table))) 35 | (loop for mtagmap across *mtagmaps* 36 | for tag from 0 37 | for elem-len = (when mtagmap (mtagmap-elem-len mtagmap)) 38 | for table across refs-table 39 | for offsets across offsets-table 40 | when table 41 | do 42 | (mtagmap-check mtagmap) 43 | (loop for pos from 0 44 | for refs across table 45 | for old-offset from (mtagmap-first-index mtagmap) by elem-len 46 | for old-mptr = (make-mptr tag old-offset) 47 | for new-offset across offsets 48 | for new-mptr = (make-mptr tag new-offset) 49 | when refs 50 | do 51 | (labels ((up (ref) 52 | (declare (type mptr ref)) 53 | (unless (zerop ref) 54 | (assert (= (d (mptr-pointer ref) 0 mptr) old-mptr)) 55 | (unless (= old-mptr new-mptr) 56 | (setf (d (mptr-pointer ref) 0 mptr) new-mptr))))) ;;; XXX only write if necessary so that pages are not pointlessly dirtied 57 | (typecase refs 58 | (array 59 | (loop for r across refs do (up r))) 60 | (t 61 | (up refs)))))) 62 | (gc-compact offsets-table))) 63 | 64 | (defun gc (root-objects-sequence &key verbose (collect-and-compact t)) 65 | "Do a full and precise garbage collection over all objects in the memory mapped system. 66 | If COLLECT-AND-COMPACT is true, then unused objeccts are removed. 67 | 68 | Uses at least two pointers of Lisp memory per object and more if 69 | objects are densely referenced. See REWRITE-GC for a sloppier 70 | alternative that does not need so much memory. 71 | " 72 | 73 | (declare (optimize speed)) 74 | (let ((refs-table (map 'vector (lambda (m) 75 | (unless (or (not m) (mtagmap-closed-p m)) 76 | ;;; also tried with a hash-table but in comparison it is very very slow on Allegro 77 | (make-array (mtagmap-count m) :initial-element nil))) 78 | *mtagmaps*)) 79 | (root-objects-sequence (map '(vector mptr) #'force-mptr root-objects-sequence ))) 80 | (macrolet ((r (mptr) 81 | (check-type mptr symbol) 82 | `(aref (aref refs-table (mptr-tag ,mptr)) (mtagmap-elem-pos (mtagmap (mptr-tag ,mptr)) (mptr-index ,mptr)) ) 83 | )) 84 | (labels ((add-ref (mptr referrer) 85 | (symbol-macrolet ((ref (r mptr))) 86 | (let ((rref ref)) 87 | (typecase rref 88 | (array 89 | (when (zerop referrer) 90 | (return-from add-ref)) 91 | (vector-push-extend referrer rref)) 92 | (null 93 | (setf ref referrer)) 94 | (t 95 | (cond ((zerop rref) 96 | (setf ref referrer)) 97 | ((= rref referrer)) 98 | (t 99 | (setf ref 100 | (make-array 2 :adjustable t :fill-pointer 2 101 | :initial-contents (list rref referrer) 102 | :element-type 'mptr))))))))) 103 | (walk-ref (mptr referrer len) 104 | (unless (zerop mptr) 105 | (let ((first-time (not (r mptr)))) 106 | (add-ref mptr referrer) 107 | (when first-time 108 | (let ((walker (mtagmap-walker (mtagmap (mptr-tag mptr))))) 109 | (when walker 110 | (funcall walker mptr #'walk-ref)))) 111 | (unless (= 1 len) 112 | (walk-ref (+ mptr (ash (mtagmap-elem-len 113 | (mtagmap (mptr-tag mptr))) +mtag-bits+)) 0 (1- len))))))) 114 | (declare (dynamic-extent #'walk-ref #'add-ref)) 115 | (iter (for o in-vector root-objects-sequence) 116 | (walk-ref o 0 1)) 117 | (when verbose 118 | (loop for m across *mtagmaps* 119 | for table across refs-table 120 | do 121 | (when table 122 | (format t "~A total ~D used ~D~&" 123 | (mtagmap-class m) (mtagmap-count m) 124 | (count-if-not #'not table) 125 | )))) 126 | (when collect-and-compact 127 | (gc-rewrite-pointers-and-compact refs-table) 128 | (shrink-all-mmaps)) 129 | (values))))) 130 | 131 | -------------------------------------------------------------------------------- /src/mop.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defclass mm-metaclass (standard-class) 4 | ((mtagmap :accessor mm-metaclass-mtagmap :initform nil) 5 | (tag :reader mm-metaclass-tag :initform nil) 6 | (len :initform 0 :accessor mm-metaclass-len) 7 | (default-instantiator :initform nil) 8 | (default-walker :initform nil) 9 | (walker :initarg walker :initform nil) 10 | (instantiator :accessor mm-instantiator :initarg instantiator :initform nil) 11 | (allocator :initform nil)) 12 | (:documentation "Metaclass for memory mapped objects.")) 13 | 14 | (defclass mm-object () 15 | ((%ptr :type mptr :accessor %ptr :initarg %ptr)) 16 | (:documentation "Base class for all memory mapped objects.")) 17 | 18 | (declaim (ftype (function (mm-object) (mptr)) ptr)) 19 | (defun-speedy ptr (object) 20 | (declare (type mm-object object)) 21 | (the mptr (%ptr object))) 22 | (define-compiler-macro ptr (object) 23 | `(the mptr (%ptr (the mm-object ,object)))) 24 | 25 | (defun-speedy mm-object-pointer (mm-object) 26 | (mptr-pointer (ptr mm-object))) 27 | 28 | (defmethod initialize-instance :around ((class mm-metaclass) 29 | &rest all-keys) 30 | (ensure-inherits-from-mm-object class #'call-next-method all-keys)) 31 | (defmethod reinitialize-instance :around ((class mm-metaclass) 32 | &rest all-keys) 33 | (ensure-inherits-from-mm-object class #'call-next-method all-keys)) 34 | 35 | (defun ensure-inherits-from-mm-object (class next-method all-keys) 36 | (let ((parent (find-class 'mm-object))) 37 | (labels ((inherits-from (classes) 38 | (loop for class in classes 39 | thereis (or (subtypep class parent) 40 | (inherits-from (class-direct-subclasses class)))))) 41 | (let ((all-keys (copy-list all-keys))) 42 | (symbol-macrolet ((direct-superclasses (getf all-keys :direct-superclasses))) 43 | (setf direct-superclasses 44 | (if (inherits-from direct-superclasses) 45 | direct-superclasses 46 | (cons parent direct-superclasses)))) 47 | (apply next-method class all-keys))))) 48 | 49 | (deftype mm-slot-definition-reader () 50 | `(function (mm-object) t)) 51 | 52 | (deftype mm-slot-definition-writer () 53 | `(function (t mm-object) t)) 54 | 55 | (defgeneric slot-definition-memory-mapped (slotd) 56 | (:method (slotd) 57 | (declare (ignorable slotd)))) 58 | 59 | (defgeneric slot-definition-mmap-pointer-p (slotd) 60 | (:method (slotd) 61 | (declare (ignorable slotd)))) 62 | 63 | (defclass mm-slot-definition (slot-definition) 64 | ((persistent :initarg :persistent :reader slot-definition-memory-mapped :initform t))) 65 | 66 | 67 | (defclass mm-effective-slot-definition (mm-slot-definition standard-effective-slot-definition) 68 | ((offset :initarg :offset :reader mm-slot-definition-offset) 69 | (mmap-pointer-p :initform nil :initarg :mmap-pointer-p :accessor slot-definition-mmap-pointer-p) 70 | (writer-function :accessor slot-definition-writer-function) 71 | (reader-function :accessor slot-definition-reader-function))) 72 | 73 | (defclass mm-direct-slot-definition (standard-direct-slot-definition mm-slot-definition) 74 | ()) 75 | 76 | (defmethod validate-superclass ((class mm-metaclass) (super standard-class)) 77 | "Memory mapped classes may inherit from ordinary classes." 78 | t) 79 | 80 | (defmethod validate-superclass ((class standard-class) (super mm-metaclass)) 81 | "Ordinary classes may NOT inherit from memory mapped classes." 82 | nil) 83 | 84 | (defmethod slot-definition-allocation ((slotd mm-slot-definition)) 85 | (if (slot-definition-memory-mapped slotd) 86 | 'memory 87 | (call-next-method))) 88 | 89 | 90 | (defmethod direct-slot-definition-class ((class mm-metaclass) &rest initargs) 91 | (declare (ignore initargs)) 92 | (find-class 'mm-direct-slot-definition)) 93 | 94 | (defvar *mop-hack-effective-slot-definition-class* nil) ;; as compute-effective-slot-definition-initargs is not available portably 95 | 96 | (defmethod effective-slot-definition-class ((class mm-metaclass) &rest initargs) 97 | (declare (ignore initargs)) 98 | (or 99 | *mop-hack-effective-slot-definition-class* 100 | (call-next-method))) 101 | 102 | (defmethod compute-slots :before ((class mm-metaclass)) 103 | (with-slots (len) 104 | class 105 | (setf len 0))) 106 | 107 | (defmethod compute-effective-slot-definition :around ((class mm-metaclass) name dslotds) 108 | (declare (ignorable name)) 109 | (let ((dslotds (remove nil dslotds))) 110 | (let ((last-dslot (first (last dslotds)))) 111 | (let ((*mop-hack-effective-slot-definition-class* 112 | (when (slot-definition-memory-mapped last-dslot) 113 | (find-class 'mm-effective-slot-definition)))) 114 | (let ((eslot (call-next-method))) 115 | (when (slot-definition-memory-mapped eslot) 116 | (setf (slot-definition-mmap-pointer-p eslot) 117 | (loop for dslot in dslotds 118 | always (or (eq 'mptr (slot-definition-type dslot)) 119 | (eq 'mm-box (slot-definition-mm-type dslot))))) 120 | 121 | (let ((type (slot-definition-type eslot))) 122 | (with-slots (len) 123 | class 124 | (setf (slot-value eslot 'offset) len) 125 | (incf len (stored-type-size type))))) 126 | eslot))))) 127 | 128 | (defmethod slot-value-using-class ((class mm-metaclass) object (slotd mm-effective-slot-definition)) 129 | (declare (ignorable class)) 130 | (funcall (the mm-slot-definition-reader (slot-definition-reader-function slotd)) object)) 131 | 132 | (defmethod (setf slot-value-using-class) (new-value (class mm-metaclass) object (slotd mm-effective-slot-definition)) 133 | (declare (ignorable class)) 134 | (funcall (the mm-slot-definition-writer (slot-definition-writer-function slotd)) new-value object)) 135 | 136 | (defmethod slot-boundp-using-class ((class mm-metaclass) object (slotd mm-effective-slot-definition)) 137 | (declare (ignorable class object slotd)) 138 | t) 139 | (defmethod slot-makunbound-using-class ((class mm-metaclass) object (slotd mm-effective-slot-definition)) 140 | (declare (ignorable class object slotd)) 141 | (error "Memory mapped slots cannot be unbound.")) 142 | 143 | 144 | -------------------------------------------------------------------------------- /src/rewrite-gc.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defun rewrite-gc-walk (root-objects-sequence shared-tables new-mtagmaps &key progress) 4 | (declare (optimize speed)) 5 | (let* ((print-step 6 | (when progress 7 | (ceiling (length root-objects-sequence) (if (numberp progress) progress 10)))) 8 | (print-next print-step) 9 | (start-time (get-internal-real-time)) 10 | (root-objects-sequence (map '(vector mptr) #'force-mptr root-objects-sequence ))) 11 | 12 | (iter 13 | (for o in-vector root-objects-sequence) 14 | (for count from 0) 15 | (when (and print-next (= count print-next)) 16 | (let ((now (get-internal-real-time))) 17 | (unless (= now start-time) 18 | (format t "~&Added ~D objects; ~$ object/s~%" count 19 | (/ (* count internal-time-units-per-second) (- now start-time))))) 20 | (incf print-next print-step)) 21 | 22 | (rewrite-gc-copy-one-root o shared-tables new-mtagmaps)))) 23 | 24 | (defun rewrite-gc-copy-one-root (mptr shared-tables new-mtagmaps) 25 | (let ((visited 26 | (map 'vector 27 | (lambda (x table) 28 | (or table 29 | (when x (make-hash-table :test 'eql)))) 30 | new-mtagmaps shared-tables))) 31 | (declare (dynamic-extent visited)) 32 | (macrolet ((vref (mptr) 33 | `(gethash (mptr-index ,mptr) 34 | (aref (the simple-vector visited) (mptr-tag ,mptr))))) 35 | 36 | (labels ((allocate-ref (mptr num) 37 | (declare (type mptr mptr) 38 | (type mindex num)) 39 | (let* ((tag (mptr-tag mptr)) 40 | (mtagmap (aref new-mtagmaps tag)) 41 | (len (mtagmap-elem-len mtagmap)) 42 | (total-len (* num len)) 43 | (new-index (mtagmap-alloc mtagmap total-len)) 44 | (new-mptr (make-mptr tag new-index))) 45 | 46 | (osicat-posix:memcpy 47 | (cffi:inc-pointer (mtagmap-ptr mtagmap) 48 | new-index) 49 | (mptr-pointer mptr) 50 | total-len) 51 | new-mptr)) 52 | (walk-ref (mptr referrer num) 53 | (declare (ignore referrer)) 54 | (cond ((zerop mptr) 0) 55 | ((vref mptr)) 56 | (t 57 | (let* ((new-mptr (allocate-ref mptr num)) 58 | (mtagmap (mtagmap (mptr-tag mptr))) 59 | (walker (mtagmap-walker mtagmap))) 60 | (setf (vref mptr) new-mptr) 61 | 62 | (when walker 63 | (let ((old-index (mptr-index mptr))) 64 | (labels ((reset-ref (child-mptr referrer num) 65 | (declare (type mptr child-mptr referrer) 66 | (type mindex num)) 67 | 68 | (let ((offset (- (mptr-index referrer) old-index)) 69 | (new-child-mptr (walk-ref child-mptr referrer num))) 70 | 71 | (setf 72 | (dw 73 | (cffi:inc-pointer 74 | (mtagmap-ptr 75 | (aref new-mtagmaps (mptr-tag new-mptr))) 76 | (+ offset (mptr-index new-mptr)))) 77 | new-child-mptr)))) 78 | (declare (dynamic-extent #'reset-ref)) 79 | (funcall walker mptr #'reset-ref) 80 | (unless (= 1 num) 81 | (let* ((elem-len (mtagmap-elem-len mtagmap)) 82 | (step (ash elem-len +mtag-bits+))) 83 | (loop for i from 1 below num do 84 | (incf mptr step) 85 | (incf new-mptr step) 86 | (incf old-index elem-len) 87 | (funcall walker mptr #'reset-ref)) 88 | (decf new-mptr (* step (1- num)))))))) 89 | 90 | new-mptr))))) 91 | (declare (dynamic-extent #'walk-ref)) 92 | (walk-ref mptr 0 1))))) 93 | 94 | (defun rewrite-gc-cleanup (new-mtagmaps new-files) 95 | (loop for new across new-mtagmaps 96 | for old across *mtagmaps* 97 | for new-file in new-files 98 | do 99 | (when new 100 | (mtagmap-close new) 101 | (let ((old-file (mtagmap-default-filename old))) 102 | (mtagmap-close old) 103 | (osicat-posix:rename new-file old-file) 104 | (mtagmap-open old))))) 105 | 106 | (defun rewrite-gc (root-objects-sequence &key 107 | progress verbose shared-classes 108 | (base-shared-classes '(mm-symbol))) 109 | 110 | "An alternative, sloppier GC algorithm with a space complexity that is not proportional to the size of the datastore. 111 | 112 | Creates a new datastore by copying each element of 113 | ROOT-OBJECTS-SEQUENCE as if it were entirely self contained except for 114 | any shared objects in SHARED-CLASSES. 115 | 116 | Cannot handle pointers to the inside of arrays at all; they will be 117 | recreated pointing to fresh objects. Note that arrays pointing to 118 | complex objects (or any user defined classes) are stored as arrays of 119 | mptrs, with each mptr pointing to the actual object; it is fine to 120 | have pointers to these objects, because the actual objects are not 121 | stored in the array." 122 | (check-mmap-truncate-okay) 123 | (let* ((new-mtagmaps 124 | (map '(vector (or null mtagmap)) 125 | (lambda (m) 126 | (when (and m (not (mtagmap-closed-p m))) 127 | (let ((m (copy-structure m))) 128 | (mtagmap-detach m) 129 | m))) 130 | *mtagmaps*)) 131 | (shared-tables 132 | (make-array (length *mtagmaps*) :initial-element nil)) 133 | (new-files 134 | (loop for m across new-mtagmaps 135 | collect 136 | (when m 137 | (make-pathname :type "rewrite" :defaults (mm-metaclass-pathname (mtagmap-class m))))))) 138 | (flet ((add-shared (seq) 139 | (map nil (lambda (x) 140 | (setf (aref shared-tables (force-tag x)) (make-hash-table :test 'eql))) seq))) 141 | (add-shared base-shared-classes) 142 | (add-shared shared-classes)) 143 | 144 | (unwind-protect 145 | (progn 146 | (loop for m across new-mtagmaps 147 | for f in new-files 148 | do 149 | (when m 150 | (ignore-errors (delete-file f)) 151 | (mtagmap-open m :file f :finalize nil))) 152 | (rewrite-gc-walk root-objects-sequence shared-tables new-mtagmaps :progress progress) 153 | (when verbose 154 | (loop for new across new-mtagmaps 155 | for old across *mtagmaps* 156 | when new 157 | do 158 | (let ((cold (mtagmap-count old)) 159 | (cnew (mtagmap-count new))) 160 | (cond ((zerop cold) 161 | (assert (zerop cnew))) 162 | (t 163 | (format t "~&~A before ~D after ~D; change ~D~%" 164 | (mtagmap-class old) cold cnew (- cnew cold))))))) 165 | (rewrite-gc-cleanup new-mtagmaps new-files)) 166 | (loop for m across new-mtagmaps 167 | for f in new-files 168 | do 169 | (when m 170 | (mtagmap-close m) 171 | (ignore-errors (delete-file f))))))) 172 | -------------------------------------------------------------------------------- /src/types.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defmmclass mm-symbol () 4 | ((package-name :initarg :package) 5 | (symbol-name :initarg :symbol)) 6 | (instantiator unbox-symbol)) 7 | 8 | (defmmclass mm-box () 9 | ((ptr)) 10 | (instantiator unbox-box)) 11 | 12 | (defmmclass marray () ;; special arrays 13 | ((length :type mindex :initarg :length :reader marray-length) 14 | (base :type mptr :initarg :base :reader marray-base)) 15 | (:documentation "The base representation of a memory-mapped vector.") 16 | (walker walk-array)) 17 | 18 | (defmmclass mm-array (marray) ;; stored lisp arrays 19 | () 20 | (instantiator unbox-array) 21 | (walker walk-array)) 22 | 23 | (defmmclass mm-string (mm-array) 24 | () 25 | (instantiator unbox-string) 26 | (walker walk-array)) 27 | 28 | (defmmclass mm-cons () 29 | ((a :initarg :car) 30 | (b :initarg :cdr)) 31 | (instantiator unbox-cons)) 32 | 33 | (defmmclass mm-array-as-list (mm-array) 34 | () 35 | (walker walk-array) 36 | (instantiator unbox-array-as-list)) 37 | 38 | (eval-when (:compile-toplevel :load-toplevel) 39 | (defun specialized-class-array-boxer-name (classname) 40 | (alexandria:symbolicate classname '-array-boxer)) 41 | 42 | (defun generate-boxed-numeric-type (name &key type) 43 | (let ((unboxer (alexandria:symbolicate 'unbox- name))) 44 | `(progn 45 | (eval-when (:compile-toplevel :load-toplevel) 46 | (defmmclass ,name () 47 | ((value :type ,type)) 48 | (instantiator ,unboxer))) 49 | (with-constant-tag-for-class (tag ,name) 50 | (defun-speedy ,unboxer (index) 51 | (d (mpointer tag index) 0 ,type))) 52 | (define-box-array ,(specialized-class-array-boxer-name name) ,name ,type))))) 53 | 54 | 55 | (defmacro define-boxed-numeric-types (&rest typespecs) 56 | (let (types) 57 | `(progn 58 | ,@(loop for typespec in typespecs 59 | collect 60 | (destructuring-bind (name &optional (type name)) 61 | (alexandria:ensure-list typespec) 62 | (let ((name (alexandria:symbolicate 'boxed- name))) 63 | (push `(,name . ,type) types) 64 | (generate-boxed-numeric-type name :type type)))) 65 | 66 | (macrolet ((later () 67 | (generate-boxer ',(reverse types)))) 68 | (later))))) 69 | 70 | (defun-speedy unbox-array-internal-general (elem-tag elem-index len) 71 | (declare (type mtag elem-tag) (type mindex elem-index) (type mindex len)) 72 | (let* ((mtagmap (mtagmap elem-tag)) 73 | (ilen (mtagmap-elem-len mtagmap)) 74 | (instantiator (mtagmap-instantiator mtagmap)) 75 | (array (make-array len))) 76 | (declare (type mm-instantiator instantiator)) 77 | (loop for i below len 78 | for index from elem-index by ilen 79 | do (setf (aref array i) (funcall (the mm-instantiator instantiator) index))) 80 | array)) 81 | 82 | (defgeneric lisp-object-to-mptr-impl (object) 83 | (:documentation 84 | 85 | "Override this generic function to give an user-defined class an 86 | alternative serialisation in the memory mapped datastore. Return the 87 | mptr pointing to this serialisation. 88 | 89 | Note that the serialisation for builtin types are inlined and cannot 90 | be affected. 91 | ")) 92 | 93 | (eval-when (:compile-toplevel :load-toplevel) 94 | (defun generate-boxer (types) 95 | `(progn 96 | (defun-speedy box-object (object) 97 | (typecase object 98 | ,@(loop for (class . type) in types 99 | collect 100 | `(,type 101 | ,(let* ((class (find-class class)) 102 | (tag (mm-metaclass-tag class))) 103 | `(let ((index (mtagmap-alloc (mtagmap ,tag) ,(mm-metaclass-len class)))) 104 | (setf (d (mpointer ,tag index) 0 ,type) object) 105 | (make-mptr ,tag index))))) 106 | (symbol (box-symbol object)) 107 | (string (box-string object)) 108 | (array (locally 109 | (declare (notinline box-array)) 110 | (box-array object))) 111 | (cons (box-cons object)) 112 | (t (lisp-object-to-mptr-impl object)))) 113 | 114 | (defun-speedy unbox-array-internal (elem-tag elem-index len) 115 | (declare (type mtag elem-tag) (type mindex elem-index) (type mindex len)) 116 | (case elem-tag 117 | ,@(loop for (classname . type) in types 118 | for class = (find-class classname) 119 | for tag = (mm-metaclass-tag class) 120 | collect 121 | `(,tag 122 | (let ((array (make-array len :element-type ',type)) 123 | (pointer (mpointer ,tag elem-index))) 124 | (declare (type (simple-array ,type) array)) 125 | (loop for i below len 126 | do (setf (aref array i) (d pointer i ,type))) 127 | array))) 128 | (t (unbox-array-internal-general elem-tag elem-index len)))) 129 | 130 | 131 | 132 | 133 | (defun-speedy box-array (object) 134 | (assert (not (cdr (array-dimensions object)))) 135 | (declaim (notinline general-box-array)) 136 | (etypecase object 137 | (simple-array 138 | (typecase object 139 | ,@(loop for (class . type) in types 140 | collect `((array ,type) (,(specialized-class-array-boxer-name class) object))) 141 | (t (general-box-array object)))) 142 | (array 143 | (general-box-array object))))))) 144 | 145 | 146 | (defmacro define-box-array (array-boxer-name box-class lisp-type &key convertor (array-class 'mm-array)) 147 | (let ((stored-type (if (stored-cffi-type lisp-type) lisp-type 'mptr))) 148 | `(with-constant-tag-for-class (element-tag ,box-class) 149 | (with-constant-tag-for-class (array-tag ,array-class) 150 | (defun-speedy ,array-boxer-name (array) 151 | (declare (type (simple-array ,lisp-type (*)) array)) 152 | (let* ((len (length array)) 153 | (index (mtagmap-alloc (mtagmap element-tag) (* ,(mm-metaclass-len (find-class box-class)) len))) 154 | (pointer (mpointer element-tag index)) 155 | ,@(when convertor ;; have to to the conversion first as allocating can invalidate our pointers 156 | `((array (map '(vector ,stored-type) #',convertor array)))) 157 | ) 158 | ,@(when convertor 159 | `((declare (type (simple-array ,stored-type (*)) array)))) 160 | (loop for i below len do 161 | (setf (d pointer i ,stored-type) (aref array i))) 162 | (let ((barray (mtagmap-alloc (mtagmap array-tag) ,(mm-metaclass-len (find-class array-class))))) 163 | (with-pointer-slots (base length) 164 | ((mpointer array-tag barray) ,array-class) 165 | (setf base (make-mptr element-tag index) 166 | length len) 167 | (make-mptr array-tag barray))))))))) 168 | 169 | (define-box-array general-box-array mm-box t :convertor lisp-object-to-mptr) 170 | 171 | 172 | (define-boxed-numeric-types 173 | (byte (unsigned-byte 8)) 174 | double-float 175 | single-float 176 | (unsigned (unsigned-byte 64)) 177 | (signed (signed-byte 64))) 178 | 179 | 180 | (defmmclass mm-fixed-string (mm-string) 181 | ((cropped-length :type mindex :initform 0)) 182 | (walker walk-array)) 183 | 184 | -------------------------------------------------------------------------------- /src/box.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (with-constant-tag-for-class (tag mm-box) 4 | (defun-speedy unbox-box (index) 5 | (with-pointer-slots (ptr) 6 | ((mpointer tag index) mm-box) 7 | (mptr-to-lisp-object ptr)))) 8 | 9 | (with-constant-tag-for-class (element-tag mm-box) 10 | (defun-speedy make-marray (length &key 11 | (initial-element nil initial-element-p) 12 | (initial-contents nil initial-contents-p) 13 | (marray-class 'marray)) 14 | "Create a new marray (memory-mapped array) structure in the datastore, similarly to make-array." 15 | (let ((marray (make-instance marray-class 16 | :length length 17 | :base (make-mptr element-tag 18 | (mtagmap-alloc (mtagmap element-tag) 19 | (* length #.(stored-type-size 'mptr))))))) 20 | (symbol-macrolet () 21 | (cond (initial-contents-p 22 | (let ((initial-contents (mapcar #'lisp-object-to-mptr initial-contents)) 23 | (ptr (mptr-pointer (marray-base marray)))) 24 | (loop for i below length 25 | for n in initial-contents 26 | do (setf (dw ptr i) n)))) 27 | (initial-element-p 28 | (let ((initial-element (lisp-object-to-mptr initial-element)) 29 | (ptr (mptr-pointer (marray-base marray)))) 30 | (loop for i below length do 31 | (setf (dw ptr i) initial-element)))))) 32 | marray))) 33 | 34 | (defun box-cons (cons) 35 | (declare (optimize speed)) 36 | (cond ((consp (cdr cons)) 37 | (let* ((new (cons (car cons) nil)) 38 | (new-tail new) 39 | (len 2)) 40 | (declare (type fixnum len) (dynamic-extent new)) 41 | (loop for x = (cdr cons) then (cdr x) 42 | while (consp x) 43 | do (setf new-tail (setf (cdr new-tail) (cons (car x) nil))) 44 | (incf len) 45 | finally (setf (cdr new-tail) (cons x nil))) 46 | (ptr (make-marray len :initial-contents new :marray-class 'mm-array-as-list))) 47 | ) 48 | (t 49 | (ptr (make-instance 'mm-cons :car (car cons) :cdr (cdr cons)))))) 50 | 51 | (with-constant-tag-for-class (tag mm-cons) 52 | (check-class-slot-layout mm-cons) 53 | 54 | (defun unbox-cons (index) 55 | (with-pointer-slots (a b) 56 | ((mpointer tag index) mm-cons) 57 | (cons (mptr-to-lisp-object a) (mptr-to-lisp-object b))))) 58 | 59 | (with-constant-tag-for-class (tag mm-array-as-list) 60 | (defun unbox-array-as-list (index) 61 | (with-pointer-slots (base length) 62 | ((mpointer tag index) mm-array-as-list) 63 | (let ((base base) 64 | (length length)) 65 | (declare (inline elem)) 66 | (flet ((elem (n) 67 | (mptr-to-lisp-object (dw (mptr-pointer base) n)))) 68 | (let* 69 | ((cons (cons (elem 0) nil)) 70 | (tail cons)) 71 | (loop for i from 1 below (1- length) 72 | do (setf tail (setf (cdr tail) (cons (elem i) nil))) 73 | finally (setf (cdr tail) (elem (1- length)))) 74 | cons)))))) 75 | 76 | (defmacro prop-for-mm-symbol (sym) 77 | `(get ,sym 'mm-symbol)) 78 | 79 | (defvar *stored-symbols* nil) 80 | 81 | (with-constant-tag-for-class (tag mm-symbol) 82 | (check-class-slot-layout mm-symbol) 83 | 84 | (declaim (ftype (function (symbol) (mptr)) uncached-box-symbol box-symbol)) 85 | (defun box-symbol-miss (object) 86 | (declare (type symbol object) 87 | (optimize speed)) 88 | (let* 89 | ((pkg (symbol-package object)) 90 | (mptr (ptr 91 | (make-instance 'mm-symbol 92 | :package 93 | (if pkg 94 | (package-name pkg) 95 | nil) 96 | :symbol 97 | (symbol-name object))))) 98 | (assert (not (zerop mptr))) 99 | (when pkg 100 | (push object *stored-symbols*) 101 | (setf (prop-for-mm-symbol object) mptr)) 102 | mptr)) 103 | 104 | (defun-speedy box-symbol (object) 105 | (declare (type symbol object)) 106 | (cond ((not object) 107 | (make-mptr tag 0)) 108 | (t 109 | (or (prop-for-mm-symbol object) 110 | (box-symbol-miss object))))) 111 | 112 | (defun-speedy unbox-symbol (index) 113 | (unless (zerop index) 114 | (with-pointer-slots (package-name symbol-name) 115 | ((mpointer tag index) mm-symbol) 116 | (let ((package-name (mptr-to-lisp-object package-name)) 117 | (symbol-name (mptr-to-lisp-object symbol-name))) 118 | (let ((sym 119 | (if package-name 120 | (intern symbol-name (find-package package-name)) 121 | (make-symbol symbol-name)))) 122 | (unless (prop-for-mm-symbol sym) 123 | (push sym *stored-symbols*) 124 | (setf (prop-for-mm-symbol sym) 125 | (make-mptr tag index))) 126 | sym)))))) 127 | 128 | (defun-speedy tag-general-unbox-array (tag index) 129 | (with-pointer-slots (length base) 130 | ((mpointer tag index) mm-array) 131 | (unbox-array-internal (mptr-tag base) (mptr-index base) length))) 132 | 133 | 134 | (with-constant-tag-for-class (tag mm-array) 135 | (defun unbox-array (index) 136 | (tag-general-unbox-array tag index))) 137 | 138 | (with-constant-tag-for-class (tag mm-string) 139 | (defun unbox-string (index) 140 | (cl-irregsexp.bytestrings:force-string 141 | (cl-irregsexp.bytestrings:force-byte-vector 142 | (tag-general-unbox-array tag index))))) 143 | 144 | (define-box-array internal-box-string boxed-byte (unsigned-byte 8) :array-class mm-string) 145 | 146 | (defun-speedy box-string (string) 147 | (internal-box-string (cl-irregsexp.bytestrings:force-simple-byte-vector string))) 148 | 149 | (defun-speedy walk-array (mptr func) 150 | (macrolet ((base-offset () 151 | (ash (mm-slot-offset 'mm-array 'base) +mtag-bits+))) 152 | (with-pointer-slots (length base) 153 | ((mptr-pointer mptr) mm-array) 154 | (let ((length length)) 155 | (unless (zerop length) 156 | (funcall func base (+ mptr (base-offset)) length)))))) 157 | 158 | 159 | 160 | ;;; XXXX these things are really awful and should be redone much more nicely 161 | (defmacro direct-slot-mptr (class object slot) 162 | `(with-pointer-slots (,slot) 163 | ((mm-object-pointer ,object) ,class) 164 | ,slot)) 165 | 166 | (defmacro set-direct-slot-mptr (class object slot new-value) 167 | `(with-pointer-slots (,slot) 168 | ((mm-object-pointer ,object) ,class) 169 | (setf ,slot ,new-value))) 170 | 171 | (defsetf direct-slot-mptr set-direct-slot-mptr) 172 | 173 | (defmacro direct-slot-numeric-maref (class object slot element-type index) 174 | "Access element INDEX of an array of ELEMENT-TYPE that is stored in 175 | slot SLOT of OBJECT, which is an instance of class CLASS, without 176 | instantiating the array into the memory of the host Lisp 177 | implementation." 178 | `(with-pointer-slots (base) 179 | ((mptr-pointer (direct-slot-mptr ,class ,object ,slot)) marray) 180 | (d (mptr-pointer base) ,index ,element-type))) 181 | 182 | (defmacro set-direct-slot-numeric-maref (class object slot element-type index new-value ) 183 | `(with-pointer-slots (base) 184 | ((mptr-pointer (direct-slot-mptr ,class ,object ,slot)) marray) 185 | (setf (d (mptr-pointer base) ,index ,element-type) ,new-value))) 186 | 187 | (defsetf direct-slot-numeric-maref set-direct-slot-numeric-maref) 188 | 189 | (defun-speedy meq (a b) 190 | "True iff either (eq a b) or A and B are both datastore objects 191 | representing the same object in the datastore." 192 | (or (eq a b) 193 | (and (typep a 'mm-object) (typep b 'mm-object) 194 | (= (ptr a) (ptr b))))) -------------------------------------------------------------------------------- /src/mtagmap.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defun-speedy mtagmap-byte (mtagmap index) 4 | (declare (type mindex index)) 5 | (d (mtagmap-ptr mtagmap) index)) 6 | 7 | (defun-speedy (setf mtagmap-byte) (val mtagmap index) 8 | (declare (type mindex index) (type fixnum val)) 9 | (setf (d (mtagmap-ptr mtagmap) index) (logand #xff val))) 10 | 11 | (declaim (ftype (function (mtagmap mindex) word) mtagmap-word)) 12 | (defun-speedy mtagmap-word (mtagmap windex) 13 | (declare (type mindex windex)) 14 | (d (mtagmap-ptr mtagmap) windex word)) 15 | 16 | (declaim (ftype (function (word mtagmap mindex) word) (setf mtagmap-word))) 17 | (defun-speedy (setf mtagmap-word) (val mtagmap windex) 18 | (declare (type mindex windex)) 19 | (declare (type (unsigned-byte 64) val)) 20 | (setf (d (mtagmap-ptr mtagmap) windex word) val)) 21 | 22 | (defmacro mtagmap-next (mtagmap) 23 | `(mtagmap-word ,mtagmap 0)) 24 | 25 | (defun-speedy mtagmap-first-index (mtagmap) 26 | (declare (ignore mtagmap)) 27 | +word-length+) 28 | (defun-speedy mtagmap-last-index (mtagmap) 29 | (mtagmap-next mtagmap)) 30 | (defun-speedy mtagmap-elem-pos (mtagmap index) 31 | (/ (- index (mtagmap-first-index mtagmap)) (mtagmap-elem-len mtagmap))) 32 | (defun-speedy mtagmap-elem-pos-to-index (mtagmap pos) 33 | (+ (mtagmap-first-index mtagmap) (* (mtagmap-elem-len mtagmap) pos))) 34 | 35 | (defun mtagmap-count (mtagmap) 36 | (if (zerop (mtagmap-elem-len mtagmap)) 37 | 0 38 | (/ (- (mtagmap-last-index mtagmap) (mtagmap-first-index mtagmap)) 39 | (mtagmap-elem-len mtagmap)))) 40 | 41 | (defun round-up-to-pagesize (bytes) 42 | (let ((pagesize (osicat-posix:getpagesize))) 43 | (* pagesize (max 1 (ceiling bytes pagesize))))) 44 | 45 | (defun mtagmap-finalize (m) 46 | (check-type (mtagmap-class m) mm-metaclass) 47 | 48 | (setf (mtagmap-instantiator m) 49 | (mm-metaclass-custom-function (mtagmap-class m) 'instantiator) 50 | 51 | (mtagmap-walker m) 52 | (mm-metaclass-custom-function (mtagmap-class m) 'walker) 53 | 54 | (slot-value (mtagmap-class m) 'mtagmap) m 55 | 56 | (mtagmap-elem-len m) (mm-metaclass-len (mtagmap-class m))) 57 | 58 | (check-type (mtagmap-instantiator m) function) 59 | (check-type (mtagmap-walker m) (or null function)) 60 | 61 | (when (mtagmap-closed-p m) 62 | (setf (mtagmap-layout m) (mm-metaclass-slot-layout (mtagmap-class m)))) 63 | 64 | (mtagmap-check m)) 65 | 66 | (defun mtagmap-check (m) 67 | (cond ((mtagmap-closed-p m) 68 | (assert (cffi:null-pointer-p (mtagmap-ptr m))) 69 | (assert (zerop (mtagmap-len m)))) 70 | (t 71 | (assert (not (cffi:null-pointer-p (mtagmap-ptr m)))) 72 | (assert (>= (mtagmap-next m) (mtagmap-first-index m))) 73 | (assert (>= (mtagmap-len m) (mtagmap-next m))))) 74 | 75 | (let ((class (mtagmap-class m))) 76 | (when class 77 | (check-type class mm-metaclass) 78 | (assert (layout-compatible-p (mtagmap-layout m) (mm-metaclass-slot-layout class))) 79 | #-(and) (assert (eq (mtagmap (mm-metaclass-tag class)) m)) 80 | #-(and) (assert (eq (mm-metaclass-mtagmap class) m)))) 81 | m) 82 | 83 | (defun fd-file-length (fd) 84 | (osicat-posix:stat-size (osicat-posix:fstat fd))) 85 | 86 | (defun mtagmap-file-length (mtagmap) 87 | (assert (not (mtagmap-closed-p mtagmap))) 88 | (fd-file-length (mtagmap-fd mtagmap))) 89 | 90 | (defun-speedy check-allocate-okay () 91 | (assert *mmap-may-allocate*)) 92 | 93 | (defun check-mmap-truncate-okay () 94 | (assert (not (zerop (logand osicat-posix:MAP-SHARED *mmap-sharing*)))) 95 | (check-allocate-okay)) 96 | 97 | (defun mtagmap-default-filename (mtagmap) 98 | (mm-metaclass-pathname (mtagmap-class mtagmap))) 99 | 100 | (defun mtagmap-open (mtagmap 101 | &key (file (mtagmap-default-filename mtagmap)) 102 | (min-bytes 0) 103 | (sharing *mmap-sharing*) 104 | (protection *mmap-protection*) 105 | (finalize t)) 106 | (assert (mtagmap-closed-p mtagmap)) 107 | (incf min-bytes +word-length+) 108 | (setf min-bytes (round-up-to-pagesize min-bytes)) 109 | 110 | (when finalize 111 | (mtagmap-finalize mtagmap)) 112 | (let ((fd (osicat-posix:open file (logior osicat-posix:O-CREAT osicat-posix:O-RDWR)))) 113 | (unwind-protect 114 | (let ((bytes (fd-file-length fd))) 115 | (when (> min-bytes bytes) 116 | (check-mmap-truncate-okay) 117 | (osicat-posix:ftruncate fd min-bytes) 118 | (setf bytes min-bytes)) 119 | 120 | (assert (>= bytes +word-length+)) 121 | 122 | (let ((ptr (osicat-posix:mmap 123 | (cffi:null-pointer) bytes 124 | protection 125 | sharing 126 | fd 127 | 0))) 128 | (unwind-protect 129 | (let ((new-mtagmap (make-mtagmap :fd fd 130 | :ptr ptr 131 | :len bytes))) 132 | (when (zerop (mtagmap-next new-mtagmap)) 133 | (setf (mtagmap-next new-mtagmap) +word-length+)) 134 | (mtagmap-check new-mtagmap) 135 | (setf 136 | (mtagmap-fd mtagmap) fd 137 | (mtagmap-ptr mtagmap) ptr 138 | (mtagmap-len mtagmap) bytes 139 | fd nil ptr nil)) 140 | (when ptr 141 | (osicat-posix:munmap ptr bytes))))) 142 | (when fd 143 | (osicat-posix:close fd)))) 144 | mtagmap) 145 | 146 | (defun mtagmap-resize (mtagmap new-len) 147 | (assert (not (mtagmap-closed-p mtagmap))) 148 | (check-mmap-truncate-okay) 149 | (symbol-macrolet ((len (mtagmap-len mtagmap))) 150 | (flet ((trunc () 151 | (osicat-posix:ftruncate (mtagmap-fd mtagmap) new-len)) 152 | (remap () 153 | (setf (mtagmap-ptr mtagmap) 154 | (osicat-posix:mremap (mtagmap-ptr mtagmap) len new-len osicat-posix:MREMAP-MAYMOVE) 155 | len new-len))) 156 | (let (done) 157 | (unwind-protect 158 | (progn 159 | (cond ((> len new-len) 160 | (remap) 161 | (trunc)) 162 | (t 163 | (trunc) 164 | (remap))) 165 | (setf done t)) 166 | (unless done 167 | (mtagmap-close mtagmap)))))) 168 | 169 | (mtagmap-check mtagmap)) 170 | 171 | (defun mtagmap-extend-alloc (mtagmap bytes) 172 | (check-type bytes mindex) 173 | (let ((len (mtagmap-len mtagmap))) 174 | (let ((next (mtagmap-next mtagmap)) (new-len (* 2 len))) 175 | (assert (> len 0)) 176 | (assert (>= len next)) 177 | (check-type next mindex) 178 | (mtagmap-check mtagmap) 179 | (loop while (> (+ next bytes) new-len) 180 | do (setf new-len (* 2 new-len))) 181 | (mtagmap-resize mtagmap new-len)))) 182 | 183 | (defun-speedy mtagmap-alloc (mtagmap bytes) 184 | (declare (type mindex bytes)) 185 | (check-allocate-okay) 186 | (symbol-macrolet ((len (mtagmap-len mtagmap))) 187 | (when (zerop len) 188 | (mtagmap-open mtagmap)) 189 | 190 | (let ((next (mtagmap-next mtagmap))) 191 | (declare (type mindex next)) 192 | (when (> (the mindex (+ next bytes)) (the mindex len)) 193 | (mtagmap-extend-alloc mtagmap bytes)) 194 | (setf (mtagmap-next mtagmap) (the mindex (+ next bytes))) 195 | next))) 196 | 197 | (defun mtagmap-check-read (mtagmap) 198 | (loop for i below (mtagmap-len mtagmap) 199 | summing (mtagmap-byte mtagmap i))) 200 | 201 | (defun mtagmap-check-invert (mtagmap) 202 | (loop for i below (mtagmap-len mtagmap) 203 | for c = (mtagmap-byte mtagmap i) 204 | do (setf (mtagmap-byte mtagmap i) (lognot c)))) 205 | 206 | (defun mtagmap-check-write (mtagmap) 207 | (mtagmap-check-invert mtagmap) 208 | (mtagmap-check-invert mtagmap)) 209 | 210 | (defun-speedy mtagmap-closed-p (mtagmap) 211 | (= -1 (mtagmap-fd mtagmap))) 212 | 213 | (defun mtagmap-close (mtagmap) 214 | (check-type mtagmap mtagmap) 215 | (let ((fd (mtagmap-fd mtagmap)) 216 | (ptr (mtagmap-ptr mtagmap)) 217 | (len (mtagmap-len mtagmap))) 218 | 219 | (mtagmap-detach mtagmap) 220 | 221 | (unwind-protect 222 | (unless (cffi:null-pointer-p ptr) 223 | (osicat-posix:munmap ptr len)) 224 | (unless (minusp fd) 225 | (osicat-posix:close fd)))) 226 | mtagmap) 227 | 228 | (defun mtagmap-detach (mtagmap) 229 | (setf (mtagmap-fd mtagmap) -1 230 | (mtagmap-len mtagmap) 0 231 | (mtagmap-ptr mtagmap) (cffi:null-pointer))) 232 | 233 | 234 | (defun mtagmap-shrink (mtagmap) 235 | (assert (not (mtagmap-closed-p mtagmap))) 236 | (mtagmap-check mtagmap) 237 | (let* ((next (mtagmap-next mtagmap)) 238 | (bytes (round-up-to-pagesize next)) (file-len (mtagmap-file-length mtagmap))) 239 | (assert (>= file-len bytes)) 240 | (unless (= next bytes) 241 | (osicat-posix:memset (cffi:inc-pointer (mtagmap-ptr mtagmap) next) 242 | 0 (- bytes next))) 243 | (unless (= bytes file-len) 244 | (assert (>= bytes next)) 245 | (mtagmap-resize mtagmap bytes)))) 246 | 247 | (defun mtagmap-schema (mtagmap) 248 | (let ((class (mtagmap-class mtagmap))) 249 | (mm-metaclass-schema class))) 250 | 251 | 252 | (defmethod print-object ((m mtagmap) stream) 253 | (print-unreadable-object (m stream :type t) 254 | (unless (mtagmap-closed-p m) 255 | (format stream "~A (~D): ~D objects, ~D bytes, ~D bytes mapped (~A)" 256 | (class-name (mtagmap-class m)) 257 | (force-tag m) 258 | (mtagmap-count m) 259 | (mtagmap-next m) 260 | (mtagmap-len m) 261 | (mtagmap-default-filename m))))) 262 | 263 | -------------------------------------------------------------------------------- /src/transaction.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defun schema () 4 | (loop for m across *mtagmaps* 5 | when m 6 | collect 7 | (mtagmap-schema m))) 8 | 9 | (defun single-expression-file (filename) 10 | (with-open-file (file filename :if-does-not-exist nil) 11 | (when file 12 | (with-standard-io-syntax 13 | (let (*read-eval*) 14 | (read file)))))) 15 | 16 | (defun (setf single-expression-file) (value filename) 17 | (with-open-file (file filename :direction :output :if-does-not-exist :create :if-exists :supersede) 18 | (with-standard-io-syntax 19 | (prin1 value file) 20 | (terpri file)))) 21 | 22 | 23 | (defun write-schema (filename) 24 | (setf (single-expression-file filename) (schema))) 25 | 26 | (defun read-schema (filename) 27 | (assert (probe-file filename)) 28 | (single-expression-file filename)) 29 | 30 | (defun pathname-to-special-file (dirname filename) 31 | (merge-pathnames (make-pathname :name filename :type nil) dirname)) 32 | 33 | (defun pathname-to-schema (dirname) 34 | (pathname-to-special-file dirname "schema")) 35 | 36 | (defmacro dir-version (pathname) 37 | `(single-expression-file (pathname-to-special-file ,pathname "version"))) 38 | (defmacro dir-schema (pathname) 39 | `(single-expression-file (pathname-to-schema ,pathname))) 40 | (defmacro dir-replacement-target (pathname) 41 | `(single-expression-file (pathname-to-special-file ,pathname "replacement-target"))) 42 | 43 | (defun schema-superset-p (stored-schema our-supported-schema) 44 | (loop 45 | for (aname atag alayout) in stored-schema 46 | always 47 | (progn 48 | (assert 49 | (loop for (bname btag blayout) in our-supported-schema 50 | thereis (when (= atag btag) 51 | (assert (layout-compatible-p alayout blayout) 52 | (aname bname atag btag alayout blayout) 53 | "Stored class ~A (~A) has a different layout from defined class ~A: ~A" 54 | aname atag bname alayout 55 | ) 56 | t)) 57 | (aname atag) 58 | "No support for stored class ~A (~A)" aname atag) 59 | t))) 60 | 61 | 62 | (defun copy-all-mmaps (from-dir to-dir) 63 | (let (version) 64 | (tagbody 65 | restart 66 | (setf version (dir-version from-dir)) 67 | (assert version (from-dir to-dir) "Trying to copy from a datastore that has no version") 68 | (when (probe-file to-dir) 69 | (mapc #'delete-file (osicat:list-directory to-dir)) 70 | (assert (not (osicat:list-directory to-dir)))) 71 | (ensure-directories-exist to-dir) 72 | (assert (probe-file to-dir)) 73 | (let ((files 74 | (osicat:list-directory from-dir))) 75 | (loop for f in files do 76 | (alexandria:copy-file f (merge-pathnames (make-pathname :type (pathname-type f) :name (pathname-name f)) to-dir) :element-type '(unsigned-byte 8)))) 77 | (unless (equalp version (dir-version from-dir)) 78 | (go restart))))) 79 | 80 | (defun replace-all-mmaps (from-dir to-dir version) 81 | (setf (dir-replacement-target from-dir) to-dir) 82 | (let ((tmpdir (tmpdir)) done) 83 | (osicat-posix:rename (translate-logical-pathname to-dir) (translate-logical-pathname tmpdir)) 84 | (unwind-protect 85 | (progn 86 | (assert (version-equalp version (dir-version tmpdir)) () 87 | "Database updated to a new version (~A) while attempting to replace version ~A" 88 | (dir-version tmpdir) version) 89 | (osicat-posix:rename (translate-logical-pathname from-dir) (translate-logical-pathname to-dir)) 90 | (setf done t)) 91 | (unless done 92 | (osicat-posix:rename (translate-logical-pathname tmpdir) (translate-logical-pathname to-dir)) 93 | (setf (dir-replacement-target from-dir) nil))) 94 | (osicat:delete-directory-and-files tmpdir))) 95 | 96 | (defun str (&rest args) 97 | (with-standard-io-syntax 98 | (let (*print-readably* *print-escape*) 99 | (format nil "~{~A~}" args)))) 100 | 101 | 102 | 103 | (defun tmpdir () 104 | (ensure-directories-exist (merge-pathnames "tmp/" *mmap-base-pathname*)) 105 | (loop 106 | for counter = (random most-positive-fixnum) 107 | for name = (str "tmp/" (short-site-name) "-" (osicat-posix:getpid) "-" (osicat-posix:gettimeofday) "-" counter "/") 108 | for path = (merge-pathnames name *mmap-base-pathname*) 109 | do 110 | (when (nth-value 1 (ensure-directories-exist path)) 111 | (return path)))) 112 | 113 | (defun maindir () 114 | (merge-pathnames "main/" *mmap-base-pathname*)) 115 | 116 | (defmacro with-transaction ((&key message on-restart) &body body) 117 | "Copy the datastore to a temporary directory; open the datastore 118 | from this temporary directory and execute BODY. If, at the end of 119 | BODY, the main datastore has had another transaction on it, then run 120 | ON-RESTART and restart the procedure. Otherwise atomically replace 121 | the main datastore. 122 | 123 | Should be safe, as it uses lockfiles. The initial copy will retry if a 124 | transaction occurs while it is being performed. 125 | 126 | It is slow copying the datastore. (A better copy than 127 | alexandria:copy-file should be easy to implement.) 128 | 129 | The proposed reflink(2) system call would make a radically more 130 | efficient implementation possible. 131 | " 132 | (alexandria:with-unique-names (restart transaction) 133 | `(flet ((,transaction () 134 | ,@body) 135 | (,restart () 136 | ,on-restart)) 137 | (transact 138 | :message ,message 139 | :body #',transaction 140 | :on-restart #',restart)))) 141 | 142 | (defun version-equalp (a b) 143 | (equalp a b)) 144 | 145 | (defun check-schema (&optional (dir *mmap-pathname-defaults*)) 146 | (let ((schema (dir-schema dir))) 147 | (assert (schema-superset-p schema (schema)) (schema) "Schema in ~A in not compatible" (maindir)))) 148 | 149 | (defun build-version (&optional (counter 0)) 150 | `(,counter 151 | ,(osicat-posix:getpid) 152 | ,@(multiple-value-list (osicat-posix:gettimeofday)) 153 | ,(random most-positive-fixnum))) 154 | 155 | (defvar *transaction-copy-fail-restart-sleep* 10) 156 | 157 | (defun transact (&key body on-restart message) 158 | (declare (dynamic-extent body on-restart message) 159 | (optimize safety debug)) 160 | (close-all-mmaps) 161 | (assert (not *stored-symbols*)) 162 | (let ((tmpdir (tmpdir)) *stored-symbols* (*mmap-may-allocate* t)) 163 | (unwind-protect 164 | (tagbody restart 165 | (close-all-mmaps) 166 | (handler-bind ((error 167 | (lambda (err) 168 | (warn "Copying mmap files from directory ~A to ~A as part of transaction ~A failed: ~A" (maindir) tmpdir message err) 169 | (sleep (random *transaction-copy-fail-restart-sleep*))))) 170 | (copy-all-mmaps (maindir) tmpdir)) 171 | (let ((*mmap-pathname-defaults* tmpdir)) 172 | (check-schema) 173 | (open-all-mmaps) 174 | (return-from transact 175 | (multiple-value-prog1 176 | (funcall body) 177 | (let ((version (dir-version tmpdir))) 178 | (setf (dir-version tmpdir) (build-version (1+ (first version)))) 179 | 180 | (handler-case 181 | (progn 182 | (replace-all-mmaps tmpdir (maindir) version) 183 | (setf tmpdir nil)) 184 | (error (err) 185 | (warn "Restarting manardb transaction ~A: ~A" message err) 186 | (funcall on-restart) 187 | (go restart)))))))) 188 | (when tmpdir 189 | (ignore-errors 190 | (osicat:delete-directory-and-files tmpdir))) 191 | (close-all-mmaps)))) 192 | 193 | (defun clean-mmap-dir (&optional (dir *mmap-base-pathname*)) 194 | "Unsafely remove all temporary directories from failed transactions 195 | that were not cleaned up because the transactor crashed. 196 | 197 | [Not tested or used.] " 198 | (osicat:delete-directory-and-files (merge-pathnames "tmp/" dir))) 199 | 200 | (defun use-mmap-dir (dir &key (if-does-not-exist :create)) 201 | "Set the memory mapped datastore to map files inside DIR." 202 | (close-all-mmaps) 203 | (let ((maindir 204 | (let ((*mmap-base-pathname* dir)) 205 | (maindir)))) 206 | (cond ((probe-file (pathname-to-schema maindir)) 207 | (check-schema maindir) 208 | (setf *mmap-base-pathname* dir 209 | *mmap-pathname-defaults* maindir) 210 | (open-all-mmaps) 211 | dir) 212 | (t 213 | (ecase if-does-not-exist 214 | (:create 215 | (ensure-directories-exist maindir) 216 | (setf (dir-schema maindir) (schema)) 217 | (setf (dir-version maindir) (build-version)) 218 | (use-mmap-dir dir :if-does-not-exist :error)) 219 | (:error 220 | (error "Directory ~A does not contain a memory mapped datastore." dir)) 221 | ((nil))))))) 222 | 223 | (defun instantiate-default-mm-object (mptr) 224 | (funcall (slot-value (mtagmap-class (mtagmap (mptr-tag mptr))) 'default-instantiator) (mptr-index mptr))) 225 | 226 | (defmacro with-object-cache ((name &key (test ''equal)) &body body) 227 | "Lexically bind a function with NAME for BODY that, when passed an 228 | object, will either instantiate a new memory mapped object for it, or 229 | if the object is equal under TEST to a previous object passed to NAME, 230 | will return the same memory mapped object." 231 | (alexandria:with-unique-names (cache string) 232 | `(let ((,cache (make-hash-table :test ,test))) 233 | (flet ((,name (,string) 234 | (or (gethash ,string ,cache) 235 | (setf (gethash ,string ,cache) (instantiate-default-mm-object (lisp-object-to-mptr ,string)))))) 236 | ,@body)))) 237 | 238 | -------------------------------------------------------------------------------- /src/class.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:manardb) 2 | 3 | (defmacro define-lisp-object-to-mptr () 4 | `(defun-speedy lisp-object-to-mptr (obj) 5 | "Stores the object OBJ in the memory mapped datastore and returns the mptr referring to it" 6 | (typecase obj 7 | (mm-object (ptr obj)) 8 | (t (box-object obj))))) 9 | 10 | (define-lisp-object-to-mptr) ;; should be redefined after box-object is 11 | ;; defined, which needs many types to be 12 | ;; defined, in a circular fashion 13 | 14 | (defmacro with-constant-tag-for-class ((tagsym classname) &body body) 15 | (check-type tagsym symbol) 16 | (check-type classname symbol) 17 | (let ((class (find-class classname))) 18 | (ensure-finalize-inheritance class) 19 | (let ((tag (mm-metaclass-tag class))) 20 | (check-type tag mtag) 21 | 22 | `(progn 23 | (eval-when (:load-toplevel :compile-toplevel :execute) 24 | (assert (= ,tag ,(mm-metaclass-tag (find-class classname))) 25 | () "The tag for classname ~A has changed; compiled code may be invalid" ',classname)) 26 | (symbol-macrolet ((,tagsym ,tag)) 27 | ,@body))))) 28 | 29 | (defun-speedy force-mptr (obj) 30 | (etypecase obj 31 | (mptr obj) 32 | (mm-object (ptr obj)))) 33 | 34 | (defun-speedy mptr (obj) 35 | "If OBJ is already an integer, return it. If it is a memory mapped object, return the MPTR corresponding to it. 36 | Otherwise, raise an error." 37 | (force-mptr obj)) 38 | 39 | (defun-speedy force-tag (obj) 40 | (etypecase obj 41 | (mtag obj) 42 | (mtagmap (mm-metaclass-tag (mtagmap-class obj))) 43 | (symbol (mm-metaclass-tag (find-class obj))) 44 | (mm-metaclass (mm-metaclass-tag obj)) 45 | (mm-object (mptr-tag (ptr obj))) 46 | (mptr (mptr-tag obj)))) 47 | 48 | (defmethod finalize-inheritance :after ((class mm-metaclass)) 49 | (setup-mtagmap-for-metaclass class) 50 | (setup-default-metaclass-functions class) 51 | class) 52 | 53 | (defun metaclass-default-walker-form (class) 54 | (let ((offsets (loop for slot in (class-slots class) 55 | when (slot-definition-mmap-pointer-p slot) 56 | collect (slot-value slot 'offset)))) 57 | (when offsets 58 | `(lambda (mptr walker-func) 59 | (declare (type mm-walk-func walker-func)) 60 | ,@(loop for offset in offsets collect 61 | `(let ((p (+ mptr ,(ash offset +mtag-bits+)))) 62 | (funcall walker-func (dw (mptr-pointer p)) p 1))))))) 63 | 64 | (defun metaclass-default-instantiator-form (class) 65 | `(lambda (index) 66 | (declare (optimize speed) (type mindex index)) 67 | (let ((instance (allocate-instance ,class))) 68 | (setf (%ptr instance) (make-mptr ,(mm-metaclass-tag class) index)) 69 | ,@(loop for s in (class-slots class) 70 | unless (slot-definition-memory-mapped s) 71 | when (slot-definition-initfunction s) 72 | collect `(setf (slot-value instance ',(slot-definition-name s)) (funcall ,(slot-definition-initfunction s)))) 73 | instance))) 74 | 75 | (defun slot-definition-initform-mm-zerop (slotd) 76 | (cond ((not (slot-definition-initfunction slotd))) 77 | ((constantp (slot-definition-initform slotd)) 78 | (multiple-value-bind (val failed) 79 | (ignore-errors (eval (slot-definition-initform slotd))) 80 | (unless failed 81 | (cond ((slot-definition-mm-boxing slotd) 82 | (eq nil val)) 83 | ((slot-definition-mm-write-convertor slotd) 84 | nil) 85 | ((numberp val) 86 | (= val 0)))))))) 87 | 88 | (defun metaclass-allocator-form (class) 89 | "Returns a lambda-form that allocates a new object, and sets all memory mapped slots to their default values unless they are going to be overridden by the initargs" 90 | `(lambda (instance initargs) 91 | (declare (dynamic-extent initargs) (optimize speed) (ignorable initargs)) 92 | (setf (%ptr instance) (make-mptr ,(mm-metaclass-tag class) 93 | (mtagmap-alloc (mtagmap ,(mm-metaclass-tag class)) ,(mm-metaclass-len class)))) 94 | ,@(let* ((slots (loop for s in (class-slots class) 95 | when 96 | (and 97 | (slot-definition-memory-mapped s) 98 | (not (slot-definition-initform-mm-zerop s)) 99 | (slot-definition-initargs s)) 100 | collect s)) 101 | (gensyms (loop for s in slots collect (gensym (princ-to-string (slot-definition-name s))))) 102 | (params (remove-duplicates (loop for s in slots appending (slot-definition-initargs s)))) 103 | (cases (loop for p in params collect 104 | `(,p ,@(loop for s in slots 105 | for g in gensyms 106 | when (member p (slot-definition-initargs s)) 107 | collect `(setf ,g t)))))) 108 | (when slots 109 | `((let ,gensyms 110 | (loop for arg in initargs by #'cddr 111 | do (case arg 112 | ,@cases)) 113 | ,@(loop for s in slots 114 | for g in gensyms 115 | collect 116 | `(unless ,g 117 | (funcall (the mm-slot-definition-writer ,(slot-definition-writer-function s)) 118 | (funcall ,(slot-definition-initfunction s)) instance))))))) 119 | instance)) 120 | 121 | (defun setup-default-metaclass-functions (class) 122 | (loop for slot in (class-slots class) do 123 | (when (slot-definition-memory-mapped slot) 124 | (mm-effective-slot-definition-setup slot))) 125 | 126 | (flet ((maybe-compile (form) 127 | (when form 128 | (compile nil form)))) 129 | (with-slots (default-walker default-instantiator allocator) 130 | class 131 | (setf default-walker 132 | (maybe-compile (metaclass-default-walker-form class)) 133 | 134 | default-instantiator 135 | (compile nil 136 | (metaclass-default-instantiator-form class)) 137 | 138 | allocator 139 | (compile nil 140 | (metaclass-allocator-form class)))))) 141 | 142 | (defun mm-metaclass-filename (class) 143 | (assert (class-name class) (class) "Cannot mmap anonymous classes.") ; is possible but not implemented or sensible(?) 144 | (check-type (class-name class) symbol) 145 | 146 | (make-pathname 147 | :name (flet ((clean (str) 148 | (remove-if-not #'alphanumericp str))) 149 | (let ((name (class-name class))) 150 | (concatenate 'string (clean (package-name (symbol-package name))) 151 | "-" (clean (symbol-name name))))))) 152 | 153 | (defun mm-metaclass-pathname (class) 154 | (merge-pathnames 155 | (mm-metaclass-filename class) 156 | *mmap-pathname-defaults*)) 157 | 158 | (declaim (ftype (function (mm-metaclass &optional mindex) mptr) mm-metaclass-alloc)) 159 | (defun-speedy mm-metaclass-alloc (class &optional (amount 1)) 160 | (declare (type mindex amount)) 161 | (make-mptr (mm-metaclass-tag class) 162 | (mtagmap-alloc (mm-metaclass-mtagmap class) 163 | (* amount (mm-metaclass-len class))))) 164 | 165 | (defun mm-metaclass-custom-function (class slot 166 | &optional (default-slot 167 | (let ((*package* #.*package*)) 168 | (alexandria:symbolicate 'default- slot)))) 169 | (typecase (slot-value class slot) 170 | (null 171 | (slot-value class default-slot)) 172 | (list (let ((f (first (slot-value class slot)))) 173 | (or (ignore-errors (alexandria:ensure-function f)) f))))) 174 | 175 | (defun setup-mtagmap-for-metaclass (class) 176 | (when (zerop (mm-metaclass-len class)) 177 | (warn "Pointlessly memory mapping a class with zero length objects: ~A" class)) 178 | (with-slots (tag mtagmap) 179 | class 180 | (unless tag 181 | (let ((existing 182 | (loop for m across *mtagmaps* 183 | for a from 0 184 | thereis 185 | (when (and m (equalp (class-name class) (class-name (mtagmap-class m)))) 186 | a)))) 187 | (setf tag (or existing 188 | (next-available-tag))) 189 | 190 | (assert tag (*mtagmaps*) "No more tags available (too many types defined in the memory mapped datastore)."))) 191 | 192 | (unless (mtagmap tag) 193 | (setf (mtagmap tag) 194 | (make-mtagmap)) 195 | (setf (mtagmap-layout (mtagmap tag)) (mm-metaclass-slot-layout class))) 196 | 197 | (assert-class-slot-layout class (mtagmap-layout (mtagmap tag)) :finalize nil) 198 | 199 | (setf mtagmap (mtagmap tag) 200 | (mtagmap-class mtagmap) class)) 201 | 202 | class) 203 | 204 | (defun-speedy mm-metaclass-initialize-alloc (class instance initargs) 205 | (declare (dynamic-extent initargs) (type mm-metaclass class)) 206 | (funcall (the function (slot-value class 'allocator)) 207 | instance initargs)) 208 | 209 | (defmethod initialize-instance :before ((instance mm-object) &rest initargs) 210 | (declare (optimize speed) (dynamic-extent initargs)) 211 | (let ((class (class-of instance))) 212 | (mm-metaclass-initialize-alloc class instance initargs))) 213 | 214 | (defun always-true (&rest args) 215 | (declare (ignore args)) 216 | t) 217 | 218 | (defun slot-definition-mm-type (slotd) 219 | (if (stored-cffi-type (slot-definition-type slotd)) 220 | (slot-definition-type slotd) 221 | 'mm-box)) 222 | 223 | (defun slot-definition-mm-boxing (slotd) 224 | (eq (slot-definition-mm-type slotd) 'mm-box)) 225 | 226 | (defun slot-definition-mm-read-convertor (slotd) 227 | (cond ((slot-definition-mm-boxing slotd) 228 | 'mptr-to-lisp-object))) 229 | 230 | (defun slot-definition-mm-write-convertor (slotd) 231 | (cond ((slot-definition-mm-boxing slotd) 232 | 'lisp-object-to-mptr))) 233 | 234 | (defun slot-definition-mm-read-form (slotd raw-access-form) 235 | (let ((c (slot-definition-mm-read-convertor slotd))) 236 | (if c `(,c ,raw-access-form) 237 | raw-access-form))) 238 | 239 | (defun slot-definition-mm-write-form (slotd raw-write-form new-val-sym) 240 | (let ((c (slot-definition-mm-write-convertor slotd))) 241 | (cond (c 242 | `(let ((,new-val-sym (,c ,new-val-sym))) ;; note that (lisp-object-to-mptr new-val) can invalidate the current pointer 243 | ,raw-write-form)) 244 | (t 245 | raw-write-form)))) 246 | 247 | (defun mm-effective-slot-definition-lambda-forms (slotd) 248 | (let* ( 249 | (offset (slot-value slotd 'offset)) 250 | (type 251 | (slot-definition-mm-type slotd)) 252 | (raw-access-form 253 | `(d ,(if (zerop offset) `(mm-object-pointer object) 254 | `(cffi:inc-pointer (mm-object-pointer object) ,offset)) 0 255 | ,(if (eq type 'mm-box) 256 | 'mptr 257 | type))) 258 | (read-form 259 | (slot-definition-mm-read-form slotd raw-access-form)) 260 | (declare-form 261 | `(declare (optimize speed)))) 262 | (values 263 | `(lambda (object) 264 | ,declare-form 265 | ,read-form) 266 | `(lambda (new-val object) 267 | ,declare-form 268 | ,(slot-definition-mm-write-form slotd `(setf ,raw-access-form new-val) 'new-val) 269 | new-val)))) 270 | 271 | (defun mm-effective-slot-definition-setup (slotd) 272 | (with-slots (offset) 273 | slotd 274 | (check-type offset mindex) 275 | 276 | (multiple-value-bind (reader writer) 277 | (mm-effective-slot-definition-lambda-forms slotd) 278 | (setf (slot-definition-reader-function slotd) 279 | (compile nil 280 | reader) 281 | (slot-definition-writer-function slotd) 282 | (compile nil 283 | writer) 284 | #- (and) 285 | (slot-definition-boundp-function #'always-true))) 286 | (values))) 287 | 288 | 289 | (defun mm-slot-offset (class slotname) 290 | (let* ((class (force-class class)) 291 | (slotd (find slotname (class-slots class) :key #'slot-definition-name))) 292 | (assert slotd) 293 | (assert (slot-definition-memory-mapped slotd)) 294 | (slot-value slotd 'offset))) 295 | 296 | (defmacro with-raw-slot ((slotname classname &key (accessor-name slotname)) 297 | object-pointer &body body &environment env) 298 | (let ((class (find-class classname t env))) 299 | (ensure-finalize-inheritance class) 300 | (let* ( 301 | (slotd (or (find slotname (class-slots class) :key #'slot-definition-name) 302 | (error "Class ~A has no slot ~A" classname slotname))) 303 | (offset (slot-value slotd 'offset)) 304 | (slot-type (slot-definition-type slotd)) 305 | (d-slot-type (if (stored-cffi-type slot-type) slot-type 'mptr))) 306 | (alexandria:with-gensyms (apointer) 307 | `(let ((,apointer (cffi:inc-pointer ,object-pointer ,offset))) 308 | (declare (type machine-pointer ,apointer)) 309 | (symbol-macrolet ((,accessor-name 310 | (d ,apointer 0 ,d-slot-type))) 311 | ,@body)))))) 312 | 313 | (defmacro with-pointer-slots (slotnames (object-pointer classname) &body body) 314 | (alexandria:once-only (object-pointer) 315 | (labels ((r (slotnames) 316 | (if slotnames 317 | `(with-raw-slot (,(first slotnames) ,classname) 318 | ,object-pointer 319 | ,(r (rest slotnames))) 320 | `(locally ,@body)))) 321 | (r slotnames)))) 322 | 323 | (defun mm-metaclass-slot-layout (class) 324 | (ensure-finalize-inheritance class) 325 | (let ((slots (class-slots class))) 326 | (loop for s in slots 327 | when (slot-definition-memory-mapped s) 328 | collect `(,(slot-definition-name s) ,(slot-value s 'offset) ,(stored-type-size (slot-definition-type s)) 329 | ,@(when (slot-definition-mmap-pointer-p s) `(:mmap-pointer t)))))) 330 | 331 | (defun layout-compatible-p (a b) 332 | (flet ((sort-layout (layout) 333 | (sort (copy-list layout) #'> :key #'second))) 334 | (equalp 335 | (mapcar #'rest (sort-layout a)) 336 | (mapcar #'rest (sort-layout b))))) 337 | 338 | 339 | (defun ensure-finalize-inheritance (class) 340 | (let ((class (force-class class))) 341 | (unless (class-finalized-p class) 342 | (finalize-inheritance class)))) 343 | 344 | (defun assert-class-slot-layout (class layout &key (finalize t)) 345 | (when finalize 346 | (ensure-finalize-inheritance class)) 347 | (cassert (layout-compatible-p layout (mm-metaclass-slot-layout class)) () 348 | "Layout for class ~A has changed from ~A" class layout)) 349 | 350 | (defmacro check-class-slot-layout (classname &optional (layout (mm-metaclass-slot-layout (find-class classname)))) 351 | `(assert-class-slot-layout (find-class ',classname) ',layout)) 352 | 353 | (defmacro defmmclass (name direct-supers direct-slots &rest options) 354 | "Define a memory mapped class, like defclass. 355 | 356 | Automatically adds :metaclass mm-metaclass to options, if it is not 357 | present, finalizes the class immediately, and puts in an assertion 358 | that the class layout in the loaded datastore is compatible." 359 | `(progn 360 | (eval-when (:load-toplevel :execute :compile-toplevel) 361 | (defclass ,name ,direct-supers ,direct-slots 362 | ,@(if (assoc :metaclass options) 363 | options 364 | `((:metaclass mm-metaclass) ,@options))) 365 | (ensure-finalize-inheritance ',name)) 366 | 367 | (eval-when (:execute) 368 | (check-class-slot-layout ,name)) 369 | 370 | (find-class ',name))) 371 | 372 | 373 | 374 | (defun tree-to-atoms-or-strings (tree) 375 | (typecase tree 376 | (integer tree) 377 | (null tree) 378 | (list 379 | (loop for i in tree collect (tree-to-atoms-or-strings i))) 380 | (t 381 | (princ-to-string tree)))) 382 | 383 | (defun mm-metaclass-schema (class) 384 | (with-standard-io-syntax 385 | (tree-to-atoms-or-strings 386 | (list 387 | (mm-metaclass-filename class) 388 | (mm-metaclass-tag class) 389 | (mm-metaclass-slot-layout class))))) 390 | 391 | 392 | (defmacro with-cached-slots (slots instance &body body) 393 | "Like with-slots, but each slot is only read from the datastore once. 394 | It is written to the datastore immediately after every write, and the 395 | cached version becomes the value written (not the value as serialised 396 | and deserialised). 397 | 398 | This is an optimization to stop repeatedly instantiating slots into 399 | Lisp memory. Note that it also useful because it preserves 400 | non-persistent slots of objects stored in SLOTS of INSTANCE over their 401 | lexical scope." 402 | (alexandria:with-unique-names (new-val) 403 | (let* ((tmps (loop for s in slots do (check-type s symbol) collect (gensym (symbol-name s)))) 404 | (funcs (loop for tmp in tmps collect tmp collect `(setf ,tmp))) 405 | (ffuncs (loop for f in funcs collect `(function ,f)))) 406 | (alexandria:once-only (instance) 407 | `(let ,(loop for tmp in tmps 408 | for s in slots 409 | collect `(,tmp (slot-value ,instance ',s)) 410 | ) 411 | (flet ,(loop for tmp in tmps for s in slots 412 | collect 413 | `(,tmp () ,tmp) 414 | collect 415 | `((setf ,tmp) (,new-val) 416 | (setf ,tmp (setf (slot-value ,instance ',s) ,new-val)))) 417 | (declare (inline ,@funcs) 418 | (ignorable ,@ffuncs) 419 | (dynamic-extent ,@ffuncs)) 420 | (symbol-macrolet 421 | ,(loop for s in slots for tmp in tmps collect 422 | `(,s (,tmp))) 423 | ,@body))))))) 424 | 425 | (defmethod print-object ((object mm-object) stream) 426 | (print-unreadable-object (object stream :type t) 427 | (let ((ptr (ptr object))) 428 | (format stream " M@~D(~D:~D)" ptr (mptr-tag ptr) (mptr-index ptr))))) 429 | -------------------------------------------------------------------------------- /doc/api.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | MANARDB - API reference 7 | 25 | 26 | 27 | 28 | 29 |

MANARDB - API reference

30 | 31 |

This is the API reference. There is also an introduction to this library.

32 | 33 |
34 |
 

Abstract

35 | 36 |

The code is released under the Lisp Lesser GPL.

37 | 38 |

39 | Download shortcut: manardb.tar.gz.

40 | 41 |
42 | 43 |
 

Contents

44 |
    45 |
  1. Download 46 |
  2. The MANARDB dictionary 47 |
      48 |
    1. doclass 49 |
    2. rewrite-gc 50 |
    3. with-transaction 51 |
    4. with-cached-slots 52 |
    5. gc 53 |
    6. lisp-object-to-mptr-impl 54 |
    7. with-object-cache 55 |
    8. defmmclass 56 |
    9. direct-slot-numeric-maref 57 |
    10. make-mm-fixed-string 58 |
    11. mm-fixed-string-value 59 |
    12. clean-mmap-dir 60 |
    13. mptr 61 |
    14. close-all-mmaps 62 |
    15. meq 63 |
    16. mptr-to-lisp-object 64 |
    17. *mmap-may-allocate* 65 |
    18. dosubclasses 66 |
    19. count-all-instances 67 |
    20. make-marray 68 |
    21. lisp-object-to-mptr 69 |
    22. list-to-marray 70 |
    23. marray-to-list 71 |
    24. *mmap-base-pathname* 72 |
    25. use-mmap-dir 73 |
    26. marray 74 |
    27. retrieve-all-instances 75 |
    28. mm-object 76 |
    29. marray-ref 77 |
    30. wipe-all-mmaps 78 |
    31. mm-metaclass 79 |
    32. print-all-mmaps 80 |
    33. open-all-mmaps 81 |
    34. marray-length 82 |
    83 |
  3. Acknowledgements 84 |
85 | 86 |
 

Download

87 | 88 |

MANARDB together with this documentation can be downloaded from manardb.tar.gz.

89 | 90 |
 

The MANARDB dictionary

91 | 92 | 93 | 94 | 95 | 96 |


[Macro]
doclass (var class-specifier &key fresh-instances reverse) declaration* statement* => result 97 | 

 98 | For each object in the memory-mapped datastore of class denoted by
 99 | CLASS-SPECIFIER (evaluated), lexically bind VAR to a Lisp
100 | object representing that object around BODY and execute it.
101 | 
102 | FRESH-INSTANCES (generalized boolean, not evaluated), if true means
103 | means that a fresh Lisp object will be created for each datastore
104 | object -- by default a single Lisp object is instantiated and it is
105 | modified destructively to point to each object in the class.
106 | 
107 | REVERSE (generalized boolean, not evaluated), if true means that
108 | objects will be iterated in order from newest to oldest. If false (default),
109 | they are iterated from oldest to newest.
110 | 
111 | Also see dosubclasses.
112 | 
113 | 
114 |
115 | 116 | 117 | 118 | 119 | 120 | 121 |


[Function]
rewrite-gc root-objects-sequence &key progress verbose shared-classes base-shared-classes => result 122 | 

123 | An alternative, sloppier GC algorithm with a space complexity that is not proportional to the size of the datastore.
124 | 
125 | Creates a new datastore by copying each element of
126 | ROOT-OBJECTS-SEQUENCE as if it were entirely self contained except for
127 | any shared objects in SHARED-CLASSES.
128 | 
129 | Cannot handle pointers to the inside of arrays at all; they will be
130 | recreated pointing to fresh objects. Note that arrays pointing to
131 | complex objects (or any user defined classes) are stored as arrays of
132 | mptrs, with each mptr pointing to the actual object; it is fine to
133 | have pointers to these objects, because the actual objects are not
134 | stored in the array.
135 | 
136 |
137 | 138 | 139 | 140 | 141 | 142 | 143 |


[Macro]
with-transaction (&key message on-restart) declaration* statement* => result 144 | 

145 | Copy the datastore to a temporary directory; open the datastore
146 | from this temporary directory and execute BODY. If, at the end of
147 | BODY, the main datastore has had another transaction on it, then run
148 | ON-RESTART and restart the procedure. Otherwise atomically replace
149 | the main datastore.
150 | 
151 | Should be safe, as it uses lockfiles. The initial copy will retry if a
152 | transaction occurs while it is being performed.
153 | 
154 | It is slow copying the datastore. (A better copy than
155 | alexandria:copy-file should be easy to implement.)
156 | 
157 | The proposed reflink(2) system call would make a radically more
158 | efficient implementation possible.
159 | 
160 | 
161 |
162 | 163 | 164 | 165 | 166 | 167 | 168 |


[Macro]
with-cached-slots slots instance declaration* statement* => result 169 | 

170 | Like with-slots, but each slot is only read from the datastore once.
171 | It is written to the datastore immediately after every write, and the
172 | cached version becomes the value written (not the value as serialised
173 | and deserialised).
174 | 
175 | This is an optimization to stop repeatedly instantiating slots into
176 | Lisp memory. Note that it also useful because it preserves
177 | non-persistent slots of objects stored in SLOTS of INSTANCE over their
178 | lexical scope.
179 | 
180 |
181 | 182 | 183 | 184 | 185 | 186 | 187 |


[Function]
gc root-objects-sequence &key verbose collect-and-compact => result 188 | 

189 | Do a full and precise garbage collection over all objects in the memory mapped system. 
190 | If COLLECT-AND-COMPACT is true, then unused objeccts are removed.
191 | 
192 | Uses at least two pointers of Lisp memory per object and more if
193 | objects are densely referenced. See REWRITE-GC for a sloppier
194 | alternative that does not need so much memory.
195 | 
196 | 
197 |
198 | 199 | 200 | 201 | 202 | 203 | 204 |


[Generic function]
lisp-object-to-mptr-impl object => result 205 | 

206 | Override this generic function to give an user-defined class an
207 | alternative serialisation in the memory mapped datastore. Return the
208 | mptr pointing to this serialisation.
209 | 
210 | Note that the serialisation for builtin types are inlined and cannot
211 | be affected.
212 | 
213 | 
214 |
215 | 216 | 217 | 218 | 219 | 220 | 221 |


[Macro]
with-object-cache (name &key test) declaration* statement* => result 222 | 

223 | Lexically bind a function with NAME for BODY that, when passed an
224 | object, will either instantiate a new memory mapped object for it, or
225 | if the object is equal under TEST to a previous object passed to NAME,
226 | will return the same memory mapped object.
227 | 
228 |
229 | 230 | 231 | 232 | 233 | 234 | 235 |


[Macro]
defmmclass name direct-supers direct-slots &rest options => result 236 | 

237 | Define a memory mapped class, like defclass.
238 | 
239 | Automatically adds :metaclass mm-metaclass to options, if it is not
240 | present, finalizes the class immediately, and puts in an assertion
241 | that the class layout in the loaded datastore is compatible.
242 | 
243 |
244 | 245 | 246 | 247 | 248 | 249 | 250 |


[Macro]
direct-slot-numeric-maref class object slot element-type index => result 251 | 

252 | Access element INDEX of an array of ELEMENT-TYPE that is stored in
253 | slot SLOT of OBJECT, which is an instance of class CLASS, without
254 | instantiating the array into the memory of the host Lisp
255 | implementation.
256 | 
257 |
258 | 259 | 260 | 261 | 262 | 263 | 264 |


[Function]
make-mm-fixed-string length &key value => result 265 | 

266 | Create a fixed length string object of size LENGTH; stores into it the string in VALUE if given.
267 | 
268 | A fixed length string allows string objects to be modified in the
269 | datastore without allocating more space.
270 | 
271 | 
272 |
273 | 274 | 275 | 276 | 277 | 278 | 279 |


[Accessor]
mm-fixed-string-value mfs => result 280 |
(setf (mm-fixed-string-value mfs) string) 281 | 

282 | The string stored in the fixed length string MFS. If the string was cropped, then append ... to the stored value.
283 | 
284 | Can be set with setf. If the new value is too long then it will be silently cropped.
285 | 
286 | 
287 |
288 | 289 | 290 | 291 | 292 | 293 | 294 |


[Function]
clean-mmap-dir &optional dir => result 295 | 

296 | Unsafely remove all temporary directories from failed transactions
297 | that were not cleaned up because the transactor crashed.
298 | 
299 | [Not tested or used.] 
300 | 
301 |
302 | 303 | 304 | 305 | 306 | 307 | 308 |


[Function]
mptr obj => result 309 | 

310 | If OBJ is already an integer, return it. If it is a memory mapped object, return the MPTR corresponding to it.
311 | Otherwise, raise an error.
312 | 
313 |
314 | 315 | 316 | 317 | 318 | 319 | 320 |


[Function]
close-all-mmaps => result 321 | 

322 | Closes the datastore, unmapping and closing all files. Afterwards, a new datastore can be opened in a different locaiton.
323 | 
324 |
325 | 326 | 327 | 328 | 329 | 330 | 331 |


[Function]
meq a b => result 332 | 

333 | True iff either (eq a b) or A and B are both datastore objects
334 | representing the same object in the datastore.
335 | 
336 |
337 | 338 | 339 | 340 | 341 | 342 | 343 |


[Function]
mptr-to-lisp-object mptr => result 344 | 

345 | Deference the object at location MPTR in the memory mapped datastore and create a Lisp representation of it.
346 | 
347 |
348 | 349 | 350 | 351 | 352 | 353 | 354 |


[Special variable]
*mmap-may-allocate* 355 | 

356 | If this is not true, and an attempt is made to extend a memory mapped region, an error will be signalled.
357 | 
358 |
359 | 360 | 361 | 362 | 363 | 364 | 365 |


[Macro]
dosubclasses (var class-specifier &rest options) declaration* statement* => result 366 | 

367 | For the class itself and each subclass of the class denoted by CLASS-SPECIFIER (evaluated) run doclass.
368 | 
369 |
370 | 371 | 372 | 373 | 374 | 375 | 376 |


[Function]
count-all-instances class => result 377 | 

378 | Return a count of the number of instances of the class denoted by CLASS and any subclasses of it.
379 | 
380 |
381 | 382 | 383 | 384 | 385 | 386 | 387 |


[Function]
make-marray length &key initial-element initial-contents marray-class => result 388 | 

389 | Create a new marray (memory-mapped array) structure in the datastore, similarly to make-array.
390 | 
391 |
392 | 393 | 394 | 395 | 396 | 397 | 398 |


[Function]
lisp-object-to-mptr obj => result 399 | 

400 | Stores the object OBJ in the memory mapped datastore and returns the mptr referring to it
401 | 
402 |
403 | 404 | 405 | 406 | 407 | 408 | 409 |


[Function]
list-to-marray list => result 410 | 

411 | Converts a Lisp list to a memory-mapped array object; nil is converted to nil
412 | 
413 |
414 | 415 | 416 | 417 | 418 | 419 | 420 |


[Function]
marray-to-list marray => result 421 | 

422 | Converts a memory mapped array to a Lisp list; nil is converted to nil
423 | 
424 |
425 | 426 | 427 | 428 | 429 | 430 | 431 |


[Special variable]
*mmap-base-pathname* 432 | 

433 | The base path in which the datastore files are to be found.
434 | 
435 |
436 | 437 | 438 | 439 | 440 | 441 | 442 |


[Function]
use-mmap-dir dir &key if-does-not-exist => result 443 | 

444 | Set the memory mapped datastore to map files inside DIR.
445 | 
446 |
447 | 448 | 449 | 450 | 451 | 452 | 453 |


[Standard class]
marray 454 | 

455 | The base representation of a memory-mapped vector.
456 | 
457 |
458 | 459 | 460 | 461 | 462 | 463 | 464 |


[Function]
retrieve-all-instances class => result 465 | 

466 | Returns a list of all instances of CLASS.
467 | 
468 |
469 | 470 | 471 | 472 | 473 | 474 | 475 |


[Standard class]
mm-object 476 | 

477 | Base class for all memory mapped objects.
478 | 
479 |
480 | 481 | 482 | 483 | 484 | 485 | 486 |


[Accessor]
marray-ref marray i => result 487 |
(setf (marray-ref marray i) new) 488 | 

489 | Like aref, but for memory mapped arrays
490 | 
491 |
492 | 493 | 494 | 495 | 496 | 497 | 498 |


[Method]
marray-length (object marray) => result 499 | 

500 | automatically generated reader method
501 | 
502 |
503 | 504 | 505 | 506 | 507 | 508 | 509 |


[Function]
wipe-all-mmaps => result 510 | 

511 | Delete all objects from all classes.
512 | 
513 |
514 | 515 | 516 | 517 | 518 | 519 | 520 |


[Standard class]
mm-metaclass 521 | 

522 | Metaclass for memory mapped objects.
523 | 
524 |
525 | 526 | 527 | 528 | 529 | 530 | 531 |


[Function]
print-all-mmaps &optional stream => result 532 | 

533 | Describe the state of the datastore
534 | 
535 |
536 | 537 | 538 | 539 | 540 | 541 | 542 |


[Function]
open-all-mmaps => result 543 | 

544 | Maps the datastore into memory.
545 | 
546 |
547 | 548 | 549 | 550 | 551 | 552 | 553 |


[Generic function]
marray-length object => result 554 | 

555 | 
556 | 
557 |
558 | 559 | 560 | 561 | 562 |
 

Acknowledgements

563 | 564 |

565 | This documentation was prepared with a modified version of DOCUMENTATION-TEMPLATE. 566 |

567 |

568 | $Header: /usr/local/cvsrep/documentation-template/output.lisp,v 1.14 2008/05/29 08:23:37 edi Exp $ 569 |

BACK TO THE MAIN PROJECT PAGE 570 | 571 | 572 | --------------------------------------------------------------------------------