├── .gitignore ├── BUGS ├── CHANGES ├── LGPL.LICENSE ├── LLGPL.LICENSE ├── README.md ├── TODO ├── abcl ├── compiler.lisp ├── export.lisp ├── java.lisp └── package.lisp ├── doc ├── NEWS.md └── design.md ├── ffi ├── ffi.lisp ├── os.lisp ├── package.lisp └── struct.lisp ├── hyperluminal-mem-test.asd ├── hyperluminal-mem.asd ├── lang ├── lang.lisp ├── package.lisp └── swap-bytes.lisp ├── mem ├── box.lisp ├── box │ ├── array.lisp │ ├── bignum.lisp │ ├── bit-vector.lisp │ ├── complex.lisp │ ├── float.lisp │ ├── hash-table.lisp │ ├── list.lisp │ ├── pathname.lisp │ ├── ratio.lisp │ ├── string-ascii.lisp │ ├── string-utf-8.lisp │ ├── symbol.lisp │ └── vector.lisp ├── boxed.lisp ├── constants.lisp ├── defs.lisp ├── endianity.lisp ├── ffi-late.lisp ├── float.lisp ├── int.lisp ├── lang.lisp ├── magic.lisp ├── mem.lisp ├── mvar.lisp ├── native-mem.lisp ├── object.lisp ├── object │ ├── ghash-table.lisp │ ├── gmap.lisp │ ├── tcell.lisp │ └── tstack.lisp ├── package.lisp ├── struct.lisp ├── symbols.lisp ├── unboxed.lisp ├── unicode.lisp └── version.lisp ├── sbcl ├── arm.lisp ├── compiler.lisp ├── export.lisp ├── package.lisp └── x86.lisp ├── test ├── abi.lisp ├── magic.lisp ├── mem.lisp ├── memcpy.lisp ├── mset-int.lisp ├── package.lisp ├── run-suite.lisp ├── stmx-objects.lisp └── string.lisp └── tree ├── b+leaf.lisp ├── b+node.lisp ├── b+tree.lisp ├── package.lisp └── test-b+tree.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | -------------------------------------------------------------------------------- /BUGS: -------------------------------------------------------------------------------- 1 | See https://github.com/cosmos72/superluminal-db/issues 2 | 3 | KNOWN BUGS 4 | 5 | see https://github.com/cosmos72/hyperluminal-mem/issues 6 | 7 | FIXED BUGS 8 | 9 | - on SBCL, allocating large buffers (0.5GB) with (cffi-sys:with-foreign-pointer ...) 10 | returns a foreign pointer so it seems to succeed, 11 | but actually accessing the buffer crashes with "Memory fault at ..." 12 | 13 | There's a patch floating on SBCL mailing list, and hyperluminal-mem 14 | now avoids stack-allocating large buffers 15 | 16 | NOT BUGS 17 | 18 | - none yet 19 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | Changes in Hyperluminal-MEM 0.5.2: 2 | * Moved from Hyperluminal-DB and created a separate project. 3 | * Changed Hyperluminal-MEM license from GPLv3 to LLGPL. 4 | Note that Hyperluminal-DB is still GPLv3. 5 | 6 | Changes in Hyperluminal-DB 0.5.0: 7 | * Last release bundling together Hyperluminal-MEM and Hyperluminal-DB under GPL license. 8 | 9 | Changes in Hyperluminal-DB 0.0.2: 10 | * Renamed from Superluminal-DB to Hyperluminal-DB 11 | 12 | Changes in Superluminal-DB 0.0.1: 13 | * Moved from STMX and created a separate project 14 | -------------------------------------------------------------------------------- /LLGPL.LICENSE: -------------------------------------------------------------------------------- 1 | Preamble to the Gnu Lesser General Public License 2 | 3 | Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704 4 | 5 | The concept of the GNU Lesser General Public License version 2.1 ("LGPL") has been adopted to govern the use and distribution of above-mentioned application. However, the LGPL uses terminology that is more appropriate for a program written in C than one written in Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if certain clarifications are made. This document details those clarifications. Accordingly, the license for the open-source Lisp applications consists of this document plus the LGPL. Wherever there is a conflict between this document and the LGPL, this document takes precedence over the LGPL. 6 | 7 | A "Library" in Lisp is a collection of Lisp functions, data and foreign modules. The form of the Library can be Lisp source code (for processing by an interpreter) or object code (usually the result of compilation of source code or built with some other mechanisms). Foreign modules are object code in a form that can be linked into a Lisp executable. When we speak of functions we do so in the most general way to include, in addition, methods and unnamed functions. Lisp "data" is also a general term that includes the data structures resulting from defining Lisp classes. A Lisp application may include the same set of Lisp objects as does a Library, but this does not mean that the application is necessarily a "work based on the Library" it contains. 8 | 9 | The Library consists of everything in the distribution file set before any modifications are made to the files. If any of the functions or classes in the Library are redefined in other files, then those redefinitions ARE considered a work based on the Library. If additional methods are added to generic functions in the Library, those additional methods are NOT considered a work based on the Library. If Library classes are subclassed, these subclasses are NOT considered a work based on the Library. If the Library is modified to explicitly call other functions that are neither part of Lisp itself nor an available add-on module to Lisp, then the functions called by the modified Library ARE considered a work based on the Library. The goal is to ensure that the Library will compile and run without getting undefined function errors. 10 | 11 | It is permitted to add proprietary source code to the Library, but it must be done in a way such that the Library will still run without that proprietary code present. Section 5 of the LGPL distinguishes between the case of a library being dynamically linked at runtime and one being statically linked at build time. Section 5 of the LGPL states that the former results in an executable that is a "work that uses the Library." Section 5 of the LGPL states that the latter results in one that is a "derivative of the Library", which is therefore covered by the LGPL. Since Lisp only offers one choice, which is to link the Library into an executable at build time, we declare that, for the purpose applying the LGPL to the Library, an executable that results from linking a "work that uses the Library" with the Library is considered a "work that uses the Library" and is therefore NOT covered by the LGPL. 12 | 13 | Because of this declaration, section 6 of LGPL is not applicable to the Library. However, in connection with each distribution of this executable, you must also deliver, in accordance with the terms and conditions of the LGPL, the source code of Library (or your derivative thereof) that is incorporated into this executable. 14 | 15 | End of Document 16 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | ========== TO DO ========== 2 | 3 | define-compiler-macro on msize, msize-box, mwrite and mwrite-box 4 | for constant value or constant :type that open-code 5 | the calls to msize-box/ and mwrite-box/ 6 | 7 | everything else... 8 | 9 | ========== DONE ========== 10 | 11 | mwrite-box/string and mread-box/string use compact representation: 12 | they pack as many characters as possible in each CPU word 13 | 14 | (mwrite) should not call (detect-n-words), but simply dispatch the write 15 | and get the return value, which is the actual number of written words. 16 | As last, it should write the box header. 17 | 18 | bit-vector 19 | -------------------------------------------------------------------------------- /abcl/compiler.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-abcl) 17 | 18 | 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | 21 | (defconstant +jclass-int-array+ (java:jclass-of (java:jnew-array "int" 0))) 22 | (defconstant +jclass-long-array+ (java:jclass-of (java:jnew-array "long" 0))) 23 | 24 | (defconstant +sap=>buf4+ 25 | (java:jmethod "java.nio.ByteBuffer" "asIntBuffer")) 26 | (defconstant +sap=>buf8+ 27 | (java:jmethod "java.nio.ByteBuffer" "asLongBuffer")) 28 | (defconstant +copy-buf4+ 29 | (java:jmethod "java.nio.IntBuffer" "duplicate")) 30 | (defconstant +copy-buf8+ 31 | (java:jmethod "java.nio.LongBuffer" "duplicate")) 32 | (defconstant +buf4-position+ 33 | (java:jmethod "java.nio.IntBuffer" "position")) 34 | (defconstant +buf8-position+ 35 | (java:jmethod "java.nio.LongBuffer" "position")) 36 | (defconstant +buf4-set-position+ 37 | (java:jmethod "java.nio.IntBuffer" "position" "int")) 38 | (defconstant +buf8-set-position+ 39 | (java:jmethod "java.nio.LongBuffer" "position" "int")) 40 | (defconstant +buf4-get+ 41 | (java:jmethod "java.nio.IntBuffer" "get" "int")) 42 | (defconstant +buf4-put+ 43 | (java:jmethod "java.nio.IntBuffer" "put" "int" "int")) 44 | (defconstant +buf8-get+ 45 | (java:jmethod "java.nio.LongBuffer" "get" "int")) 46 | (defconstant +buf8-put+ 47 | (java:jmethod "java.nio.LongBuffer" "put" "int" "long")) 48 | (defconstant +buf4-bulkget+ 49 | (java:jmethod "java.nio.IntBuffer" "get" +jclass-int-array+ "int" "int")) 50 | (defconstant +buf4-bulkput+ 51 | (java:jmethod "java.nio.IntBuffer" "put" +jclass-int-array+ "int" "int")) 52 | (defconstant +buf8-bulkget+ 53 | (java:jmethod "java.nio.LongBuffer" "get" +jclass-long-array+ "int" "int")) 54 | (defconstant +buf8-bulkput+ 55 | (java:jmethod "java.nio.LongBuffer" "put" +jclass-long-array+ "int" "int")) 56 | 57 | 58 | 59 | (declaim (inline sap=>buf4 (x))) 60 | (defun sap=>buf4 (x) 61 | (java:jcall +sap=>buf4+ x)) 62 | 63 | (declaim (inline sap=>buf8 (x))) 64 | (defun sap=>buf8 (x) 65 | (java:jcall +sap=>buf8+ x)) 66 | 67 | (declaim (inline sap=>buf8)) 68 | (declaim (inline copy-buf4)) 69 | (defun copy-buf4 (x) 70 | (java:jcall +copy-buf4+ x)) 71 | 72 | (declaim (inline copy-buf8)) 73 | (defun copy-buf8 (x) 74 | (java:jcall +copy-buf8+ x)) 75 | 76 | (declaim (inline buf4-position)) 77 | (defun buf4-position (sap) 78 | (java:jcall +buf4-position+ sap)) 79 | 80 | (declaim (inline buf8-position)) 81 | (defun buf8-position (sap) 82 | (java:jcall +buf8-position+ sap)) 83 | 84 | (declaim (inline buf4-set-position)) 85 | (defun buf4-set-position (sap index) 86 | (java:jcall +buf4-set-position+ sap index) 87 | index) 88 | 89 | (declaim (inline buf8-set-position)) 90 | (defun buf8-set-position (sap index) 91 | (java:jcall +buf8-set-position+ sap index) 92 | index) 93 | 94 | (defsetf buf4-position buf4-set-position) 95 | (defsetf buf8-position buf8-set-position) 96 | 97 | (defmacro buf4-inc-position (sap index &key (scale 1) (offset 0)) 98 | `(incf (the fixnum (buf4-position ,sap)) 99 | (fixnum+ (fixnum* ,index ,scale) ,offset))) 100 | 101 | (defmacro buf8-inc-position (sap index &key (scale 1) (offset 0)) 102 | `(incf (the fixnum (buf8-position ,sap)) 103 | (fixnum+ (fixnum* ,index ,scale) ,offset))) 104 | -------------------------------------------------------------------------------- /abcl/export.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | ;;;; * HYPERLUMINAL-ABCL 17 | 18 | (in-package :cl-user) 19 | 20 | 21 | (macrolet ((define-package/reexport (package-name (&key reexport-from) &rest body) 22 | (let ((reexport (find-package reexport-from))) 23 | `(defpackage ,package-name 24 | ,@body 25 | (:use ,(package-name reexport)) 26 | (:export 27 | ,@(loop for s being the external-symbols of (find-package reexport-from) 28 | collect (symbol-name s))))))) 29 | 30 | (define-package/reexport #:hyperluminal-mem-asm 31 | (:reexport-from #:hlm-abcl) 32 | (:nicknames #:hlm-asm))) 33 | -------------------------------------------------------------------------------- /abcl/java.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-abcl) 17 | 18 | 19 | (defun fast-memcpy/4 (dst dst-index src src-index n-words &key 20 | (dst-scale 4) (dst-offset 0) 21 | (src-scale 4) (src-offset 0)) 22 | (declare (type ffi-address dst src) 23 | (type fixnum dst-index dst-scale dst-offset) 24 | (type fixnum src-index src-scale src-offset) 25 | (type fixnum n-words)) 26 | 27 | (when (<= n-words 8) 28 | (let ((dst-index (fixnum+ (fixnum* dst-index dst-scale) dst-offset)) 29 | (src-index (fixnum+ (fixnum* src-index src-scale) src-offset))) 30 | (loop for i from 0 below (fixnum* n-words 4) by 4 31 | do 32 | (let ((value (ffi-mem-get src :int (fixnum+ i src-index)))) 33 | (ffi-mem-set value dst :int (fixnum+ i dst-index)))) 34 | (return-from fast-memcpy/4 nil))) 35 | 36 | (let* ((dst (sap=>buf4 dst)) 37 | (src (sap=>buf4 src)) 38 | (chunk 16384) 39 | (n (min chunk n-words)) 40 | (buf (java:jnew-array "int" n))) 41 | 42 | ;; buf4 i.e. java.nio.IntBuffer offsets are counted in ints, not in bytes 43 | (buf4-inc-position dst dst-index 44 | :scale (ash dst-scale -2) :offset (ash dst-offset -2)) 45 | (buf4-inc-position src src-index 46 | :scale (ash src-scale -2) :offset (ash src-offset -2)) 47 | 48 | (loop while (plusp n-words) 49 | do 50 | (setf n (min chunk n-words)) 51 | ;; bulkget and bulkput offset refer to the int[], not to the buffer! 52 | (java:jcall +buf4-bulkget+ src buf 0 n) 53 | (java:jcall +buf4-bulkput+ dst buf 0 n) 54 | (decf n-words n)))) 55 | 56 | 57 | (defun fast-memcpy/8 (dst dst-index src src-index n-words &key 58 | (dst-scale 8) (dst-offset 0) 59 | (src-scale 8) (src-offset 0)) 60 | (declare (type ffi-address dst src) 61 | (type fixnum dst-index dst-scale dst-offset) 62 | (type fixnum src-index src-scale src-offset) 63 | (type fixnum n-words)) 64 | 65 | (when (<= n-words 8) 66 | (let ((dst-index (fixnum+ (fixnum* dst-index dst-scale) dst-offset)) 67 | (src-index (fixnum+ (fixnum* src-index src-scale) src-offset))) 68 | (loop for i from 0 below (fixnum* n-words 8) by 8 69 | do 70 | (let ((value (ffi-mem-get src :long (fixnum+ i src-index)))) 71 | (ffi-mem-set value dst :long (fixnum+ i dst-index)))) 72 | 73 | (return-from fast-memcpy/8 nil))) 74 | 75 | (let* ((dst (sap=>buf8 dst)) 76 | (src (sap=>buf8 src)) 77 | (chunk 8192) 78 | (n (min chunk n-words)) 79 | (buf (java:jnew-array "long" n))) 80 | 81 | ;; buf8 i.e. java.nio.LongBuffer offsets are counted in longs, not in bytes 82 | (buf8-inc-position dst dst-index 83 | :scale (ash dst-scale -3) :offset (ash dst-offset -3)) 84 | (buf8-inc-position src src-index 85 | :scale (ash src-scale -3) :offset (ash src-offset -3)) 86 | 87 | (loop while (plusp n-words) 88 | do 89 | (setf n (min chunk n-words)) 90 | ;; bulkget and bulkput offset refer to the long[], not to the buffer! 91 | (java:jcall +buf8-bulkget+ src buf 0 n) 92 | (java:jcall +buf8-bulkput+ dst buf 0 n) 93 | (decf n-words n)))) 94 | 95 | 96 | (defun fast-memset/4 (ptr index n-words fill-word &key (scale 4) (offset 0)) 97 | (declare (type ffi-address dst src) 98 | (type fixnum index scale offset n-words) 99 | (type (unsigned-byte 32) fill-word)) 100 | 101 | (when (<= n-words 8) 102 | (let* ((index (fixnum+ (fixnum* index scale) offset)) 103 | (end (fixnum+ index n-words))) 104 | (loop while (< index end) do 105 | (ffi-mem-set fill-word ptr :unsigned-int index) 106 | (incf index)) 107 | 108 | (return-from fast-memset/4 nil))) 109 | 110 | (let* ((ptr (sap=>buf4 ptr)) 111 | (chunk 16384) 112 | (n (min chunk n-words)) 113 | (buf (java:jnew-array "int" n))) 114 | 115 | (unless (zerop fill-word) 116 | (dotimes (i n) 117 | (java:jarray-set buf fill-word i))) 118 | 119 | ;; buf4 i.e. java.nio.IntBuffer offsets are counted in ints, not in bytes 120 | (buf4-inc-position ptr index :scale (ash scale -2) :offset (ash offset -2)) 121 | 122 | (loop while (plusp n-words) 123 | do 124 | (setf n (min chunk n-words)) 125 | ;; bulkput offset refer to the int[], not to the buffer! 126 | (java:jcall +buf4-bulkput+ ptr buf 0 n) 127 | (decf n-words n)))) 128 | 129 | 130 | (defun fast-memset/8 (ptr index n-words fill-word &key (scale 8) (offset 0)) 131 | (declare (type ffi-address dst src) 132 | (type fixnum index scale offset n-words) 133 | (type (unsigned-byte 32) fill-word)) 134 | 135 | (when (<= n-words 8) 136 | (let* ((index (fixnum+ (fixnum* index scale) offset)) 137 | (end (fixnum+ index n-words))) 138 | (loop while (< index end) do 139 | (ffi-mem-set fill-word ptr :unsigned-long index) 140 | (incf index)) 141 | 142 | (return-from fast-memset/8 nil))) 143 | 144 | (let* ((ptr (sap=>buf8 ptr)) 145 | (chunk 8192) 146 | (n (min chunk n-words)) 147 | (buf (java:jnew-array "long" n))) 148 | 149 | (unless (zerop fill-word) 150 | (dotimes (i n) 151 | (java:jarray-set buf fill-word i))) 152 | 153 | ;; buf8 i.e. java.nio.LongBuffer offsets are counted in longs, not in bytes 154 | (buf8-inc-position ptr index :scale (ash scale -3) :offset (ash offset -3)) 155 | 156 | (loop while (plusp n-words) 157 | do 158 | (setf n (min chunk n-words)) 159 | ;; bulkput offset refer to the int[], not to the buffer! 160 | (java:jcall +buf8-bulkput+ ptr buf 0 n) 161 | (decf n-words n)))) 162 | -------------------------------------------------------------------------------- /abcl/package.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | ;;;; * HYPERLUMINAL-ABCL 17 | 18 | (in-package :cl-user) 19 | 20 | 21 | (defpackage #:hyperluminal-mem-abcl 22 | (:nicknames #:hlm-abcl) 23 | (:use #:cl #:hyperluminal-mem-lang #:hyperluminal-mem-ffi) 24 | (:import-from #:stmx.lang 25 | #:eval-always #:with-gensym #:with-gensyms) 26 | 27 | (:export #:fast-memcpy/4 #:fast-memset/4 28 | #:fast-memcpy/8 #:fast-memset/8)) 29 | -------------------------------------------------------------------------------- /doc/NEWS.md: -------------------------------------------------------------------------------- 1 | ### Latest news, 2nd March 2015 2 | 3 | Hyperluminal-mem 0.6.1 is included in the newest Quicklisp distribution. 4 | You can now load it with: `(ql:quickload "hyperluminal-mem")` 5 | 6 | ### News, 24th January 2015 7 | 8 | Released version 0.5.2. License change from GPLv3 to LLGPL! 9 | 10 | Older versions were bundled together with Hyperluminal-DB in a single GPLv3 package. 11 | Hyperluminal-DB is now a separate project, still under GPLv3. 12 | 13 | ### News, 9th February 2014 14 | 15 | Released version 0.5.0. 16 | 17 | The serialization library is tested, documented and ready to use. 18 | It may still contain some rough edges and small bugs. 19 | 20 | ### News, 1st February 2014 21 | 22 | The serialization library works and is in BETA status. 23 | 24 | The memory-mapped database (built on top of the serialization library) 25 | is in the early-implementation stage, not yet ready for general use. 26 | 27 | -------------------------------------------------------------------------------- /ffi/os.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-ffi) 17 | 18 | (declaim (inline os-getpagesize)) 19 | 20 | (defun os-getpagesize () 21 | #-abcl (osicat-posix:getpagesize) 22 | #+abcl 8192) ;; just a guess... 23 | 24 | (deftype fd () 25 | #-abcl 'fixnum 26 | #+abcl '(or null java:java-object)) ;; java.nio.channels.FileChannel 27 | 28 | (defconstant +bad-fd+ 29 | #-abcl -1 30 | #+abcl nil) 31 | 32 | 33 | 34 | (declaim (inline bad-fd?)) 35 | (defun bad-fd? (fd) 36 | (declare (type fd fd)) 37 | #-abcl (< fd 0) 38 | #+abcl (null fd)) 39 | 40 | 41 | (defun os-open-fd (filename &key (read t) (write nil)) 42 | #-abcl 43 | (let ((mode (cond 44 | ((and read write) osicat-posix:o-rdwr) 45 | (write osicat-posix:o-wronly) 46 | (t osicat-posix:o-rdonly)))) 47 | (osicat-posix:open filename (logior mode osicat-posix:o-creat))) 48 | #+abcl 49 | (let* ((mode (cond 50 | ((and read write) "rw") 51 | (write "w") 52 | (t "r"))) 53 | (f (java:jnew "java.io.RandomAccessFile" filename mode))) 54 | (java:jcall "getChannel" f))) 55 | 56 | 57 | (defun os-close-fd (fd) 58 | (declare (type fd fd)) 59 | #-abcl (osicat-posix:close fd) 60 | #+abcl (java:jcall "close" fd)) 61 | 62 | 63 | (defun os-stat-fd-size (fd) 64 | (declare (type fd fd)) 65 | #-abcl (osicat-posix:stat-size (osicat-posix:fstat fd)) 66 | #+abcl (java:jcall "size" fd)) 67 | 68 | 69 | (defun os-truncate-fd (fd bytes) 70 | (declare (type fd fd)) 71 | #-abcl (osicat-posix:ftruncate fd bytes) 72 | #+abcl (java:jcall "truncate" fd bytes)) 73 | 74 | 75 | (defun os-mmap-fd (fd &key (offset-bytes 0) (length-bytes (os-stat-fd-size fd)) 76 | (read t) (write nil)) 77 | (declare (type fd fd)) 78 | #-abcl 79 | (let ((prot (logior 80 | (if read osicat-posix:prot-read osicat-posix:prot-none) 81 | (if write osicat-posix:prot-write osicat-posix:prot-none)))) 82 | (osicat-posix:mmap +null-pointer+ length-bytes prot 83 | osicat-posix:map-shared 84 | fd offset-bytes)) 85 | #+abcl 86 | (declare (ignore read)) 87 | #+abcl 88 | (let* ((prot (java:jfield "java.nio.channels.FileChannel$MapMode" 89 | (if write "READ_WRITE" "READ_ONLY"))) 90 | (fd (java:jcall "map" fd prot offset-bytes length-bytes))) 91 | (java:jcall +java-nio-bytebuffer-set-byteorder+ fd +java-nio-byteorder-native+) 92 | fd)) 93 | 94 | 95 | (defun os-munmap-ptr (ptr length-bytes) 96 | (declare (type ffi-address ptr)) 97 | #-abcl 98 | (osicat-posix:munmap ptr length-bytes) 99 | 100 | ;; Java MappedByteBuffer docs say it is unmapped when garbage collected. 101 | #+abcl 102 | (declare (ignore ptr length-bytes))) 103 | 104 | 105 | (defun os-msync-ptr (ptr length-bytes sync) 106 | (declare (type ffi-address ptr) 107 | (type (integer 0) length-bytes)) 108 | 109 | #-abcl 110 | (osicat-posix:msync ptr length-bytes 111 | (if sync 112 | (logior osicat-posix:ms-sync osicat-posix:ms-invalidate) 113 | (logior osicat-posix:ms-async osicat-posix:ms-invalidate))) 114 | #+abcl 115 | (declare (ignore length-bytes sync)) 116 | #+abcl 117 | (java:jcall "force" ptr)) 118 | 119 | 120 | (declaim (ftype (function () fixnum) os-fork)) 121 | 122 | #-abcl 123 | (defun os-fork () 124 | (osicat-posix:fork)) 125 | 126 | #-abcl 127 | (defun os-fork-process (func) 128 | (check-type func function) 129 | (let ((pid (os-fork))) 130 | (if (zerop pid) 131 | ;; child: call FUNC 132 | (let ((exit-code -1)) 133 | (declare (type fixnum exit-code)) 134 | (unwind-protect 135 | (let ((result (funcall func))) 136 | (when (typep result 'fixnum) 137 | (setf exit-code result))) 138 | (osicat-posix:exit exit-code))) 139 | ;; parent: return child pid 140 | pid))) 141 | -------------------------------------------------------------------------------- /ffi/package.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | ;;;; * HYPERLUMINAL-MEM 17 | 18 | (in-package :cl-user) 19 | 20 | (defpackage #:hyperluminal-mem-ffi 21 | 22 | (:nicknames #:hlm-ffi) 23 | 24 | (:use #:cl) 25 | 26 | (:import-from #:stmx.lang 27 | 28 | #:eval-always #:enable-#?-syntax 29 | 30 | #:define-global #:define-constant-once 31 | #:with-gensym #:with-gensyms) 32 | 33 | (:export #:ffi-mem-get #:ffi-mem-set 34 | #:ffi-mem-alloc #:ffi-mem-free #:ffi-endianity 35 | #:with-ffi-mem #:with-vector-mem 36 | #:ffi-sizeof #:ffi-native-type-name 37 | #:+null-pointer+ #:null-pointer? #:ffi-address 38 | 39 | #:ffi-defstruct 40 | 41 | #:os-getpagesize #:fd #:+bad-fd+ #:bad-fd? 42 | #:os-open-fd #:os-close-fd #:os-stat-fd-size #:os-truncate-fd 43 | #:os-mmap-fd #:os-munmap-ptr #:os-msync-ptr)) 44 | 45 | -------------------------------------------------------------------------------- /ffi/struct.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-ffi) 17 | 18 | #-abcl 19 | (defmacro ffi-defstruct (name-and-options &body fields) 20 | `(cffi:defcstruct ,name-and-options ,@fields)) 21 | -------------------------------------------------------------------------------- /hyperluminal-mem-test.asd: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of HYPERLUMINAL-MEM. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | 17 | 18 | (in-package :cl-user) 19 | 20 | (asdf:defsystem :hyperluminal-mem-test 21 | :name "HYPERLUMINAL-MEM-TEST" 22 | :version "0.6.2" 23 | :author "Massimiliano Ghilardi" 24 | :license "LLGPL" 25 | :description "test suite for hyperluminal-mem" 26 | 27 | :depends-on (:log4cl 28 | :fiveam 29 | :hyperluminal-mem) 30 | 31 | :components ((:module :test 32 | :components ((:file "package") 33 | (:file "magic" :depends-on ("package")) 34 | (:file "mem" :depends-on ("package")) 35 | (:file "memcpy" :depends-on ("mem")) 36 | (:file "abi" :depends-on ("mem")) 37 | (:file "string" :depends-on ("abi")) 38 | (:file "stmx-objects" :depends-on ("abi")) 39 | (:file "run-suite" :depends-on ("package"))))) 40 | 41 | :perform (asdf:test-op 42 | (o c) 43 | (eval (read-from-string "(fiveam:run! 'hyperluminal-mem-test:suite)")))) 44 | -------------------------------------------------------------------------------- /hyperluminal-mem.asd: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of HYPERLUMINAL-MEM. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | 17 | 18 | (in-package :cl-user) 19 | 20 | (asdf:defsystem :hyperluminal-mem 21 | :name "HYPERLUMINAL-MEM" 22 | :version "0.6.2" 23 | :license "LLGPL" 24 | :author "Massimiliano Ghilardi" 25 | :description "High-performance serialization library, designed for untrusted data" 26 | 27 | :depends-on (#-abcl :cffi 28 | #-abcl :osicat 29 | ;; support inverted endianity. ABCL has built-in support, CLISP 2.49 has too old asdf 30 | #-(or abcl clisp) :swap-bytes 31 | :trivial-features ;; for uniform #+x86-64 32 | :stmx) 33 | 34 | :components 35 | ((:static-file "hyperluminal-mem.asd") 36 | 37 | (:module :lang 38 | :components ((:file "package") 39 | (:file "lang" :depends-on ("package")) 40 | (:file "swap-bytes" :depends-on ("package")))) 41 | 42 | (:module :ffi 43 | :components ((:file "package") 44 | (:file "ffi" :depends-on ("package")) 45 | (:file "struct" :depends-on ("ffi")) 46 | (:file "os" :depends-on ("ffi"))) 47 | :depends-on (:lang)) 48 | 49 | 50 | #+abcl 51 | (:module :abcl 52 | :components ((:file "package") 53 | (:file "export" :depends-on ("package")) 54 | (:file "compiler" :depends-on ("package")) 55 | (:file "java" :depends-on ("compiler"))) 56 | :depends-on (:lang :ffi)) 57 | 58 | #+(and sbcl (or arm x86 x86-64)) 59 | (:module :sbcl 60 | :components ((:file "package") 61 | (:file "export" :depends-on ("package")) 62 | (:file "compiler" :depends-on ("package")) 63 | #+arm 64 | (:file "arm" :depends-on ("compiler")) 65 | #+(or x86 x86-64) 66 | (:file "x86" :depends-on ("compiler"))) 67 | :depends-on (:lang :ffi)) 68 | 69 | (:module :mem 70 | :components ((:file "package") 71 | (:file "lang" :depends-on ("package")) 72 | (:file "version" :depends-on ("lang")) 73 | (:file "defs" :depends-on ("lang")) 74 | (:file "native-mem" :depends-on ("defs")) 75 | (:file "endianity" :depends-on ("native-mem")) 76 | (:file "float" :depends-on ("endianity")) 77 | (:file "mem" :depends-on ("float")) 78 | (:file "constants" :depends-on ("mem")) 79 | (:file "symbols" :depends-on ("constants")) 80 | (:file "int" :depends-on ("symbols")) 81 | (:file "unboxed" :depends-on ("int")) 82 | (:file "ffi-late" :depends-on ("unboxed")) 83 | (:file "box" :depends-on ("version" "unboxed" "ffi-late")) 84 | (:file "magic" :depends-on ("box")) 85 | (:file "unicode" :depends-on ("box")) 86 | 87 | (:file "box/bignum" :depends-on ("box")) 88 | (:file "box/ratio" :depends-on ("box/bignum")) 89 | (:file "box/float" :depends-on ("box")) 90 | (:file "box/complex" :depends-on ("box/float" "box/ratio")) 91 | (:file "box/pathname" :depends-on ("box")) 92 | (:file "box/hash-table" :depends-on ("box")) 93 | (:file "box/list" :depends-on ("box")) 94 | (:file "box/array" :depends-on ("box")) 95 | (:file "box/vector" :depends-on ("box/array")) 96 | (:file "box/string-utf-8" :depends-on ("box/vector" "unicode")) 97 | (:file "box/string-ascii" :depends-on ("box/vector")) 98 | (:file "box/bit-vector" :depends-on ("box/vector")) 99 | (:file "box/symbol" :depends-on ("box")) 100 | 101 | (:file "mvar" :depends-on ("box")) 102 | (:file "struct" :depends-on ("mvar")) 103 | (:file "object" :depends-on ("struct")) 104 | (:file "object/gmap" :depends-on ("object")) 105 | (:file "object/ghash-table" :depends-on ("object")) 106 | (:file "object/tcell" :depends-on ("object")) 107 | (:file "object/tstack" :depends-on ("object")) 108 | 109 | (:file "boxed" :depends-on ("box" 110 | "box/bignum" 111 | "box/ratio" 112 | "box/float" 113 | "box/complex" 114 | "box/pathname" 115 | "box/hash-table" 116 | "box/list" 117 | "box/array" 118 | "box/vector" 119 | "box/string-utf-8" 120 | "box/string-ascii" 121 | "box/bit-vector" 122 | "box/symbol" 123 | "object"))) 124 | :depends-on (:lang :ffi 125 | #+abcl :abcl 126 | #+(and sbcl (or arm x86 x86-64)) :sbcl)) 127 | 128 | (:module :tree 129 | :components ((:file "package") 130 | (:file "b+node" :depends-on ("package")) 131 | (:file "b+leaf" :depends-on ("b+node")) 132 | (:file "b+tree" :depends-on ("b+leaf")) 133 | (:file "test-b+tree" :depends-on ("b+tree"))) 134 | :depends-on (:mem))) 135 | 136 | :in-order-to ((asdf:test-op (asdf:test-op "hyperluminal-mem-test")))) 137 | -------------------------------------------------------------------------------- /lang/lang.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-lang) 17 | 18 | (eval-when (:compile-toplevel :load-toplevel) 19 | (pushnew :hyperluminal-mem *features*) 20 | 21 | #-(and) 22 | (pushnew :hyperluminal-mem/debug *features*) 23 | 24 | #+abcl ;; #?+abcl is used in mem/float.lisp 25 | (set-feature :abcl) 26 | 27 | ;; does CPU allow unaligned reads and writes of double-floats? 28 | ;; used in mem/float.lisp to split double-float reads and writes, 29 | ;; otherwise SPARC (and possibly other CPUs) will signal SIGBUS 30 | (set-feature :cpu/double-float/unaligned #+sparc nil)) 31 | 32 | 33 | (defun eval-compile-constant (name form) 34 | (unless (constantp form) 35 | (error "~S must be a compile-time constant, found ~S" name form)) 36 | (eval form)) 37 | 38 | 39 | (defmacro check-compile-constant (form) 40 | `(eval-compile-constant ',form ,form)) 41 | 42 | 43 | 44 | (defun or-func (&rest args) 45 | (dolist (arg args nil) 46 | (when arg 47 | (return t)))) 48 | 49 | (defun and-func (&rest args) 50 | (dolist (arg args t) 51 | (unless arg 52 | (return nil)))) 53 | 54 | (defun unwrap-list-1 (list) 55 | "If LIST contains a single element which is itself a list, return that element. 56 | Otherwise return the whole LIST" 57 | (declare (type list list)) 58 | (let ((first (first list))) 59 | (if (and (listp first) (null (rest list))) 60 | first 61 | list))) 62 | 63 | (defun stringify (&rest things) 64 | "Print the things to a string and return it" 65 | (let ((s (make-array 0 :element-type 'character :adjustable t :fill-pointer 0)) 66 | (*print-array* t) 67 | (*print-base* 10) 68 | (*print-escape* nil) 69 | (*print-gensym* nil) 70 | (*print-pretty* nil) 71 | (*print-radix* nil) 72 | (*print-readably* nil)) 73 | (dolist (thing (unwrap-list-1 things)) 74 | (format s "~A" thing)) 75 | s)) 76 | 77 | (defun concat-symbols (&rest things) 78 | "Print the things to a string, the convert the string into a symbol interned in current package. 79 | Return the symbol" 80 | (intern (apply #'stringify things))) 81 | 82 | 83 | (defun get-symbol (package-name symbol-name &key errorp) 84 | (declare (type (or symbol string package) package-name) 85 | (type (or symbol string) symbol-name)) 86 | (when (symbolp package-name) (setf package-name (string package-name))) 87 | (when (symbolp symbol-name) (setf symbol-name (string symbol-name))) 88 | (let ((pkg (find-package package-name))) 89 | (if pkg 90 | (multiple-value-bind (sym kind) (find-symbol symbol-name pkg) 91 | (if kind 92 | (values sym kind) 93 | (when errorp 94 | (error "no symbol ~A in package ~A" 95 | symbol-name package-name)))) 96 | (when errorp 97 | (error "no package ~A" package-name))))) 98 | 99 | 100 | 101 | (defun have-symbol? (package-name symbol-name) 102 | (declare (type (or symbol string package) package-name) 103 | (type (or symbol string) symbol-name)) 104 | (not (null (nth-value 1 (get-symbol package-name symbol-name))))) 105 | 106 | (defun get-fbound-symbol (package-name symbol-name) 107 | (declare (type (or symbol string package) package-name) 108 | (type (or symbol string) symbol-name)) 109 | (multiple-value-bind (sym found) (get-symbol package-name symbol-name) 110 | (when (and found (fboundp sym)) 111 | sym))) 112 | 113 | 114 | 115 | 116 | (defmacro check-vector-index (vector index &rest error-message-and-args) 117 | (with-gensyms (len idx) 118 | `(let* ((,len (length (the vector ,vector))) 119 | (,idx (the fixnum ,index))) 120 | (unless (<= 0 ,idx ,len) 121 | ,(if error-message-and-args 122 | `(error ,@error-message-and-args) 123 | `(error "out of range index ~S: vector has ~S elements" 124 | ,idx ,len)))))) 125 | 126 | 127 | 128 | (declaim (inline fixnum*)) 129 | (defun fixnum* (a b) 130 | (declare (type fixnum a b)) 131 | (the fixnum (* a b))) 132 | 133 | (declaim (inline fixnum+)) 134 | (defun fixnum+ (a b) 135 | (declare (type fixnum a b)) 136 | (the fixnum (+ a b))) 137 | 138 | (declaim (inline fixnum-)) 139 | (defun fixnum- (a b) 140 | (declare (type fixnum a b)) 141 | (the fixnum (- a b))) 142 | -------------------------------------------------------------------------------- /lang/package.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | ;;;; * HYPERLUMINAL-MEM 17 | 18 | (in-package :cl-user) 19 | 20 | (defpackage #:hyperluminal-mem-lang 21 | 22 | (:nicknames #:hlm-lang) 23 | 24 | (:use #:cl) 25 | 26 | (:import-from #:stmx.lang 27 | #:with-gensyms #:set-feature) 28 | 29 | (:export #:eval-compile-constant #:check-compile-constant 30 | #:or-func #:and-func 31 | #:stringify #:concat-symbols 32 | #:get-symbol #:get-fbound-symbol #:have-symbol? 33 | #:check-vector-index 34 | 35 | #:fixnum* #:fixnum+ #:fixnum- 36 | #:find-swap-bytes/n 37 | #:swap-bytes/2 #:swap-bytes/4 #:swap-bytes/8)) 38 | 39 | 40 | 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /lang/swap-bytes.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-lang) 17 | 18 | ;; support inverted endianity. 19 | 20 | ;; clisp 2.49 has too old asdf, cannot load swap-bytes 21 | #+clisp 22 | (progn 23 | (declaim (inline swap-bytes/2)) 24 | (defun swap-bytes/2 (n) 25 | (declare (type (unsigned-byte 16) n)) 26 | (logior (ash (logand #x00FF n) 8) 27 | (ash n -8))) 28 | 29 | (declaim (inline swap-bytes/4)) 30 | (defun swap-bytes/4 (n) 31 | (declare (type (unsigned-byte 32) n)) 32 | #+#.(cl:if (cl:> (cl:integer-length cl:most-positive-fixnum) 32) '(:and) '(:or)) 33 | (logior (ash (logand #x000000FF n) 24) 34 | (ash (logand #x0000FF00 n) 8) 35 | (ash (logand #x00FF0000 n) -8) 36 | (ash n -24)) 37 | #-#.(cl:if (cl:> (cl:integer-length cl:most-positive-fixnum) 32) '(:and) '(:or)) 38 | (logior (swap-bytes/2 (ash n -16)) 39 | (ash (swap-bytes/2 (logand n #xFFFF)) 16))) 40 | 41 | (declaim (inline swap-bytes/8)) 42 | (defun swap-bytes/8 (n) 43 | (declare (type (unsigned-byte 64) n)) 44 | (logior (swap-bytes/4 (ash n -32)) 45 | (ash (swap-bytes/4 (logand n #xFFFFFFFF)) 32)))) 46 | 47 | 48 | 49 | ;; ABCL has built-in support in java.nio.ByteBuffer 50 | #-(or abcl clisp) 51 | (progn 52 | (declaim (inline swap-bytes/2)) 53 | (defun swap-bytes/2 (n) 54 | (swap-bytes:swap-bytes-16 n)) 55 | 56 | (declaim (inline swap-bytes/4)) 57 | (defun swap-bytes/4 (n) 58 | (swap-bytes:swap-bytes-32 n)) 59 | 60 | (declaim (inline swap-bytes/8)) 61 | (defun swap-bytes/8 (n) 62 | (swap-bytes:swap-bytes-64 n))) 63 | 64 | 65 | #-abcl 66 | (defun find-swap-bytes/n (size) 67 | (ecase size 68 | (1 'identity) 69 | (2 'swap-bytes/2) 70 | (4 'swap-bytes/4) 71 | (8 'swap-bytes/8))) 72 | 73 | 74 | 75 | -------------------------------------------------------------------------------- /mem/box/array.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | (enable-#?-syntax) 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;;; boxed array ;;;; 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | 25 | (defmacro %the-array (a type simple) 26 | (if simple 27 | `(the (simple-array ,(if type type '*) *) ,a) 28 | `(the (and (array ,(if type type '*) *) 29 | (not simple-array)) 30 | ,a))) 31 | 32 | 33 | (defmacro %loop-array-unboxed (func a type) 34 | (ecase func 35 | (mwrite 36 | (with-gensyms (i e) 37 | `(progn 38 | (check-mem-overrun ptr index end-index len) 39 | (loop for ,i from 0 below len 40 | for ,e = (row-major-aref ,a ,i) do 41 | (mset-unboxed ptr index (the ,type ,e)) 42 | (incf-mem-size index))))) 43 | (msize 44 | `(incf-mem-size index len)))) 45 | 46 | 47 | 48 | (defmacro %loop-array-t (func a type) 49 | (with-gensyms (i e) 50 | `(loop for ,i from 0 below len 51 | for ,e = (row-major-aref ,a ,i) 52 | do (setf index 53 | ,(ecase func 54 | (mwrite `(mwrite ptr index end-index (the ,type ,e))) 55 | (msize `(msize index (the ,type ,e)))))))) 56 | 57 | 58 | (defmacro %loop-array (func a type simple) 59 | `(cond 60 | ((mem-int=integer-type ,type) 61 | (%loop-array-unboxed ,func (%the-array ,a mem-int ,simple) mem-int)) 62 | 63 | #?+hlmem/mem-int>fixnum 64 | ((eq ,type 'fixnum) 65 | (%loop-array-unboxed ,func (%the-array ,a fixnum ,simple) fixnum)) 66 | 67 | ((mem-int>integer-type ,type) 68 | (%loop-array-unboxed ,func (%the-array ,a * ,simple) mem-int)) 69 | 70 | ((eq 'character ,type) 71 | (%loop-array-unboxed ,func (%the-array ,a character ,simple) character)) 72 | 73 | ((eq 'base-char ,type) 74 | (%loop-array-unboxed ,func (%the-array ,a base-char ,simple) base-char)) 75 | 76 | #?+hlmem/sfloat/inline 77 | ((eq 'single-float ,type) 78 | (%loop-array-unboxed ,func (%the-array ,a single-float ,simple) single-float)) 79 | 80 | #?+hlmem/dfloat/inline 81 | ((eq 'double-float ,type) 82 | (%loop-array-unboxed ,func (%the-array ,a double-float ,simple) double-float)) 83 | 84 | ((eq t ,type) 85 | (%loop-array-t ,func (%the-array ,a t ,simple) t)) 86 | 87 | (t 88 | (%loop-array-t ,func (%the-array ,a * ,simple) t)))) 89 | 90 | 91 | 92 | 93 | (defun msize-box/array (index array) 94 | "Return the number of words needed to store ARRAY in mmap memory, 95 | not including BOX header." 96 | (declare (type mem-size index) 97 | (type array array)) 98 | 99 | (let ((rank (array-rank array)) 100 | (len (array-total-size array)) 101 | (type (array-element-type array)) 102 | (simple (typep array 'simple-array))) 103 | 104 | #-(and) (log:trace ptr index array) 105 | 106 | (unless (< rank (- +most-positive-int+ index)) 107 | (error "HYPERLUMINAL-MEM: array has too many dimensions for object store. 108 | it has rank ~S, but at most ~S words are available at index ~S" 109 | rank (- +most-positive-int+ index 1) index)) 110 | 111 | ;; 1 word to store the rank, +1 per dimension 112 | (incf-mem-size index (mem-size+1 rank)) 113 | 114 | (unless (<= len (- +most-positive-int+ index)) 115 | (error "HYPERLUMINAL-MEM: array too large for object store. 116 | it contains ~S elements, but at most ~S words are available at index ~S" 117 | len (- +most-positive-int+ index) index)) 118 | 119 | (if simple 120 | (%loop-array msize array type t) 121 | ;; specializing on the element-type of non-simple arrays 122 | ;; is usually not needed, as they are slow in any case 123 | (%loop-array-t msize array t))) 124 | index) 125 | 126 | 127 | 128 | (defun mwrite-box/array (ptr index end-index array) 129 | "Write ARRAY into the memory starting at (PTR+INDEX). 130 | Return number of words actually written. 131 | 132 | Assumes BOX header is already written, and that enough memory is available 133 | at (PTR+INDEX)." 134 | (declare (type maddress ptr) 135 | (type mem-size index end-index) 136 | (type array array)) 137 | 138 | (let ((rank (array-rank array)) 139 | (len (array-total-size array)) 140 | (type (array-element-type array)) 141 | (simple (typep array 'simple-array))) 142 | 143 | #-(and) (log:trace ptr index array) 144 | 145 | (check-mem-overrun ptr index end-index (1+ rank)) 146 | 147 | (mset-int ptr index (the mem-int rank)) 148 | (incf-mem-size index) 149 | 150 | (loop for i from 0 below rank do 151 | (mset-int ptr index (the mem-int (array-dimension array i))) 152 | (incf-mem-size index)) 153 | 154 | (if simple 155 | (%loop-array mwrite array type t) 156 | ;; specializing on the element-type of non-simple arrays 157 | ;; is usually not needed, as they are slow in any case 158 | (%loop-array-t mwrite array t))) 159 | index) 160 | 161 | 162 | (defun mread-box/array (ptr index end-index) 163 | "Read an array from the memory starting at (PTR+INDEX) and return it. 164 | Also returns number of words actually read as additional value. 165 | 166 | Assumes BOX header was already read." 167 | (declare (type maddress ptr) 168 | (type mem-size index end-index)) 169 | 170 | (let ((rank (mget-int ptr index)) 171 | (len 1)) 172 | (declare (type mem-int rank len)) 173 | 174 | (check-array-rank ptr index 'array rank) 175 | (check-mem-length ptr index end-index rank) 176 | 177 | (let* ((dimensions 178 | (loop for i from 0 below rank 179 | for len-i = (mget-int ptr (incf-mem-size index)) 180 | do 181 | (setf len (the mem-int (* len len-i))) 182 | collect len-i 183 | finally 184 | (incf-mem-size index) 185 | (check-mem-length ptr index end-index len))) 186 | 187 | (array (the (simple-array t) (make-array (the list dimensions))))) 188 | 189 | (loop for i from 0 below len 190 | do (multiple-value-bind (e e-index) (mread ptr index end-index) 191 | (setf (row-major-aref array i) e 192 | index (the mem-size e-index)))) 193 | 194 | (values array index)))) 195 | -------------------------------------------------------------------------------- /mem/box/bignum.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | (enable-#?-syntax) 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;;; boxed BIGNUMs ;;;; 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | 25 | (declaim (inline %bignum-words)) 26 | 27 | (defun %bignum-words (n) 28 | "Return the number of words needed to store bignum N in memory, not including BOX header 29 | nor the N-WORDS prefix." 30 | (declare (type integer n)) 31 | 32 | (the ufixnum 33 | (ceiling (integer-length n) +mem-word/bits+))) ;; round up 34 | 35 | 36 | (defun msize-box/bignum (index n) 37 | "Return the number of words needed to store bignum N in memory, not including BOX header." 38 | (declare (type integer n) 39 | (type mem-size index)) 40 | 41 | (let ((words (%bignum-words n)) 42 | (words-left (mem-size- +mem-bignum/max-words+ index))) 43 | (unless (< words words-left) 44 | (error "HYPERLUMINAL-MEM: not enough free space in object store for bignum: 45 | it requires ~S words, but only ~S words currently available" 46 | (1+ words) words-left)) 47 | 48 | ;; add 1 word for N-WORDS prefix 49 | (mem-size+ index 1 words))) 50 | 51 | 52 | 53 | (defun %mwrite-bignum-loop (ptr index n-words n) 54 | (declare (type maddress ptr) 55 | (type mem-size index n-words) 56 | (type integer n)) 57 | 58 | (let ((shift (- +mem-word/bits+)) 59 | (mask +mem-word/mask+)) 60 | 61 | (loop for i-word from n-words downto 1 do 62 | (mset-word ptr index (logand n mask)) 63 | (incf (the mem-size index)) 64 | (setf n (ash n shift)))) 65 | index) 66 | 67 | 68 | (defun %mwrite-bignum-recurse (ptr index n-words n) 69 | (declare (type maddress ptr) 70 | (type mem-size index n-words) 71 | (type integer n)) 72 | 73 | #-(and) (log:trace "index: ~S n-words: ~S n: #x~X" index n-words n) 74 | 75 | (if (<= n-words 16) 76 | (%mwrite-bignum-loop ptr index n-words n) 77 | 78 | (let* ((n-words-high (truncate n-words 2)) 79 | (n-words-low (- n-words n-words-high)) 80 | (high-shift (the fixnum (* n-words-low +mem-word/bits+))) 81 | (low-mask (1- (ash 1 high-shift)))) 82 | 83 | (%mwrite-bignum-recurse ptr index n-words-low (logand n low-mask)) 84 | (%mwrite-bignum-recurse ptr (the mem-size (+ index n-words-low)) 85 | n-words-high (ash n (- high-shift)))))) 86 | 87 | 88 | (defun mwrite-box/bignum (ptr index end-index n) 89 | "Write bignum N into memory starting at (PTR+INDEX). 90 | Assumes BOX header is already written. 91 | Return INDEX pointing to immediately after written value. 92 | 93 | ABI: writes mem-int N-WORDS, i.e. (%bignum-words N) 94 | \(if bignum is negative, writes (lognot N-WORDS) instead) 95 | followed by an array of words containing N in two's complement." 96 | (declare (type maddress ptr) 97 | (type mem-size index end-index) 98 | (type integer n)) 99 | 100 | (let ((n-words (%bignum-words n))) 101 | 102 | (check-mem-overrun ptr index end-index (mem-size+1 n-words)) 103 | 104 | (mset-int ptr index (if (< n 0) (lognot n-words) n-words)) 105 | ;; add 1, we just wrote N-WORDS prefix 106 | (incf-mem-size index) 107 | 108 | ;; optimization: directly access SBCL internal representation of BIGNUMs. 109 | ;; does not work for FIXNUMs, so we must check! 110 | ;; N may be a FIXNUM when 32-bit ABI is used on 64-bit SBCL, 111 | ;; or when MWRITE-BOX/BIGNUM is called directly. 112 | (if (typep n 'fixnum) 113 | (%mwrite-bignum-loop ptr index n-words n) 114 | 115 | #+sbcl 116 | (sb-sys:with-pinned-objects (n) 117 | (let ((src (cffi-sys:make-pointer 118 | (the sb-ext:word 119 | (+ +lisp-object-header-length+ 120 | (logand +lisp-object-address-mask+ 121 | (sb-kernel:get-lisp-obj-address n))))))) 122 | #?+hlmem/native-endianity 123 | (progn 124 | (memcpy-words ptr index src 0 n-words) 125 | (incf-mem-size index n-words)) 126 | 127 | #?-hlmem/native-endianity 128 | (dotimes (src-i n-words index) 129 | (mset-word ptr index (mget-word/native-endianity src src-i)) 130 | (incf-mem-size index)))) 131 | 132 | #-sbcl 133 | (%mwrite-bignum-recurse ptr index n-words n)))) 134 | 135 | 136 | 137 | 138 | (defun %mread-pos-bignum-loop (ptr index n-words) 139 | "Read an unsigned bignum" 140 | (declare (type maddress ptr) 141 | (type mem-size index n-words)) 142 | 143 | (let* ((bits +mem-word/bits+) 144 | (limit (the fixnum (* bits n-words))) 145 | (n 0)) 146 | (declare (type integer n)) 147 | 148 | (loop for shift from 0 below limit by bits 149 | for word = (mget-word ptr index) 150 | do 151 | (incf (the mem-size index)) 152 | (setf n (logior n (ash word shift)))) 153 | 154 | (the integer n))) 155 | 156 | 157 | (defun %mread-neg-bignum-loop (ptr index n-words) 158 | "Read a negative bignum" 159 | (declare (type maddress ptr) 160 | (type mem-size index n-words)) 161 | 162 | (when (zerop n-words) 163 | (return-from %mread-neg-bignum-loop -1)) 164 | 165 | (decf (the mem-size n-words)) 166 | 167 | (let* ((n (%mread-pos-bignum-loop ptr index n-words)) 168 | ;; read last word as negative 169 | (bits +mem-word/bits+) 170 | (limit (the fixnum (* bits n-words))) 171 | (word (mget-word ptr (mem-size+ n-words index)))) 172 | 173 | (the integer (logior n (ash (logior word #.(- -1 +mem-word/mask+)) limit))))) 174 | 175 | 176 | 177 | 178 | (defun %mread-bignum-recurse (ptr index n-words sign) 179 | (declare (type maddress ptr) 180 | (type mem-size index n-words) 181 | (type bit sign)) 182 | 183 | (if (<= n-words 16) 184 | (if (zerop sign) 185 | (%mread-pos-bignum-loop ptr index n-words) 186 | (%mread-neg-bignum-loop ptr index n-words)) 187 | 188 | (let* ((n-words-high (truncate n-words 2)) 189 | (n-words-low (- n-words n-words-high)) 190 | 191 | (n-low (%mread-bignum-recurse ptr index n-words-low 0)) 192 | (n-high (%mread-bignum-recurse ptr (mem-size+ index n-words-low) 193 | n-words-high sign)) 194 | 195 | (high-shift (the fixnum (* n-words-low +mem-word/bits+)))) 196 | 197 | #-(and) (log:trace "n-low: #x~X n-high: #x~X" n-low n-high) 198 | 199 | (logior n-low (ash n-high high-shift))))) 200 | 201 | 202 | (defun mread-box/bignum (ptr index end-index) 203 | "Read a bignum from the memory starting at (PTR+INDEX) and return it. 204 | Also returns the number of words actually written as additional value. 205 | Assumes the BOX header was read already." 206 | (declare (type maddress ptr) 207 | (type mem-size index end-index)) 208 | 209 | (check-mem-length ptr index end-index 1) 210 | 211 | (let* ((sign-n-words (mget-int ptr index)) 212 | (sign 0) 213 | (n-words sign-n-words)) 214 | 215 | (when (< sign-n-words 0) 216 | (setf sign 1 217 | n-words (lognot n-words))) 218 | 219 | ;; we just read N-WORDS prefix above 220 | (incf (the mem-size index)) 221 | 222 | (check-mem-length ptr index end-index n-words) 223 | 224 | (values 225 | (%mread-bignum-recurse ptr index n-words sign) 226 | (mem-size+ index n-words)))) 227 | 228 | 229 | 230 | 231 | 232 | -------------------------------------------------------------------------------- /mem/box/bit-vector.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;;; boxed bit-vector ;;;; 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | 25 | (defun msize-box/bit-vector (index vector) 26 | "Return the number of words needed to store bit-vector VALUE in mmap memory, 27 | not including BOX header." 28 | (declare (type bit-vector vector) 29 | (type mem-size index)) 30 | ;; 1-word length prefix, and round up required bytes to a whole word 31 | (mem-size+ index 1 (ceiling (length vector) +mem-word/bits+))) 32 | 33 | 34 | (defmacro %bit-vector-extract-byte (vector position) 35 | "Warning: evaluates VECTOR multiple times" 36 | (with-gensyms (pos) 37 | `(let ((,pos ,position)) 38 | (logior 39 | ,@(loop for i from 0 below +mem-byte/bits+ 40 | collect `(ash (aref ,vector (the ufixnum (+ ,pos ,i))) ,i)))))) 41 | 42 | 43 | (defmacro %bit-vector-insert-byte (vector position byte) 44 | "Warning: evaluates VECTOR multiple times. updates BYTE" 45 | (with-gensyms (pos) 46 | `(let ((,pos ,position)) 47 | ,@(loop for i from 0 below +mem-byte/bits+ 48 | collect `(setf (aref ,vector (the ufixnum (+ ,pos ,i))) (logand ,byte 1) 49 | ,byte (the mem-word (ash ,byte -1))))))) 50 | 51 | 52 | 53 | (defmacro %bit-vector-extract-word (vector position) 54 | "Warning: evaluates VECTOR multiple times" 55 | (with-gensyms (start end i word) 56 | `(let* ((,start (the ufixnum ,position)) 57 | (,end (the ufixnum (+ ,start +mem-word/bits+))) 58 | (,word 0)) 59 | (declare (type mem-word ,word)) 60 | (loop for ,i from ,start below ,end by +mem-byte/bits+ do 61 | (setf ,word (logior ,word (the mem-word 62 | (ash (%bit-vector-extract-byte ,vector ,i) 63 | (- ,i ,start)))))) 64 | ,word))) 65 | 66 | 67 | (defmacro %bit-vector-insert-word (vector position word) 68 | "Warning: evaluates VECTOR multiple times." 69 | (with-gensyms (start end w i) 70 | `(let* ((,start (the ufixnum ,position)) 71 | (,end (the ufixnum (+ ,start +mem-word/bits+))) 72 | (,w ,word)) 73 | (declare (type mem-word ,w)) 74 | 75 | (loop for ,i from ,start below ,end by +mem-byte/bits+ do 76 | (%bit-vector-insert-byte ,vector ,i ,w))))) 77 | 78 | 79 | 80 | 81 | (defmacro %mwrite-bit-vector (ptr index vector n-bits) 82 | "Warning: evaluates PTR, INDEX and VECTOR multiple times. Updates INDEX." 83 | ;; split N-BITS into a whole number of words and a remainder 84 | ;; works also if +msizeof-word+ is not a power of two. 85 | (with-gensyms (n end tail i word bit) 86 | `(let* ((,n (the ufixnum ,n-bits)) 87 | (,tail (the ufixnum (mod ,n +mem-word/bits+))) 88 | (,end (the ufixnum (- ,n ,tail)))) 89 | (loop for ,i from 0 below ,end by +mem-word/bits+ 90 | do 91 | (mset-word ,ptr (incf-mem-size ,index) 92 | (%bit-vector-extract-word ,vector ,i))) 93 | (unless (zerop ,tail) 94 | (let ((,word 0)) 95 | (declare (type mem-word ,word)) 96 | (loop for ,i from 0 below ,tail 97 | for ,bit = (aref ,vector (the ufixnum (+ ,i ,end))) 98 | do 99 | (setf ,word (logior ,word (the mem-word (ash ,bit ,i))))) 100 | (mset-word ,ptr (incf-mem-size ,index) ,word)))))) 101 | 102 | 103 | (defun %mread-bit-vector (ptr index vector n-bits) 104 | (declare (type maddress ptr) 105 | (type mem-size index) 106 | (type simple-bit-vector vector) 107 | (type ufixnum n-bits)) 108 | 109 | ;; split N-BITS into a whole number of words and a remainder 110 | ;; works also if +msizeof-word+ is not a power of two. 111 | (let* ((tail (the ufixnum (mod n-bits +mem-word/bits+))) 112 | (end (the ufixnum (- n-bits tail)))) 113 | (loop for i from 0 below end by +mem-word/bits+ 114 | do 115 | (let ((word (mget-word ptr (incf-mem-size index)))) 116 | (%bit-vector-insert-word vector i word))) 117 | (unless (zerop tail) 118 | (let ((word (mget-word ptr (incf-mem-size index)))) 119 | (loop for i from 0 below tail 120 | for bit = (logand word 1) 121 | do 122 | (setf (aref vector (the ufixnum (+ i end))) bit 123 | word (the mem-word (ash word -1)))))) 124 | (mem-size+1 index))) 125 | 126 | 127 | 128 | (defun mwrite-box/bit-vector (ptr index end-index vector) 129 | "Write bit-vector VECTOR into the memory starting at (+ PTR INDEX) 130 | and return the number of words written. Assumes BOX header is already written. 131 | 132 | ABI: writes element count as mem-int, followed by sequence of bits" 133 | (declare (type maddress ptr) 134 | (type mem-size index end-index) 135 | (type bit-vector vector)) 136 | 137 | (let* ((n-bits (length vector)) 138 | (n-words (mem-size+1 (ceiling n-bits +mem-word/bits+)))) 139 | 140 | (check-mem-overrun ptr index end-index n-words) 141 | 142 | (mset-int ptr index n-bits) 143 | 144 | (if (typep vector 'simple-bit-vector) 145 | (%mwrite-bit-vector ptr index vector n-bits) 146 | (%mwrite-bit-vector ptr index vector n-bits)) 147 | 148 | (mem-size+1 index))) 149 | 150 | 151 | 152 | (defun mread-box/bit-vector (ptr index end-index) 153 | "Read a bit-vector from the memory starting at (PTR+INDEX) and return it. 154 | Assumes BOX header was already read." 155 | (declare (type maddress ptr) 156 | (type mem-size index)) 157 | 158 | (let* ((n-bits (mget-int ptr index)) 159 | (n-words (mem-size+1 (ceiling n-bits +mem-word/bits+)))) 160 | 161 | (check-array-length ptr index 'bit-vector n-bits) 162 | (check-mem-length ptr index end-index n-words) 163 | 164 | (let ((vector (make-array n-bits :element-type 'bit))) 165 | (values 166 | vector 167 | (%mread-bit-vector ptr index vector n-bits))))) 168 | -------------------------------------------------------------------------------- /mem/box/complex.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | (deftype complex-sfloat () '(complex single-float)) 20 | (deftype complex-dfloat () '(complex double-float)) 21 | (deftype complex-rational () '(complex rational)) 22 | 23 | 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | ;;;; boxed COMPLEXes ;;;; 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | 28 | (declaim (inline msize-box/complex-sfloat)) 29 | 30 | (defconstant +msize-box/complex-sfloat+ (* 2 +msize-box/sfloat+)) 31 | 32 | (defun msize-box/complex-sfloat (index value) 33 | "Return the number of words needed to store a complex-sfloat VALUE in mmap memory. 34 | Does not count the space needed by BOX header." 35 | (declare (ignore value) 36 | (type mem-size index)) 37 | 38 | (mem-size+ index +msize-box/complex-sfloat+)) 39 | 40 | 41 | (defun mwrite-box/complex-sfloat (ptr index end-index value) 42 | "Reuse the memory starting at (PTR+INDEX) and write complex-sfloat VALUE into it. 43 | Assumes BOX header is already written. 44 | 45 | ABI: Writes real part, then imaginary part." 46 | (declare (type maddress ptr) 47 | (type mem-size index end-index) 48 | (type complex-sfloat value)) 49 | 50 | (let* ((n-words-real +msize-box/sfloat+) 51 | (n-words-imag +msize-box/sfloat+) 52 | (n-words (+ n-words-real n-words-imag))) 53 | (check-mem-overrun ptr index end-index n-words) 54 | 55 | (mset-t (realpart value) :sfloat ptr index) 56 | (incf-mem-size index n-words-real) 57 | (mset-t (imagpart value) :sfloat ptr index) 58 | (incf-mem-size index n-words-imag))) 59 | 60 | 61 | (defun mread-box/complex-sfloat (ptr index end-index) 62 | "Read a complex-sfloat from the memory starting at (PTR+INDEX) and return it. 63 | Assumes BOX header was already read." 64 | (declare (type maddress ptr) 65 | (type mem-size index end-index)) 66 | 67 | (let* ((n-words-real +msize-box/sfloat+) 68 | (n-words-imag +msize-box/sfloat+) 69 | (n-words (+ n-words-real n-words-imag))) 70 | (check-mem-length ptr index end-index n-words) 71 | 72 | (values 73 | (complex 74 | (the single-float (mget-t :sfloat ptr index)) 75 | (the single-float (mget-t :sfloat ptr (incf-mem-size index n-words-real)))) 76 | 77 | (incf-mem-size index n-words-imag)))) 78 | 79 | 80 | 81 | 82 | 83 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 84 | 85 | (declaim (inline msize-box/complex-dfloat)) 86 | 87 | (defconstant +msize-box/complex-dfloat+ (* 2 +msize-box/dfloat+)) 88 | 89 | (defun msize-box/complex-dfloat (index value) 90 | "Return the number of words needed to store a complex-dfloat VALUE in mmap memory. 91 | Does not count the space needed by BOX header." 92 | (declare (ignore value) 93 | (type mem-size index)) 94 | 95 | (mem-size+ index +msize-box/complex-dfloat+)) 96 | 97 | 98 | (defun mwrite-box/complex-dfloat (ptr index end-index value) 99 | "Reuse the memory starting at (PTR+INDEX) and write complex-dfloat VALUE into it. 100 | Assumes BOX header is already written. 101 | 102 | ABI: Writes real part, then imaginary part." 103 | (declare (type maddress ptr) 104 | (type mem-size index end-index) 105 | (type complex-dfloat value)) 106 | 107 | (let* ((n-words-real +msize-box/dfloat+) 108 | (n-words-imag +msize-box/dfloat+) 109 | (n-words (+ n-words-real n-words-imag))) 110 | (check-mem-overrun ptr index end-index n-words) 111 | 112 | (mset-t (realpart value) :dfloat ptr index) 113 | (incf-mem-size index n-words-real) 114 | (mset-t (imagpart value) :dfloat ptr index) 115 | (incf-mem-size index n-words-imag))) 116 | 117 | 118 | (defun mread-box/complex-dfloat (ptr index end-index) 119 | "Read a complex-dfloat from the memory starting at (PTR+INDEX) and return it. 120 | Assumes BOX header was already read." 121 | (declare (type maddress ptr) 122 | (type mem-size index end-index)) 123 | 124 | (let* ((n-words-real +msize-box/dfloat+) 125 | (n-words-imag +msize-box/dfloat+) 126 | (n-words (+ n-words-real n-words-imag))) 127 | (check-mem-length ptr index end-index n-words) 128 | 129 | (values 130 | (complex 131 | (the double-float (mget-t :dfloat ptr index)) 132 | (the double-float (mget-t :dfloat ptr (incf-mem-size index n-words-real)))) 133 | 134 | (incf-mem-size index n-words-imag)))) 135 | 136 | 137 | 138 | 139 | 140 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 141 | 142 | (defun msize-box/complex-rational (index value) 143 | "Return the number of words needed to store a complex-rational VALUE in mmap memory. 144 | Does not count the space needed by BOX header." 145 | (declare (type complex-rational value)) 146 | 147 | (msize* index (realpart value) (imagpart value))) 148 | 149 | 150 | 151 | (defun mwrite-box/complex-rational (ptr index end-index value) 152 | "Write complex-rational VALUE into the memory starting at (PTR+INDEX). 153 | Assumes BOX header is already written. 154 | 155 | ABI: Writes real part, then imaginary part." 156 | (declare (type maddress ptr) 157 | (type mem-size index end-index) 158 | (type complex-rational value)) 159 | 160 | (mwrite* ptr index end-index (realpart value) (imagpart value))) 161 | 162 | 163 | (defun mread-box/complex-rational (ptr index end-index) 164 | "Read a complex-rational from the memory starting at (PTR+INDEX) and return it. 165 | Assumes BOX header is already read." 166 | (declare (type maddress ptr) 167 | (type mem-size index end-index)) 168 | 169 | (with-mread* (realpart imagpart index) (ptr index end-index) 170 | (values 171 | (complex realpart imagpart) 172 | index))) 173 | 174 | -------------------------------------------------------------------------------- /mem/box/float.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;;; boxed SINGLE-FLOATs and DOUBLE-FLOATs ;;;; 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | (declaim (inline msize-box/sfloat msize-box/dfloat)) 25 | 26 | (defconstant +msize-box/sfloat+ +sfloat/words+) 27 | (defconstant +msize-box/dfloat+ +dfloat/words+) 28 | 29 | (defun msize-box/sfloat (index value) 30 | "Return the number of words needed to store single-float VALUE in memory, not including BOX header." 31 | (declare (ignore value) 32 | (type mem-size index)) 33 | (mem-size+ index +msize-box/sfloat+)) 34 | 35 | 36 | (defun msize-box/dfloat (index value) 37 | "Return the number of words needed to store a BOX containing double-float VALUE in memory." 38 | (declare (ignore value) 39 | (type mem-size index)) 40 | (mem-size+ index +msize-box/dfloat+)) 41 | 42 | 43 | 44 | (defun mwrite-box/sfloat (ptr index end-index value) 45 | "Write single-float VALUE into the memory starting at (+ PTR INDEX). 46 | Assumes BOX header is already written. 47 | 48 | ABI: single-float is stored raw (usually means IEEE format)" 49 | (declare (type maddress ptr) 50 | (type mem-size index end-index) 51 | (type single-float value)) 52 | 53 | (let ((n-words +msize-box/sfloat+)) 54 | (check-mem-overrun ptr index end-index n-words) 55 | 56 | (mset-t value :sfloat ptr index) 57 | (mem-size+ index n-words))) 58 | 59 | 60 | (defun mwrite-box/dfloat (ptr index end-index value) 61 | "Write double-float VALUE into the memory starting at (+ PTR INDEX). 62 | Assumes BOX header is already written. 63 | 64 | ABI: double-float is stored raw (usually means IEEE format)" 65 | (declare (type maddress ptr) 66 | (type mem-size index end-index) 67 | (type double-float value)) 68 | 69 | (let ((n-words +msize-box/dfloat+)) 70 | (check-mem-overrun ptr index end-index n-words) 71 | 72 | (mset-t value :dfloat ptr index) 73 | (mem-size+ index n-words))) 74 | 75 | 76 | (defun mread-box/sfloat (ptr index end-index) 77 | "Read a single-float from the memory starting at (PTR+INDEX) and return it. 78 | Assumes BOX header was already read." 79 | (declare (type maddress ptr) 80 | (type mem-size index)) 81 | 82 | (let ((n-words +msize-box/sfloat+)) 83 | (check-mem-length ptr index end-index n-words) 84 | 85 | (values 86 | (the single-float (mget-t :sfloat ptr index)) 87 | (mem-size+ index n-words)))) 88 | 89 | 90 | (defun mread-box/dfloat (ptr index end-index) 91 | "Read a double-float from the memory starting at (PTR+INDEX) and return it. 92 | Assumes BOX header was already read." 93 | (declare (type maddress ptr) 94 | (type mem-size index end-index)) 95 | 96 | (let ((n-words +msize-box/dfloat+)) 97 | (check-mem-length ptr index end-index n-words) 98 | 99 | (values 100 | (the double-float (mget-t :dfloat ptr index)) 101 | (mem-size+ index n-words)))) 102 | -------------------------------------------------------------------------------- /mem/box/hash-table.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;;; boxed hash-table ;;;; 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | 25 | (defun msize-box/hash-table (index htable) 26 | "Return the number of words needed to store hash-table HTABLE in mmap memory, 27 | not including BOX header." 28 | (declare (type hash-table htable) 29 | (type mem-size index)) 30 | 31 | (let ((len (hash-table-count htable))) 32 | (unless (<= len +most-positive-int+) 33 | (error "HYPERLUMINAL-MEM: hash-table too large for object store. 34 | it contains ~S entries, maximum supported is ~S entries" 35 | len +most-positive-int+))) 36 | 37 | ;; +1 to store test function, and another +1 for number of entries 38 | (incf-mem-size index 2) 39 | 40 | (loop for k being the hash-keys in htable using (hash-value v) 41 | do 42 | (setf index (msize* index k v))) 43 | index) 44 | 45 | 46 | (eval-always 47 | (define-constant-once +hash-table-tests+ #(eq eql equal equalp))) 48 | 49 | (defun mwrite-box/hash-table (ptr index end-index htable) 50 | "Write hash-table HTABLE into the memory starting at (PTR+INDEX). 51 | Return INDEX pointing to immediately after written hash-table. 52 | 53 | Assumes BOX header is already written, and that enough memory is available 54 | at (PTR+INDEX)." 55 | (declare (type maddress ptr) 56 | (type mem-size index end-index) 57 | (type hash-table htable)) 58 | 59 | (let ((len (hash-table-count htable)) 60 | (test (hash-table-test htable))) 61 | 62 | (check-mem-overrun ptr index end-index 2) 63 | 64 | (mset-int ptr index 65 | (ecase test 66 | ((eq #+clisp ext:fasthash-eq) 0) 67 | ((eql #+clisp ext:fasthash-eql) 1) 68 | ((equal #+clisp ext:fasthash-equal) 2) 69 | ((equalp) 3))) 70 | 71 | (mset-int ptr (incf-mem-size index) len) 72 | (incf-mem-size index) 73 | 74 | (loop for k being the hash-keys in htable using (hash-value v) 75 | do 76 | (setf index (mwrite* ptr index end-index k v))) 77 | 78 | index)) 79 | 80 | 81 | 82 | (defun mread-box/hash-table (ptr index end-index) 83 | "Read a hash-table from the boxed memory starting at (PTR+INDEX) and return it. 84 | Also returns as additional value INDEX pointing to immediately after read hash-table. 85 | 86 | Assumes BOX header was already read." 87 | (declare (type maddress ptr) 88 | (type mem-size index end-index)) 89 | 90 | (check-mem-length ptr index end-index 2) 91 | 92 | (let* ((hash-test-function-index (mget-int ptr index)) 93 | (len (mget-int ptr (incf-mem-size index)))) 94 | 95 | (check-type hash-test-function-index (mod #.(length +hash-table-tests+))) 96 | (incf-mem-size index) 97 | 98 | (let ((htable (make-hash-table :test (svref +hash-table-tests+ hash-test-function-index) 99 | :size len))) 100 | (loop for i from 0 below len 101 | do (with-mread* (k v new-index) (ptr index end-index) 102 | (setf index (the mem-size new-index) 103 | (gethash k htable) v))) 104 | 105 | (values htable index)))) 106 | -------------------------------------------------------------------------------- /mem/box/list.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;;; boxed list ;;;; 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | 25 | (defun msize-box/list (index list) 26 | "Return the number of words needed to store LIST in mmap memory, not including BOX header." 27 | (declare (type list list)) 28 | 29 | ;; +1 to store list length 30 | (incf-mem-size index) 31 | 32 | ;; note: list may end with a dotted pair 33 | (loop for cons = list then (rest cons) 34 | while (consp cons) 35 | do 36 | (setf index (msize index (first cons))) 37 | finally 38 | (when cons 39 | (setf index (msize index cons)))) 40 | index) 41 | 42 | 43 | 44 | 45 | (defun mwrite-box/list (ptr index end-index list) 46 | "Write LIST into the memory starting at (PTR+INDEX). 47 | Return INDEX pointing to immediately after written list. 48 | 49 | Assumes BOX header is already written, and that enough memory is available 50 | at (PTR+INDEX)." 51 | (declare (type maddress ptr) 52 | (type mem-size index end-index) 53 | (type list list)) 54 | 55 | ;; note: written length is (length list) for proper lists, 56 | ;; but is (lognot (length list)) for lists ending with a dotted pair 57 | 58 | (check-mem-overrun ptr index end-index 1) 59 | 60 | (let ((orig-index index) ;; we write list length later 61 | (len 0) 62 | (mwrite #'mwrite)) 63 | (declare (type mem-int len)) 64 | 65 | (incf-mem-size index) ;; leave space for list length 66 | 67 | (loop for cons = list then (rest cons) 68 | while (consp cons) 69 | for e = (first cons) 70 | do 71 | (setf index (the mem-size (funcall mwrite ptr index end-index e))) 72 | (incf len) 73 | finally 74 | (when cons 75 | (setf index (the mem-size (funcall mwrite ptr index end-index cons))) 76 | (incf len) 77 | ;; dotted pair: store (lognot len) 78 | (setf len (lognot len)))) 79 | 80 | ;; finally write list length 81 | (mset-int ptr orig-index len) 82 | index)) 83 | 84 | 85 | 86 | (defun mread-box/list (ptr index end-index) 87 | "Read a list from the memory starting at (PTR+INDEX) and return it. 88 | Also returns as additional value the INDEX pointing to immediately after the list read. 89 | 90 | Assumes BOX header was already read." 91 | (declare (type maddress ptr) 92 | (type mem-size index end-index)) 93 | 94 | (check-mem-length ptr index end-index 1) 95 | 96 | (let* ((len (mget-int ptr index)) 97 | (dotted-pair (< len 0)) 98 | (list nil) 99 | (prev nil) 100 | (tail nil)) 101 | 102 | 103 | (when dotted-pair 104 | (setf len (lognot len))) 105 | 106 | (incf-mem-size index) 107 | 108 | (unless (zerop len) 109 | (setf list (stmx.lang::cons^ nil nil) 110 | tail list) 111 | 112 | (let ((mread #'mread)) 113 | (loop for i from 0 below len 114 | do 115 | (multiple-value-bind (e e-index) (funcall mread ptr index end-index) 116 | (setf index (the mem-size e-index)) 117 | (let ((cons (stmx.lang::cons^ e nil))) 118 | (setf prev tail 119 | (rest tail) cons 120 | tail cons))))) 121 | 122 | ;; adjust for dotted pair 123 | (when (and dotted-pair prev tail) 124 | (setf (rest prev) (first tail)) 125 | (stmx.lang::free-cons^ tail))) 126 | 127 | (values 128 | (prog1 (rest list) 129 | (stmx.lang::free-cons^ list)) 130 | index))) 131 | -------------------------------------------------------------------------------- /mem/box/pathname.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;;; boxed pathname ;;;; 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | 25 | (defun msize-box/pathname (index path) 26 | "Return the number of words needed to store pathname PATH in mmap memory, 27 | not including BOX header." 28 | (declare (type pathname path) 29 | (type mem-size index)) 30 | 31 | (let ((host (pathname-host path :case :common)) 32 | (default-host (pathname-host *default-pathname-defaults* :case :common))) 33 | 34 | (msize* index 35 | (if (eq host default-host) nil host) 36 | (pathname-device path :case :common) 37 | (pathname-directory path :case :common) 38 | (pathname-name path :case :common) 39 | (pathname-type path :case :common) 40 | (pathname-version path)))) 41 | 42 | 43 | 44 | 45 | 46 | (defun mwrite-box/pathname (ptr index end-index path) 47 | "write pathname PATH into the memory starting at (PTR+INDEX). 48 | Assumes BOX header is already written." 49 | (declare (type maddress ptr) 50 | (type mem-size index end-index) 51 | (type pathname path)) 52 | 53 | (let ((host (pathname-host path :case :common)) 54 | (default-host (pathname-host *default-pathname-defaults* :case :common))) 55 | 56 | (mwrite* ptr index end-index 57 | (if (eq host default-host) nil host) 58 | (pathname-device path :case :common) 59 | (pathname-directory path :case :common) 60 | (pathname-name path :case :common) 61 | (pathname-type path :case :common) 62 | (pathname-version path)))) 63 | 64 | 65 | (defun mread-box/pathname (ptr index end-index) 66 | "Read a pathname from the memory starting at (PTR+INDEX) and return it. 67 | Assumes BOX header was already read." 68 | (declare (type maddress ptr) 69 | (type mem-size index)) 70 | 71 | (with-mread* (host device directory name type version new-index) (ptr index end-index) 72 | (values 73 | (make-pathname 74 | :host (or host (pathname-host *default-pathname-defaults* :case :common)) 75 | :device device :directory directory 76 | :name name :type type :version version :case :common) 77 | new-index))) 78 | -------------------------------------------------------------------------------- /mem/box/ratio.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;;; boxed RATIOs ;;;; 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | 25 | (defun msize-box/ratio (index value) 26 | "Return the number of words needed to store a BOX containing ratio VALUE in mmap memory. 27 | Does not count the space needed by BOX header." 28 | (declare (type ratio value) 29 | (type mem-size index)) 30 | 31 | (msize* index (numerator value) (denominator value))) 32 | 33 | 34 | (defun mwrite-box/ratio (ptr index end-index value) 35 | "Write ratio VALUE into the memory starting at (PTR+INDEX). 36 | Assumes BOX header is already written. 37 | 38 | ABI: Writes numerator, then denominator." 39 | (declare (type maddress ptr) 40 | (type mem-size index end-index) 41 | (type ratio value)) 42 | 43 | (let ((index (mwrite ptr index end-index (numerator value)))) 44 | 45 | (mwrite ptr index end-index (denominator value)))) 46 | 47 | 48 | 49 | (defun mread-box/ratio (ptr index end-index) 50 | "Read a ratio from the memory starting at (PTR+INDEX) and return it. 51 | Assumes BOX header is already read." 52 | (declare (type maddress ptr) 53 | (type mem-size index end-index)) 54 | 55 | (multiple-value-bind (numerator index) (mread ptr index end-index) 56 | (multiple-value-bind (denominator index) (mread ptr index end-index) 57 | (values 58 | (/ (the integer numerator) (the integer denominator)) 59 | index)))) 60 | -------------------------------------------------------------------------------- /mem/box/symbol.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | ;;;; SYMBOLs ;;;; 22 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 23 | 24 | 25 | 26 | (defun %package-words (index pkg) 27 | "Return the number of words needed to store package PKG in mmap memory." 28 | 29 | (if (or (eq pkg nil) 30 | (eq pkg +package-keyword+) 31 | (eq pkg +package-common-lisp+) 32 | (eq pkg +package-common-lisp-user+)) 33 | ;; unboxed package reference 34 | (incf-mem-size index) 35 | ;; untagged package name: mem-int length, then utf-8 chars 36 | (msize-box/string-utf-8 index (package-name pkg)))) 37 | 38 | 39 | (declaim (inline %mwrite-package %mread-package)) 40 | 41 | (defun %mwrite-package (ptr index end-index pkg) 42 | "Write package PKG into the memory starting at (PTR+INDEX). 43 | Return INDEX pointing to immediately after written words. 44 | 45 | ABI: package is stored as package reference if possible, otherwise as package name." 46 | (declare (type maddress ptr) 47 | (type mem-size index end-index) 48 | (type (or null package) pkg)) 49 | 50 | (let ((tag +mem-tag/package+) 51 | (vid +mem-pkg/common-lisp+)) 52 | (cond 53 | ((eq pkg +package-keyword+) (setf vid +mem-pkg/keyword+)) 54 | ((eq pkg +package-common-lisp+)) 55 | ((eq pkg +package-common-lisp-user+) (setf vid +mem-pkg/common-lisp-user+)) 56 | 57 | ((eq pkg nil) (setf tag +mem-tag/symbol+ 58 | vid +mem-sym/nil+)) 59 | (t 60 | (return-from %mwrite-package 61 | (mwrite-box/string-utf-8 ptr index end-index (package-name pkg))))) 62 | 63 | (check-mem-overrun ptr index end-index 1) 64 | (mset-tag-and-vid ptr index tag vid) 65 | (mem-size+1 index))) 66 | 67 | 68 | (defun %mread-package (ptr index end-index) 69 | "Read a package from the memory starting at (PTR+INDEX). 70 | Return the package and INDEX pointing to immediately after words read. 71 | 72 | ABI: package is stored as package reference if possible, otherwise as package name." 73 | (declare (type maddress ptr) 74 | (type mem-size index end-index)) 75 | 76 | (check-mem-length ptr index end-index 1) 77 | (with-tag-and-vid (tag vid) (ptr index) 78 | (if (= +mem-tag/symbol+ tag) 79 | (values 80 | (ecase vid 81 | (#.+mem-pkg/keyword+ +package-keyword+) 82 | (#.+mem-pkg/common-lisp+ +package-common-lisp+) 83 | (#.+mem-pkg/common-lisp-user+ +package-common-lisp-user+)) 84 | (mem-size+1 index)) 85 | 86 | ;; actually return the package name... (find-symbol) below accepts it 87 | (mread-box/string-utf-8 ptr index end-index)))) 88 | 89 | 90 | (defun msize-box/symbol (index sym) 91 | "Return the number of words needed to store symbol SYM in mmap memory. 92 | Does not count the space needed by BOX header." 93 | (declare (type symbol sym) 94 | (type mem-size index)) 95 | 96 | ;; assume symbol does NOT have predefined representation 97 | 98 | (let ((index (%package-words index (symbol-package sym)))) 99 | (msize-box/string-utf-8 index (symbol-name sym)))) 100 | 101 | 102 | (defun mwrite-box/symbol (ptr index end-index sym) 103 | "Write symbol SYM into the memory starting at (PTR+INDEX). 104 | Return INDEX pointing to immediately after words written. 105 | 106 | ABI: symbol is stored as package followed by symbol name. 107 | To store symbol as unboxed reference, use MSET-UNBOXED or MWRITE." 108 | (declare (type maddress ptr) 109 | (type mem-size index end-index) 110 | (type symbol sym)) 111 | 112 | ;; assume symbol does NOT have predefined representation 113 | (setf index (%mwrite-package ptr index end-index (symbol-package sym))) 114 | 115 | (mwrite-box/string-utf-8 ptr index end-index (symbol-name sym))) 116 | 117 | 118 | (defvar *mread-symbol-not-found-handler* 119 | (lambda (sym-name pkg-name) 120 | (error "Deserialization error: symbol ~A not found in package ~A" sym-name pkg-name))) 121 | 122 | (defun mread-box/symbol (ptr index end-index) 123 | "Read a symbol from the memory starting at (PTR+INDEX) and return it. 124 | Return the symbol and the INDEX pointing to immediately after the words read. 125 | Assumes BOX header is already read. 126 | 127 | ABI: symbol is assumed to be stored as package followed by symbol name. 128 | To read symbol stored as unboxed reference, use MGET-UNBOXED or MREAD." 129 | (declare (type maddress ptr) 130 | (type mem-size index end-index)) 131 | 132 | ;; assume symbol does NOT have predefined representation 133 | 134 | (multiple-value-bind (pkg index) (%mread-package ptr index end-index) 135 | (multiple-value-bind (sym-name index) (mread-box/string-utf-8 ptr index end-index) 136 | (values 137 | (if pkg 138 | (or (find-symbol sym-name pkg) 139 | (let ((pkg-name (if (typep pkg 'package) (package-name pkg) pkg))) 140 | (funcall *mread-symbol-not-found-handler* 141 | sym-name pkg-name))) 142 | (make-symbol (the simple-string sym-name))) 143 | index)))) 144 | -------------------------------------------------------------------------------- /mem/box/vector.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | (enable-#?-syntax) 20 | 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | ;;;; boxed vector ;;;; 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | 25 | 26 | (deftype array1 (&optional (element-type '*)) 27 | `(and (array ,element-type (*)) 28 | (not (or string base-string bit-vector)))) 29 | 30 | (defmacro %the-array1 (a type simple) 31 | (if simple 32 | `(the (simple-array ,(if type type '*) 1) ,a) 33 | `(the (and (not simple-array) (array ,(if type type '*) 1)) ,a))) 34 | 35 | 36 | (defmacro %loop-array1-unboxed (func a type) 37 | (ecase func 38 | (mwrite 39 | (with-gensym e 40 | `(progn 41 | (check-mem-overrun ptr index end-index len) 42 | (loop for ,e across ,a do 43 | (mset-unboxed ptr index (the ,type ,e)) 44 | (incf-mem-size index))))) 45 | (msize 46 | `(incf-mem-size index len)))) 47 | 48 | 49 | (defmacro %loop-array1-t (func a type) 50 | (with-gensym e 51 | `(loop for ,e across ,a do 52 | (setf index 53 | ,(ecase func 54 | (mwrite `(mwrite ptr index end-index (the ,type ,e))) 55 | (msize `(msize index (the ,type ,e)))))))) 56 | 57 | 58 | (defmacro %loop-array1 (func a type simple) 59 | `(cond 60 | ((mem-int=integer-type ,type) 61 | (%loop-array1-unboxed ,func (%the-array1 ,a mem-int ,simple) mem-int)) 62 | 63 | #?+hlmem/mem-int>fixnum 64 | ((eq ,type 'fixnum) 65 | (%loop-array1-unboxed ,func (%the-array1 ,a fixnum ,simple) fixnum)) 66 | 67 | ((mem-int>integer-type ,type) 68 | (%loop-array1-unboxed ,func (%the-array1 ,a * ,simple) mem-int)) 69 | 70 | #?+hlmem/sfloat/inline 71 | ((eq 'single-float ,type) 72 | (%loop-array1-unboxed ,func (%the-array1 ,a single-float ,simple) single-float)) 73 | 74 | #?+hlmem/dfloat/inline 75 | ((eq 'double-float ,type) 76 | (%loop-array1-unboxed ,func (%the-array1 ,a double-float ,simple) double-float)) 77 | 78 | ((eq t ,type) 79 | (%loop-array1-t ,func (%the-array1 ,a t ,simple) t)) 80 | 81 | (t 82 | (%loop-array1-t ,func (%the-array1 ,a * ,simple) t)))) 83 | 84 | 85 | 86 | (defun msize-box/vector (index vector) 87 | "Return the number of words needed to store VECTOR in mmap memory, 88 | not including BOX header." 89 | (declare (type array1 vector) 90 | (type mem-size index)) 91 | 92 | (let ((len (array-total-size vector)) 93 | (type (array-element-type vector)) 94 | (simple (typep vector 'simple-array))) 95 | 96 | #-(and) (log:trace ptr index array) 97 | 98 | (unless (< len (- +most-positive-int+ index)) 99 | (error "HYPERLUMINAL-MEM: vector too large for object store. 100 | it contains ~S elements, but at most ~S words are available at index ~S" 101 | len (- +most-positive-int+ index 1) index)) 102 | 103 | ;; 1 word to store vector length 104 | (incf-mem-size index) 105 | 106 | (if simple 107 | (%loop-array1 msize vector type t) 108 | ;; specializing on the element-type of non-simple arrays 109 | ;; is usually not needed, as they are slow in any case 110 | (%loop-array1-t msize vector t))) 111 | index) 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | (defun mwrite-box/vector (ptr index end-index vector) 120 | "Write VECTOR into the memory starting at (PTR+INDEX). 121 | Return number of words actually written. 122 | 123 | Assumes BOX header is already written, and that enough memory is available 124 | at (PTR+INDEX)." 125 | (declare (type maddress ptr) 126 | (type mem-size index end-index) 127 | (type array1 vector)) 128 | 129 | (check-mem-overrun ptr index end-index 1) 130 | 131 | (let ((type (array-element-type vector)) 132 | (len (length vector))) 133 | 134 | (mset-int ptr index (the mem-int len)) 135 | (incf-mem-size index) 136 | 137 | (if (typep vector 'simple-array) 138 | (%loop-array1 mwrite vector type t) 139 | ;; specializing on the element-type of non-simple arrays 140 | ;; is usually not needed, as they are slow in any case 141 | (%loop-array1-t mwrite vector t))) 142 | index) 143 | 144 | 145 | (defun mread-box/vector (ptr index end-index) 146 | "Read a vector from the memory starting at (PTR+INDEX) and return it. 147 | Also returns number of words actually read as additional value. 148 | 149 | Assumes BOX header was already read." 150 | (declare (type maddress ptr) 151 | (type mem-size index end-index)) 152 | 153 | (check-mem-length ptr index end-index 1) 154 | 155 | (let* ((len (mget-int ptr index))) 156 | 157 | (check-array-length ptr index 'vector len) 158 | 159 | (incf-mem-size index) 160 | 161 | (let ((vector (the simple-vector (make-array len)))) 162 | (dotimes (i len) 163 | (multiple-value-bind (e e-index) (mread ptr index end-index) 164 | (setf (svref vector i) e 165 | index (the mem-size e-index)))) 166 | 167 | (values vector index)))) 168 | -------------------------------------------------------------------------------- /mem/defs.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | (deftype maddress () 'ffi-address) 19 | 20 | (deftype ufixnum () '(and fixnum (integer 0))) 21 | 22 | 23 | (eval-always 24 | (declaim (type keyword +chosen-word-type+)) 25 | (defconstant +chosen-word-type+ (choose-word-type)) 26 | 27 | (defconstant +native-word-type+ (ffi-native-type-name +chosen-word-type+)) 28 | 29 | (declaim (inline sfloat-word-type dfloat-word-type half-dfloat-word-type)) 30 | 31 | (defun parse-type (type) 32 | (case type 33 | (:sfloat :float) ;; this is the ONLY code mapping :sfloat to a CFFI type 34 | (:dfloat :double) ;; this is the ONLY code mapping :dfloat to a CFFI type 35 | (:byte :unsigned-char) ;; this is the ONLY code mapping :byte to a CFFI type 36 | (:word +chosen-word-type+) ;; :word is mapped to a CFFI type by (choose-word-type) 37 | (:sfloat-word (sfloat-word-type)) ;; an unsigned integer as wide as :sfloat 38 | (:dfloat-word (dfloat-word-type)) ;; an unsigned integer as wide as :dfloat 39 | (:half-dfloat-word (half-dfloat-word-type)) ;; an unsigned integer half as wide as :dfloat 40 | (otherwise type))) 41 | 42 | 43 | (defun choose-float-word-type (type lisp-type &key half-width) 44 | (let ((types '(:unsigned-char :unsigned-short :unsigned-int 45 | :unsigned-long :unsigned-long-long))) 46 | (loop 47 | with float-size fixnum = (/ (ffi-sizeof (parse-type type)) (if half-width 2 1)) 48 | for type in types 49 | do 50 | (when (= float-size (ffi-sizeof type)) 51 | (return type)) 52 | finally 53 | (error "cannot compile STMX: no CFFI integer type as wide as ~A~S (~S bytes), 54 | tried ~S" (if half-width "half " "") lisp-type float-size types)))) 55 | 56 | (defconstant +sfloat-type+ (parse-type :sfloat)) 57 | (defconstant +dfloat-type+ (parse-type :dfloat)) 58 | (defconstant +sfloat-word-type+ (choose-float-word-type :sfloat 'single-float)) 59 | (defconstant +dfloat-word-type+ (choose-float-word-type :dfloat 'double-dloat)) 60 | (defconstant +half-dfloat-word-type+ (choose-float-word-type :dfloat 'double-dloat 61 | :half-width t)) 62 | 63 | (defun sfloat-word-type () 64 | +sfloat-word-type+) 65 | 66 | (defun dfloat-word-type () 67 | +dfloat-word-type+) 68 | 69 | (defun half-dfloat-word-type () 70 | +half-dfloat-word-type+)) 71 | 72 | 73 | 74 | 75 | ;; not really used, but handy 76 | #-(and) 77 | (eval-always 78 | (cffi:defctype mfloat #.(parse-type :sfloat)) 79 | (cffi:defctype mdouble #.(parse-type :dfloat)) 80 | (cffi:defctype mbyte #.(parse-type :byte)) 81 | (cffi:defctype mword #.(parse-type :word))) 82 | 83 | 84 | 85 | (defmacro %msizeof (type) 86 | "Wrapper for (CFFI-SYS:%FOREIGN-TYPE-SIZE), interprets :SFLOAT :DFLOAT :BYTE AND :WORD" 87 | `(ffi-sizeof ,(if (constantp type) 88 | (parse-type type) 89 | `(parse-type ,type)))) 90 | 91 | (defmacro msizeof (type) 92 | "Wrapper for (%MSIZEOF), computes (CFFI:%FOREIGN-TYPE-SIZE) at compile time whenever possible" 93 | (if (constantp type) 94 | (%msizeof (eval type)) 95 | `(%msizeof ,type))) 96 | 97 | 98 | 99 | (eval-always 100 | (defconstant +msizeof-sfloat+ (msizeof :sfloat)) 101 | (defconstant +msizeof-dfloat+ (msizeof :dfloat)) 102 | (defconstant +msizeof-half-dfloat+ (/ +msizeof-dfloat+ 2)) 103 | (defconstant +msizeof-byte+ (msizeof :byte)) 104 | (defconstant +msizeof-word+ (msizeof :word)) 105 | (defconstant +sfloat/words+ (ceiling +msizeof-sfloat+ +msizeof-word+)) 106 | (defconstant +dfloat/words+ (ceiling +msizeof-dfloat+ +msizeof-word+)) 107 | (defconstant +half-dfloat/words+ (ceiling +msizeof-half-dfloat+ +msizeof-word+)) 108 | 109 | (set-feature :hlmem/sfloat/words +sfloat/words+) 110 | (set-feature :hlmem/dfloat/words +dfloat/words+) 111 | (set-feature :hlmem/half-dfloat/words +half-dfloat/words+)) 112 | 113 | 114 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 115 | 116 | 117 | (defmacro with-mem-bytes ((var-name n-bytes &optional n-bytes-var) &body body) 118 | `(with-ffi-mem (,var-name ,n-bytes ,@(when n-bytes-var `(,n-bytes-var))) 119 | ,@body)) 120 | 121 | 122 | (defmacro with-mem-words ((ptr n-words &optional n-words-var) 123 | &body body) 124 | "Bind PTR to N-WORDS words of raw memory while executing BODY. 125 | Raw memory is automatically deallocated when BODY terminates." 126 | 127 | (let* ((n-const? (constantp n-words)) 128 | (n-words (if n-const? (eval n-words) n-words)) 129 | (n-bytes (if n-const? 130 | (* n-words +msizeof-word+) 131 | `(the mem-word (* ,(or n-words-var n-words) +msizeof-word+))))) 132 | 133 | `(let ,(when n-words-var `((,n-words-var ,n-words))) 134 | (with-mem-bytes (,ptr ,n-bytes) 135 | ,@body)))) 136 | 137 | 138 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 | 140 | 141 | -------------------------------------------------------------------------------- /mem/endianity.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | (enable-#?-syntax) 19 | 20 | 21 | (eval-always 22 | (defun %detect-native-endianity () 23 | (with-mem-words (p 1) 24 | (let ((little-endian 0) 25 | (big-endian 0)) 26 | 27 | (loop for i from 0 below +msizeof-word+ 28 | for bits = (logand (1+ i) +mem-byte/mask+) do 29 | 30 | (setf little-endian (logior little-endian (ash bits (* i +mem-byte/bits+))) 31 | big-endian (logior bits (ash big-endian +mem-byte/bits+))) 32 | 33 | (mset-byte p i bits)) 34 | 35 | (let ((endianity (%mget-t :word p 0))) 36 | (cond 37 | ((eql endianity little-endian) :little-endian) 38 | ((eql endianity big-endian) :big-endian) 39 | (t (error "cannot build HYPERLUMINAL-MEM: unsupported architecture. 40 | CPU word endianity is #x~X, expecting either #x~X (little-endian) or #x~X (big-endian)" 41 | endianity little-endian big-endian)))))))) 42 | 43 | (eval-always 44 | (defconstant +mem/initial-native-endianity+ (%detect-native-endianity))) 45 | 46 | 47 | (eval-always 48 | (defun choose-endianity () 49 | "Choose the serialized format ABI between little endian or big endian. 50 | 51 | By default, Hyperluminal-MEM uses little-endian ABI. 52 | 53 | It is possible to compile Hyperluminal-MEM for a different endianity by adding 54 | an appropriate entry in the global variable `*FEATURES*` **before** compiling 55 | and loading Hyperluminal-MEM. 56 | 57 | To force native endianity: 58 | (pushnew :hyperluminal-mem/endianity/native *features*) 59 | To force non-native endianity: 60 | (pushnew :hyperluminal-mem/endianity/inverted *features*) 61 | To force little-endian ABI: 62 | (pushnew :hyperluminal-mem/endianity/little *features*) 63 | To force big-endian ABI: 64 | (pushnew :hyperluminal-mem/endianity/big *features*)" 65 | 66 | ;;search for :hyperluminal-mem/endianity/{little,big,native,inverted} *features* 67 | (let ((endianity (find-hldb-option/keyword 'endianity))) 68 | (case endianity 69 | (:native +mem/initial-native-endianity+) 70 | (:inverted (if (eq +mem/initial-native-endianity+ :little-endian) 71 | :big-endian 72 | :little-endian)) 73 | ((nil :little) :little-endian) 74 | (:big :big-endian) 75 | (otherwise 76 | (error "cannot build HYPERLUMINAL-MEM: unsupported option ~S in ~S, 77 | expecting one of ~S" 78 | (intern (concat-symbols 'hyperluminal-mem/endianity/ endianity) :keyword) 79 | '*features* 80 | '(:hyperluminal-mem/endianity/little 81 | :hyperluminal-mem/endianity/big 82 | :hyperluminal-mem/endianity/native 83 | :hyperluminal-mem/endianity/inverted))))))) 84 | 85 | 86 | 87 | (eval-always 88 | (defconstant +mem/chosen-endianity+ (choose-endianity))) 89 | 90 | #-abcl 91 | (eval-always 92 | (defconstant +mem/native-endianity+ +mem/initial-native-endianity+)) 93 | 94 | #+abcl 95 | (eval-always 96 | ;; on ABCL, we set the endianity on java.nio.ByteBuffer, used to implement raw memory: 97 | ;; no need for explicit conversions, so endianity always appears to be "native" 98 | (defconstant +mem/native-endianity+ +mem/chosen-endianity+) 99 | (setf (ffi-endianity) +mem/chosen-endianity+)) 100 | 101 | 102 | (eval-always 103 | (set-feature :cpu/little-endian (eql +mem/native-endianity+ :little-endian)) 104 | (set-feature :hlmem/native-endianity (eql +mem/chosen-endianity+ +mem/native-endianity+))) 105 | 106 | 107 | (fmakunbound '%maybe-invert-endianity) 108 | (fmakunbound 'maybe-invert-endianity) 109 | 110 | #?+hlmem/native-endianity 111 | (progn 112 | (fmakunbound '%maybe-invert-endianity/integer) 113 | (defmacro maybe-invert-endianity/integer (type value) 114 | (declare (ignore type)) 115 | value)) 116 | 117 | #?-hlmem/native-endianity 118 | (progn 119 | (defun %maybe-invert-endianity/integer (type value) 120 | (let ((size (%msizeof (parse-type type)))) 121 | (case size 122 | (1 value) 123 | (2 (swap-bytes/2 value)) 124 | (4 (swap-bytes/4 value)) 125 | (8 (swap-bytes/8 value)) 126 | (otherwise 127 | (funcall (find-swap-bytes/n size) value))))) 128 | 129 | (defmacro maybe-invert-endianity/integer (type value) 130 | (if (constantp type) 131 | (let ((size (%msizeof (eval `(parse-type ,type))))) 132 | (case size 133 | (1 value) 134 | (2 `(swap-bytes/2 ,value)) 135 | (4 `(swap-bytes/4 ,value)) 136 | (8 `(swap-bytes/8 ,value)) 137 | (otherwise 138 | `(,(find-swap-bytes/n size) ,value)))) 139 | `(%maybe-invert-endianity/integer ,type ,value)))) 140 | 141 | 142 | -------------------------------------------------------------------------------- /mem/ffi-late.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | (enable-#?-syntax) 19 | 20 | (declaim (inline malloc)) 21 | (defun malloc (n-bytes) 22 | "Allocate N-BYTES of raw memory and return raw pointer to it. 23 | The obtained memory must be freed manually: call MFREE on it when no longer needed." 24 | (ffi-mem-alloc n-bytes)) 25 | 26 | 27 | (declaim (inline malloc-words)) 28 | (defun malloc-words (n-words) 29 | "Allocate N-WORDS words of raw memory and return raw pointer to it. 30 | Usually more handy than MALLOC since almost all Hyperluminal-MEM functions 31 | count and expect memory lengths in words, not in bytes." 32 | (declare (type mem-size n-words)) 33 | (malloc (* n-words +msizeof-word+))) 34 | 35 | 36 | (declaim (inline mfree)) 37 | (defun mfree (ptr) 38 | "Deallocate a block of raw memory previously obtained with MALLOC or MALLOC-WORDS." 39 | (declare (type maddress ptr)) 40 | (ffi-mem-free ptr)) 41 | 42 | 43 | (defun !hex (value) 44 | (format t "#x~X" value)) 45 | 46 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; memset ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 | 48 | 49 | (defun !memset-bytes (ptr start-byte n-bytes fill-byte) 50 | (declare (type maddress ptr) 51 | (type (unsigned-byte 8) fill-byte) 52 | (type mem-word start-byte n-bytes)) 53 | 54 | #-abcl 55 | (when (> n-bytes 32) 56 | (unless (zerop start-byte) (setf ptr (cffi-sys:inc-pointer ptr start-byte))) 57 | (osicat-posix:memset ptr fill-byte n-bytes) 58 | (return-from !memset-bytes nil)) 59 | 60 | (let ((i start-byte) 61 | (end (the mem-word (+ start-byte n-bytes)))) 62 | (declare (type mem-word i end)) 63 | (loop while (< i end) 64 | do 65 | (mset-byte ptr i fill-byte) 66 | (incf i)))) 67 | 68 | 69 | (defun memset-words (ptr start-index n-words fill-word) 70 | (declare (optimize (speed 3) (safety 0) (debug 1)) 71 | (type maddress ptr) 72 | (type mem-word fill-word) 73 | (type mem-size start-index n-words)) 74 | 75 | (symbol-macrolet ((i start-index) 76 | (end end-index)) 77 | 78 | #?+hlmem/fast-memset 79 | (fast-memset-words ptr i n-words fill-word) 80 | 81 | #?-hlmem/fast-memset 82 | (progn 83 | ;; ARM has no ptr+INDEX*SCALE+OFFSET addressing, 84 | #?+(and hlmem/fast-mem (or x86 x86-64)) 85 | (progn 86 | 87 | (loop while (>= n-words 8) 88 | do 89 | (fast-mset-word fill-word ptr i :offset (* 0 +msizeof-word+)) 90 | (fast-mset-word fill-word ptr i :offset (* 1 +msizeof-word+)) 91 | (fast-mset-word fill-word ptr i :offset (* 2 +msizeof-word+)) 92 | (fast-mset-word fill-word ptr i :offset (* 3 +msizeof-word+)) 93 | (fast-mset-word fill-word ptr i :offset (* 4 +msizeof-word+)) 94 | (fast-mset-word fill-word ptr i :offset (* 5 +msizeof-word+)) 95 | (fast-mset-word fill-word ptr i :offset (* 6 +msizeof-word+)) 96 | (fast-mset-word fill-word ptr i :offset (* 7 +msizeof-word+)) 97 | (incf-mem-size i 8) 98 | (decf-mem-size n-words 8)) 99 | 100 | (loop while (> n-words 0) 101 | do 102 | (fast-mset-word fill-word ptr i) 103 | (incf-mem-size i) 104 | (decf-mem-size n-words))) 105 | 106 | #?-(and hlmem/fast-mem (or x86 x86-64)) 107 | (progn 108 | #+(and sbcl (not x86)) 109 | ;; 32-bit x86 is register-starved 110 | (loop while (>= n-words 4) 111 | do 112 | (let ((i1 (mem-size+ i 1)) 113 | (i2 (mem-size+ i 2)) 114 | (i3 (mem-size+ i 3))) 115 | (mset-word ptr i fill-word) 116 | (mset-word ptr i1 fill-word) 117 | (mset-word ptr i2 fill-word) 118 | (mset-word ptr i3 fill-word) 119 | (incf-mem-size i 4) 120 | (decf-mem-size n-words 4))) 121 | 122 | (loop while (> n-words 0) 123 | do 124 | (mset-word ptr i fill-word) 125 | (incf-mem-size i) 126 | (decf-mem-size n-words)))))) 127 | 128 | #?+hlmem/fast-memset 129 | (define-compiler-macro memset-words (&whole form ptr start-index n-words fill-word) 130 | (if (constantp n-words) 131 | `(fast-memset-words ,ptr ,start-index ,(eval n-words) ,fill-word) 132 | form)) 133 | 134 | 135 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; mzero ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 136 | 137 | (declaim (inline mzero-bytes)) 138 | (defun !mzero-bytes (ptr start-byte n-bytes) 139 | (declare (type maddress ptr) 140 | (type mem-word start-byte n-bytes)) 141 | (!memset-bytes ptr 0 start-byte n-bytes)) 142 | 143 | 144 | #?+(or hlmem/fast-memset (and hlmem/fast-mem (or x86 x86-64))) 145 | (declaim (inline mzero-words)) 146 | (defun mzero-words (ptr start-index n-words) 147 | (declare (type maddress ptr) 148 | (type mem-size start-index n-words)) 149 | 150 | #?-(or hlmem/fast-memset (and hlmem/fast-mem (or x86 x86-64))) 151 | (progn 152 | #-abcl 153 | (when (> n-words 32) 154 | (unless (zerop start-index) 155 | (setf ptr (cffi-sys:inc-pointer ptr (* start-index +msizeof-word+)))) 156 | (osicat-posix:memset ptr 0 (* n-words +msizeof-word+)) 157 | (return-from mzero-words nil))) 158 | 159 | (memset-words ptr 0 start-index n-words)) 160 | 161 | 162 | #?+hlmem/fast-memset 163 | (define-compiler-macro mzero-words (&whole form ptr start-index n-words) 164 | (if (constantp n-words) 165 | `(fast-memset-words ,ptr ,start-index ,(eval n-words) 0) 166 | form)) 167 | 168 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; memcpy ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 169 | 170 | (defun !memcpy-bytes (dst dst-byte src src-byte n-bytes) 171 | (declare (type maddress dst src) 172 | (type mem-word dst-byte src-byte n-bytes)) 173 | (symbol-macrolet ((si src-byte) 174 | (di dst-byte)) 175 | #-abcl 176 | (when (> n-bytes 32) 177 | (unless (zerop di) (setf dst (cffi-sys:inc-pointer dst di))) 178 | (unless (zerop si) (setf src (cffi-sys:inc-pointer src si))) 179 | (osicat-posix:memcpy dst src n-bytes) 180 | (return-from !memcpy-bytes nil)) 181 | 182 | (dotimes (i n-bytes) 183 | (mset-byte dst (mem-size+ i di) 184 | (mget-byte src (mem-size+ i si)))))) 185 | 186 | (defun memcpy-words (dst dst-index src src-index n-words) 187 | (declare (type maddress dst src) 188 | (type mem-size dst-index src-index n-words)) 189 | 190 | (symbol-macrolet ((si src-index) 191 | (di dst-index)) 192 | 193 | #?+hlmem/fast-memcpy 194 | (fast-memcpy-words dst di src si n-words) 195 | 196 | #?-hlmem/fast-memcpy 197 | (progn 198 | #-abcl ;; no osicat-posix on ABCL yet :-( 199 | (when (> n-words #+sbcl 64 #-sbcl 16) 200 | (unless (zerop di) (setf dst (cffi-sys:inc-pointer dst (* di +msizeof-word+)))) 201 | (unless (zerop si) (setf src (cffi-sys:inc-pointer src (* si +msizeof-word+)))) 202 | (osicat-posix:memcpy dst src (* n-words +msizeof-word+)) 203 | (return-from memcpy-words nil)) 204 | 205 | (loop with end = (mem-size+ si n-words) 206 | while (< si end) 207 | do 208 | (mset-word dst di (mget-word src si)) 209 | (incf-mem-size si) 210 | (incf-mem-size di))))) 211 | 212 | 213 | #?+hlmem/fast-memcpy 214 | (define-compiler-macro memcpy-words (&whole form dst dst-index src src-index n-words) 215 | (if (constantp n-words) 216 | `(fast-memcpy-words ,dst ,dst-index ,src ,src-index ,(eval n-words)) 217 | form)) 218 | -------------------------------------------------------------------------------- /mem/int.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | (enable-#?-syntax) 19 | 20 | 21 | (deftype mem-int () `( signed-byte ,+mem-int/bits+)) 22 | (deftype mem-uint () `(unsigned-byte ,+mem-int/value-bits+)) 23 | 24 | 25 | ;; use the fastest available implementation of mword=>mem-int 26 | ;; 27 | ;; deferred from fast-mem.lisp, it needs #?+hlmem/mem-int=fixnum 28 | ;; computed in constants.lisp 29 | (eval-always 30 | (let ((sym (get-fbound-symbol 'hlm-asm (stringify 'fast-mword/ +msizeof-word+ '=>fixnum)))) 31 | 32 | ;; hlm-asm:fast-mword=>fixnum is usable for mword=>mem-int 33 | ;; only if mem-int equals fixnum 34 | (set-feature 'hlmem/mword=>mem-int 35 | ;; we store sym in the features! 36 | (if (get-feature :hlmem/mem-int=fixnum) sym nil)))) 37 | 38 | 39 | 40 | (defmacro mword=>mem-int (word) 41 | #?+hlmem/mword=>mem-int 42 | `(,(get-feature :hlmem/mword=>mem-int) ,word) 43 | 44 | #?-hlmem/mword=>mem-int 45 | (with-gensym x 46 | `(locally 47 | (declare (optimize (safety 0) (speed 3))) 48 | (let ((,x ,word)) 49 | (the mem-int (- (logand +mem-int/value-mask+ ,x) 50 | (logand +mem-int/sign-mask+ ,x))))))) 51 | 52 | 53 | (defmacro mem-int=>mword (value) 54 | #?+hlmem/mem-int=fixnum 55 | `(logior +mem-int/flag+ 56 | ;; on some archs, SBCL is smart enough to optimize away this 57 | #+(and sbcl (or x86 x86-64 arm)) (logand +mem-word/mask+ ,value) 58 | #-(and sbcl (or x86 x86-64 arm)) (logand +mem-int/mask+ ,value)) 59 | 60 | #?-hlmem/mem-int=fixnum 61 | `(logior +mem-int/flag+ 62 | (logand +mem-int/mask+ ,value))) 63 | 64 | 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | 67 | 68 | (declaim (inline mget-uint)) 69 | (defun mget-uint (ptr index) 70 | "Return the two's complement value of mem-int stored at (PTR+INDEX), 71 | ignoring any sign bit" 72 | (declare (type maddress ptr) 73 | (type mem-size index)) 74 | 75 | (the mem-uint (logand +mem-int/value-mask+ (mget-word ptr index)))) 76 | 77 | 78 | (declaim (inline mget-int)) 79 | (defun mget-int (ptr index) 80 | "Return the mem-int stored at (PTR+INDEX)" 81 | (declare (type maddress ptr) 82 | (type mem-size index)) 83 | 84 | (mword=>mem-int (mget-word ptr index))) 85 | 86 | 87 | (declaim (inline mset-int)) 88 | (defun mset-int (ptr index value) 89 | "Write mem-int VALUE into the memory at (PTR+INDEX)" 90 | (declare (type maddress ptr) 91 | (type mem-size index) 92 | (type mem-int value) 93 | (optimize (safety 0) (speed 3))) 94 | 95 | (mset-word ptr index (mem-int=>mword value)) 96 | t) 97 | 98 | (defsetf mget-int mset-int) 99 | 100 | 101 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 102 | 103 | 104 | #?+hlmem/fast-mem 105 | (define-compiler-macro mget-int (&whole form ptr index) 106 | (if (constantp index) 107 | `(mword=>mem-int 108 | (fast-mget-word (the maddress ,ptr) 0 :offset (* +msizeof-word+ ,index))) 109 | form)) 110 | 111 | #?+hlmem/fast-mem 112 | (define-compiler-macro mset-int (&whole form ptr index value) 113 | (if (constantp index) 114 | (with-gensym p 115 | ;; preserve evaluation order 116 | `(let ((,p (the maddress ,ptr))) 117 | (fast-mset-word (mem-int=>mword (the mem-int ,value)) 118 | ,p 0 :offset (* +msizeof-word+ ,index)) 119 | t)) 120 | form)) 121 | 122 | #?-hlmem/fast-mem 123 | ;; sanity 124 | (eval-always 125 | (setf (compiler-macro-function 'mget-int) nil 126 | (compiler-macro-function 'mset-int) nil)) 127 | -------------------------------------------------------------------------------- /mem/lang.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | (eval-when (:compile-toplevel :load-toplevel) 19 | 20 | ;; convenience to mix CPU type with other features 21 | (set-feature 'x86 #+x86 t #-x86 nil) 22 | ;; this relies on trivial-features to set #+x86-64 correctly on all compilers 23 | (set-feature 'x86-64 #+x86-64 t #-x86-64 nil) 24 | 25 | (defun find-hldb-option/string (prefix) 26 | (declare (type symbol prefix)) 27 | (let* ((prefix-name (stringify 'hyperluminal-mem/ prefix '/)) 28 | (prefix-len (length prefix-name))) 29 | (loop for f in *features* 30 | for fname = (if (symbolp f) (symbol-name f) "") 31 | when (and (> (length fname) prefix-len) 32 | (string-equal fname prefix-name :end1 prefix-len)) 33 | return (subseq fname prefix-len)))) 34 | 35 | (defun find-hldb-option/integer (prefix) 36 | (let ((f (find-hldb-option/string prefix))) 37 | (when f 38 | (parse-integer f)))) 39 | 40 | (defun find-hldb-option/keyword (prefix) 41 | (let ((f (find-hldb-option/string prefix))) 42 | (when f 43 | (intern f :keyword)))) 44 | 45 | (defun choose-word-type () 46 | "Choose the file format and ABI between 32 or 64 bit - and possibly more in the future. 47 | 48 | By default, Hyperluminal-MEM file format and ABI is autodetected to match 49 | Lisp idea of CFFI-SYS pointers: 50 | * 32 bit when CFFI-SYS pointers are 32 bit, 51 | * 64 bit when CFFI-SYS pointers are 64 bit, 52 | * and so on... 53 | 54 | In other words, `mem-word` is normally autodetected to match the width 55 | of underlying CPU registers (exposed through CFFI-SYS foreign-type :pointer) 56 | and `+msizeof-word+` is set accordingly. 57 | 58 | It is possible to override such autodetection by adding an appropriate entry 59 | in the global variable `*FEATURES*` **before** compiling and loading Hyperluminal-MEM. 60 | Doing so disables autodetection and either tells Hyperluminal-MEM the desired size 61 | of `mem-word`, in alternative, the CFFI-SYS type it should use for `mem-word`. 62 | 63 | For example, to force 64 bit (= 8 bytes) file format and ABI even on 32-bit systems, 64 | execute the following form before compiling and loading Hyperluminal-MEM: 65 | (pushnew :hyperluminal-mem/word-size/8 *features*) 66 | 67 | on the other hand, to force 32 bit (= 4 bytes) file format and ABI, 68 | execute the form 69 | (pushnew :hyperluminal-mem/word-size/4 *features*) 70 | 71 | in both cases, the Hyperluminal-MEM internal function (choose-word-type) 72 | will recognize the override and define `mem-word` and `+msizeof-word+` 73 | to match a CFFI-SYS unsigned integer type having the specified size 74 | among the following candidates: 75 | :unsigned-char 76 | :unsigned-short 77 | :unsigned-int 78 | :unsigned-long 79 | :unsigned-long-long 80 | In case it does not find a type with the requested size, it will raise an error. 81 | 82 | Forcing the same value that would be autodetected is fine and harmless. 83 | Also, the chosen type must be 32 bits wide or more, but there is no upper limit: 84 | Hyperluminal-MEM is designed to automatically support 64 bits systems, 85 | 128 bit systems, and anything else that will exist in the future. 86 | It even supports 'unusual' configurations where the size of `mem-word` 87 | is not a power of two (ever heard of 36-bit CPUs?). 88 | 89 | For the far future (which arrives surprisingly quickly in software) 90 | where CFFI-SYS will know about further unsigned integer types, 91 | it is also possible to explicitly specify the type to use 92 | by executing a form like 93 | (pushnew :hyperluminal-mem/word-type/ *features*) 94 | as for example: 95 | (pushnew :hyperluminal-mem/word-type/unsigned-long-long *features*) 96 | 97 | Hyperluminal-MEM will honour such override, intern the type name 98 | to convert it to a keyword, use it as the definition of `mem-word`, 99 | and derive `+msizeof-word+` from it." 100 | 101 | ;;search for :hyperluminal-mem/word-type/ in *features* 102 | (let ((type (find-hldb-option/keyword 'word-type))) 103 | (when type 104 | (return-from choose-word-type (the symbol type)))) 105 | 106 | ;; search for :hyperluminal-mem/word-size/ in *features* 107 | (let ((size (or (find-hldb-option/integer 'word-size) 108 | ;; default is pointer size 109 | (ffi-sizeof :pointer))) 110 | (types (loop for type in '(:unsigned-char :unsigned-short :unsigned-int 111 | :unsigned-long :unsigned-long-long) 112 | collect (cons (ffi-sizeof type) type)))) 113 | 114 | (let ((type (rest (assoc (the fixnum size) types)))) 115 | (when type 116 | (return-from choose-word-type (the symbol type)))) 117 | 118 | (error "Hyperluminal-MEM: failed to find a CFFI-SYS unsigned integer type 119 | having size = ~S. Tried the following types: ~S" size types)))) 120 | 121 | 122 | -------------------------------------------------------------------------------- /mem/magic.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | (eval-always 19 | (defun string-to-code-vector (s) 20 | (declare (type string s)) 21 | (let* ((n (length s)) 22 | (v (make-array n))) 23 | (dotimes (i n) 24 | (setf (svref v i) (char-code (char s i)))) 25 | v))) 26 | 27 | (define-global *endian-magic* 28 | (string-to-code-vector (if (eql +mem/chosen-endianity+ :little-endian) "hldb" "HLDB"))) 29 | 30 | (define-global *x-endian-magic* 31 | (string-to-code-vector (if (eql +mem/chosen-endianity+ :little-endian) "HLDB" "hldb"))) 32 | 33 | 34 | (eval-always 35 | (defun compact-sizeof (sizeof) 36 | (declare (type (integer 0) sizeof)) 37 | 38 | (macrolet ((%compact-sizeof (sizeof) 39 | `(let* ((bits% (integer-length ,sizeof)) 40 | ;; bump powers-of-2 to the previous interval 41 | (bits (- bits% (if (zerop (logand sizeof (1- ,sizeof))) 1 0))) 42 | (shift (- bits 3)) 43 | (mask (1- (ash 1 shift)))) 44 | 45 | (if (zerop (logand sizeof mask)) 46 | (the fixnum 47 | (+ (* 4 bits) -12 48 | (ash sizeof (- shift)))) 49 | nil)))) 50 | (if (typep sizeof 'fixnum) 51 | (if (<= sizeof 8) 52 | sizeof 53 | (%compact-sizeof (the fixnum sizeof))) 54 | (%compact-sizeof (the bignum sizeof)))))) 55 | 56 | 57 | (eval-always 58 | (defun uncompact-sizeof (csizeof) 59 | (declare (type (unsigned-byte 8) csizeof)) 60 | (when (<= csizeof 8) 61 | (return-from uncompact-sizeof csizeof)) 62 | 63 | (let* ((mod-4 (logand csizeof 3)) 64 | (power-of-2 (1- (ash csizeof -2)))) 65 | 66 | ;;(log:info csizeof power-of-2 mod-4) 67 | (ash (+ 4 mod-4) power-of-2)))) 68 | 69 | 70 | 71 | 72 | (define-global *magic-write-list* 73 | `((4 abi-major-version ,(first +hlmem-abi-version+)) 74 | (5 abi-minor-version ,(second +hlmem-abi-version+)) 75 | (6 abi-patch-version ,(third +hlmem-abi-version+)) 76 | (7 bits-per-tag ,+mem-tag/bits+) 77 | (8 compact-sizeof-word ,(compact-sizeof +msizeof-word+) ,+msizeof-word+) 78 | (9 compact-sizeof-single-float ,(compact-sizeof +msizeof-sfloat+) ,+msizeof-sfloat+) 79 | (10 compact-sizeof-double-float ,(compact-sizeof +msizeof-dfloat+) ,+msizeof-dfloat+) 80 | (11 bits-lost-per-mem-int ,(- +mem-word/bits+ +mem-int/bits+)) 81 | (12 unused 0) 82 | (13 unused 0) 83 | (14 unused 0) 84 | (15 unused 0))) 85 | 86 | 87 | (define-global *magic-read-list* 88 | (loop for x in *magic-write-list* 89 | unless (third x) 90 | do (error "HYPERLUMINAL-MEM compile error. 91 | The constant ~A = ~S cannot be represented as a compressed size. 92 | Please fix the customization in \"constants.lisp\" before recompiling." 93 | (subseq (symbol-name (second x)) 8) (fourth x)) 94 | 95 | unless (member (second x) '(abi-minor-version abi-patch-version unused)) 96 | collect x) 97 | 98 | "When opening an HLDB file or exchanging HLMEM serialized data with another process, 99 | we do not check ABI-MINOR-VERSION and ABI-PATCH-VERSION: 100 | they are allowed to differ between data and compiled library") 101 | 102 | 103 | (define-global *magic* 104 | (concatenate 'vector *endian-magic* 105 | (mapcar #'third *magic-write-list*))) 106 | 107 | (define-global *zero-magic* (make-array (length *magic*) :initial-element 0)) 108 | 109 | (defun mwrite-magic (ptr index end-index) 110 | (declare (type maddress ptr) 111 | (type mem-size index end-index)) 112 | 113 | (let* ((n-bytes (length *magic*)) 114 | (n-words (ceiling n-bytes +msizeof-word+)) 115 | (byte-index (* index +msizeof-word+))) 116 | (check-mem-overrun ptr index end-index n-words) 117 | 118 | (loop for i from 0 below n-bytes do 119 | (setf (mget-byte ptr (+ i byte-index)) (svref *magic* i))) 120 | (+ index n-words))) 121 | 122 | 123 | (defun mread-magic (ptr index end-index) 124 | (declare (type maddress ptr) 125 | (type mem-size index end-index)) 126 | 127 | (let* ((n-bytes (length *magic*)) 128 | (n-words (ceiling n-bytes +msizeof-word+)) 129 | (byte-index (* index +msizeof-word+)) 130 | (magic (make-array n-bytes))) 131 | 132 | (check-mem-length ptr index end-index n-words) 133 | 134 | (loop for i from 0 below n-bytes do 135 | (setf (svref magic i) (mget-byte ptr (+ i byte-index)))) 136 | 137 | (when (equalp magic *zero-magic*) 138 | (return-from mread-magic nil)) 139 | 140 | (let ((endian-magic (subseq magic 0 (length *endian-magic*)))) 141 | 142 | (unless (equalp endian-magic *endian-magic*) 143 | 144 | (let ((list (mapcar #'code-char (coerce endian-magic 'list))) 145 | (n-list (mapcar #'code-char (coerce *endian-magic* 'list)))) 146 | 147 | (error "HYPERLUMINAL-MEM: unsupported file format. 148 | expecting magic sequence (~{~S~^ ~}), found (~{~S~^ ~})~A" 149 | n-list list 150 | (if (equalp endian-magic *x-endian-magic*) 151 | " 152 | file was created on a system with opposite endianity" 153 | ""))))) 154 | 155 | (loop for (i name expected) in *magic-read-list* 156 | for value = (svref magic i) 157 | unless (eql value expected) do 158 | (error "HYPERLUMINAL-MEM: unsupported file format. expecting ~S = ~S, found ~S" 159 | name expected value)) 160 | 161 | (+ index n-words))) 162 | 163 | 164 | -------------------------------------------------------------------------------- /mem/mem.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | (enable-#?-syntax) 19 | 20 | 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | ;; if available, use fast-mread and fast-mwrite 24 | ;; 25 | ;; fast-mword=>mem-int must be defined later (in int.lisp) 26 | ;; because it needs #?+hlmem/mem-int=fixnum computed in constants.lisp 27 | (eval-always 28 | (let* ((fast-mread (get-fbound-symbol 'hlm-asm (stringify 'fast-mread/ +msizeof-word+))) 29 | (fast-mwrite (get-fbound-symbol 'hlm-asm (stringify 'fast-mwrite/ +msizeof-word+))) 30 | (fast-mem (and fast-mread fast-mwrite))) 31 | 32 | (set-feature :hlmem/fast-mem (not (null fast-mem))) 33 | (if fast-mem 34 | (progn 35 | (defmacro fast-mget-word/native-endianity (ptr index 36 | &key (scale +msizeof-word+) (offset 0)) 37 | `(,fast-mread ,ptr ,index :scale ,scale :offset ,offset)) 38 | (defmacro fast-mset-word/native-endianity (value ptr index 39 | &key (scale +msizeof-word+) (offset 0)) 40 | "Warning: returns no values" 41 | `(,fast-mwrite ,value ,ptr ,index :scale ,scale :offset ,offset)) 42 | 43 | ;; honour +mem/chosen-endianity+ ! 44 | (defmacro fast-mget-word (ptr index &key (scale +msizeof-word+) (offset 0)) 45 | `(maybe-invert-endianity/integer :word 46 | (,fast-mread ,ptr ,index :scale ,scale :offset ,offset))) 47 | (defmacro fast-mset-word (value ptr index &key (scale +msizeof-word+) (offset 0)) 48 | "Warning: returns no values" 49 | `(,fast-mwrite (maybe-invert-endianity/integer :word ,value) 50 | ,ptr ,index :scale ,scale :offset ,offset))) 51 | ;; sanity 52 | (progn 53 | (fmakunbound 'fast-mget-word/native-endianity) 54 | (fmakunbound 'fast-mset-word/native-endianity) 55 | (fmakunbound 'fast-mget-word) 56 | (fmakunbound 'fast-mset-word))))) 57 | 58 | 59 | ;; if available, use fast-memcpy 60 | (eval-always 61 | (let ((fast-memcpy (get-fbound-symbol 'hlm-asm (stringify 'fast-memcpy/ +msizeof-word+)))) 62 | 63 | (set-feature :hlmem/fast-memcpy (not (null fast-memcpy))) 64 | (if fast-memcpy 65 | (defmacro fast-memcpy-words (dst dst-index src src-index n-words 66 | &key 67 | (dst-scale +msizeof-word+) (dst-offset 0) 68 | (src-scale +msizeof-word+) (src-offset 0)) 69 | `(progn 70 | (,fast-memcpy ,dst ,dst-index ,src ,src-index ,n-words 71 | :dst-scale ,dst-scale :dst-offset ,dst-offset 72 | :src-scale ,src-scale :src-offset ,src-offset) 73 | nil)) 74 | ;; sanity 75 | (fmakunbound 'fast-memcpy-words)))) 76 | 77 | 78 | ;; if available, use fast-memset 79 | (eval-always 80 | (let ((fast-memset (get-fbound-symbol 'hlm-asm (stringify 'fast-memset/ +msizeof-word+)))) 81 | 82 | (set-feature :hlmem/fast-memset (not (null fast-memset))) 83 | (if fast-memset 84 | (defmacro fast-memset-words (ptr index n-words fill-word 85 | &key (scale +msizeof-word+) (offset 0)) 86 | `(progn 87 | ;; honour +mem/chosen-endianity+ ! 88 | (,fast-memset ,ptr ,index ,n-words 89 | (maybe-invert-endianity/integer :word ,fill-word) 90 | :scale ,scale :offset ,offset) 91 | nil)) 92 | ;; sanity 93 | (fmakunbound 'fast-memset-words)))) 94 | 95 | 96 | 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | 99 | 100 | (eval-always 101 | (defmacro mget-t/native-endianity (type ptr word-index) 102 | #?+hlmem/fast-mem 103 | (when (eq +chosen-word-type+ (parse-type type)) 104 | (return-from mget-t/native-endianity 105 | `(fast-mget-word/native-endianity ,ptr ,word-index))) 106 | ;; common case 107 | `(%mget-t ,type ,ptr (the #+sbcl mem-word #-sbcl t 108 | (* ,word-index +msizeof-word+)))) 109 | (defmacro mset-t/native-endianity (value type ptr word-index) 110 | #?+hlmem/fast-mem 111 | (when (eq +chosen-word-type+ (parse-type type)) 112 | (return-from mset-t/native-endianity 113 | `(fast-mset-word/native-endianity ,value ,ptr ,word-index))) 114 | ;; common case 115 | `(%mset-t ,value ,type ,ptr (the #+sbcl mem-word #-sbcl t 116 | (* ,word-index +msizeof-word+)))) 117 | 118 | (defmacro mget-t (type ptr word-index) 119 | (let ((type (parse-type type)) 120 | (byte-offset `(the #+sbcl mem-word #-sbcl t 121 | (* ,word-index +msizeof-word+)))) 122 | (case type 123 | (#.+sfloat-type+ `(mget-sfloat ,ptr ,byte-offset)) 124 | (#.+dfloat-type+ `(mget-dfloat ,ptr ,byte-offset)) 125 | (otherwise 126 | `(maybe-invert-endianity/integer 127 | ,type (mget-t/native-endianity ,type ,ptr ,word-index)))))) 128 | (defmacro mset-t (value type ptr word-index) 129 | (let ((type (parse-type type)) 130 | (byte-offset `(the #+sbcl mem-word #-sbcl t 131 | (* ,word-index +msizeof-word+)))) 132 | (case type 133 | (#.+sfloat-type+ `(mset-sfloat ,value ,ptr ,byte-offset)) 134 | (#.+dfloat-type+ `(mset-dfloat ,value ,ptr ,byte-offset)) 135 | (otherwise 136 | `(mset-t/native-endianity 137 | (maybe-invert-endianity/integer ,type ,value) ,type ,ptr ,word-index)))))) 138 | 139 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 140 | 141 | 142 | (eval-always 143 | (defmacro mget-word/native-endianity (ptr word-index) 144 | `(mget-t/native-endianity :word ,ptr ,word-index)) 145 | (defmacro mset-word/native-endianity (ptr word-index value) 146 | "Warning: evaluates VALUE before the other arguments!" 147 | `(mset-t/native-endianity ,value :word ,ptr ,word-index)) 148 | (defsetf mget-word/native-endianity mset-word/native-endianity) 149 | 150 | (defmacro mget-word (ptr word-index) 151 | `(mget-t :word ,ptr ,word-index)) 152 | (defmacro mset-word (ptr word-index value) 153 | "Warning: evaluates VALUE before the other arguments!" 154 | `(mset-t ,value :word ,ptr ,word-index)) 155 | (defsetf mget-word mset-word)) 156 | 157 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 158 | -------------------------------------------------------------------------------- /mem/mvar.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | (defstruct (mvar (:include stmx:tvar)) 20 | "a memory-mapped transactional variable (mvar) is the smallest unit of persistent, 21 | transactional memory. it contains a single value that can be read or written during a transaction 22 | using ($-slot var) and (setf ($-slot var) value). 23 | 24 | The value of each mvar modified during a transaction is written to memory-mapped persistent store 25 | while committing. 26 | 27 | mvars are seldom used directly, since persistent transactional objects (mobjs) 28 | wrap them with a more convenient interface: you can read and write normally 29 | the slots of a persistent transactional object (with slot-value, accessors ...), 30 | and behind the scenes the slots will be stored in mvars." 31 | 32 | (slot-address 0 :type mem-size) ;; address of this mvar in store's area allocated to parent obj 33 | (box-address 0 :type mem-size) ;; address of boxed memory, if needed, allocated to this mvar 34 | (box-n-words 0 :type mem-size) ;; length of boxed memory, if needed, allocated to this mvar 35 | 36 | (parent-obj nil :type t #-(and)(or null mobject))) 37 | -------------------------------------------------------------------------------- /mem/object/ghash-table.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | ;;;; read and write hash table STMX.UTIL:GHASH-TABLE ;;;; 20 | ;;;; and its transactional version STMX.UTIL:THASH-TABLE ;;;; 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | (enable-#?-syntax) 24 | 25 | 26 | #?-(and (symbol :stmx.util :ghash-table-test) 27 | (symbol :stmx.util :ghash-table-hash)) 28 | (log:warn "Found an old version of STMX, disabling (de)serialization 29 | of ~A:~A, ~A:~A and their subclasses. 30 | Upgrade to STMX 2.0.1 or later to re-enable it." 31 | 'stmx.util 'ghash-table 'stmx.util 'gmap) 32 | 33 | 34 | #?+(and (symbol :stmx.util :ghash-table-test) 35 | (symbol :stmx.util :ghash-table-hash)) 36 | (progn 37 | (defmethod msize-object ((obj ghash-table) index) 38 | (declare (type mem-size index)) 39 | 40 | (setf index (msize* index 41 | (ghash-table-test obj) 42 | (ghash-table-hash obj) 43 | (ghash-table-count obj))) 44 | (do-ghash (key value) obj 45 | (setf index (msize* index key value))) 46 | index) 47 | 48 | 49 | (defmethod mwrite-object ((obj ghash-table) ptr index end-index) 50 | (declare (type mem-size index end-index)) 51 | 52 | (setf index (mwrite* ptr index end-index 53 | (ghash-table-test obj) 54 | (ghash-table-hash obj) 55 | (ghash-table-count obj))) 56 | (do-ghash (key value) obj 57 | (setf index (mwrite* ptr index end-index key value))) 58 | index) 59 | 60 | 61 | ;; we currently do NOT allow deserializing arbitrary functions as GHASH-TABLE predicates: 62 | ;; it would allow a malicious remote user to execute arbitrary code! 63 | (define-global *ghash-table-trusted-test-list* 64 | '(eq eql equal equalp = fixnum= char= char-equal string= string-equal)) 65 | 66 | 67 | (define-global *ghash-table-trusted-hash-list* 68 | ;; also allow STMX.UTIL:SXHASH-EQUALP if it exists 69 | '(sxhash identity #?+(symbol stmx.util sxhash-equalp) stmx.util:sxhash-equalp)) 70 | 71 | 72 | (defun mread-object/ghash-table (type ptr index end-index) 73 | (declare (type symbol type) 74 | (type mem-size index end-index)) 75 | 76 | (with-mread* (test hash n index) (ptr index end-index) 77 | 78 | (unless (member test *ghash-table-trusted-test-list* :test #'eq) 79 | (error "HYPERLUMINAL-MEM: refusing to use untrusted ~S ~S value ~S, 80 | expecting one of the trusted values ~S" type :test test *ghash-table-trusted-test-list*)) 81 | (unless (member hash *ghash-table-trusted-hash-list* :test #'eq) 82 | (error "HYPERLUMINAL-MEM: refusing to use untrusted ~S ~S value ~S, 83 | expecting one of the trusted values ~S" type :hash hash *ghash-table-trusted-hash-list*)) 84 | 85 | (check-type n mem-uint) 86 | 87 | (let ((obj (make-instance type :test test :hash hash :initial-capacity n))) 88 | (declare (type ghash-table obj)) 89 | 90 | (dotimes (i n) 91 | (with-mread* (key value new-index) (ptr index end-index) 92 | (setf (get-ghash obj key) value) 93 | (setf index new-index))) 94 | 95 | (values obj index)))) 96 | 97 | 98 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 99 | ;;;; read GHASH-TABLE ;;;; 100 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 101 | 102 | 103 | (defmethod mread-object ((type (eql 'ghash-table)) ptr index end-index 104 | &key &allow-other-keys) 105 | (declare (type mem-size index end-index)) 106 | 107 | (mread-object/ghash-table type ptr index end-index)) 108 | 109 | 110 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 111 | ;;;; read THASH-TABLE ;;;; 112 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 113 | 114 | (defmethod mread-object ((type (eql 'thash-table)) ptr index end-index 115 | &key &allow-other-keys) 116 | (declare (type mem-size index end-index)) 117 | 118 | (mread-object/ghash-table type ptr index end-index))) 119 | 120 | -------------------------------------------------------------------------------- /mem/object/gmap.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | ;;;; read and write sorted map STMX.UTIL:RBMAP ;;;; 20 | ;;;; and its transactional version STMX.UTIL:TMAP ;;;; 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | (enable-#?-syntax) 24 | 25 | 26 | #?+(and (symbol :stmx.util :ghash-table-test) 27 | (symbol :stmx.util :ghash-table-hash)) 28 | (progn 29 | (defmethod msize-object ((obj gmap) index) 30 | (declare (type mem-size index)) 31 | 32 | (setf index (msize* index (gmap-pred obj) (gmap-count obj))) 33 | (do-gmap (key value) obj 34 | (setf index (msize* index key value))) 35 | index) 36 | 37 | 38 | (defmethod mwrite-object ((obj gmap) ptr index end-index) 39 | (declare (type mem-size index end-index)) 40 | 41 | (setf index (mwrite* ptr index end-index (gmap-pred obj) (gmap-count obj))) 42 | (do-gmap (key value) obj 43 | (setf index (mwrite* ptr index end-index key value))) 44 | index) 45 | 46 | 47 | ;; we currently do NOT allow deserializing arbitrary functions as RBMAP predicates: 48 | ;; it would allow a malicious remote user to execute arbitrary code! 49 | (define-global *gmap-trusted-pred-list* 50 | '(< > fixnum< fixnum> char< char> string< string>)) 51 | 52 | 53 | 54 | (defun mread-object/gmap (type ptr index end-index) 55 | (declare (type symbol type) 56 | (type maddress ptr) 57 | (type mem-size index end-index)) 58 | 59 | (with-mread* (pred n index) (ptr index end-index) 60 | 61 | (unless (member pred *gmap-trusted-pred-list* :test #'eq) 62 | (error "HYPERLUMINAL-MEM: refusing to use untrusted ~S ~S value ~S, 63 | expecting one of the trusted values ~S" type :pred pred *gmap-trusted-pred-list*)) 64 | 65 | (check-type n mem-uint) 66 | 67 | (let ((obj (make-instance type :pred pred))) 68 | (declare (type gmap obj)) 69 | (dotimes (i n) 70 | (with-mread* (key value new-index) (ptr index end-index) 71 | (setf (get-gmap obj key) value) 72 | (setf index new-index))) 73 | 74 | (values obj index)))) 75 | 76 | 77 | 78 | 79 | 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | ;;;; read RBMAP ;;;; 82 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 83 | 84 | 85 | (defmethod mread-object ((type (eql 'rbmap)) ptr index end-index 86 | &key &allow-other-keys) 87 | (declare (type mem-size index end-index)) 88 | 89 | (mread-object/gmap type ptr index end-index)) 90 | 91 | 92 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 93 | ;;;; read TMAP ;;;; 94 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 95 | 96 | (defmethod mread-object ((type (eql 'tmap)) ptr index end-index 97 | &key &allow-other-keys) 98 | (declare (type mem-size index end-index)) 99 | 100 | (mread-object/gmap type ptr index end-index))) 101 | 102 | -------------------------------------------------------------------------------- /mem/object/tcell.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | ;;;; read and write STMX.UTIL:TCELL ;;;; 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | 22 | 23 | ;; short version :) 24 | (decl-mserializable-class tcell 25 | :slots (stmx.util::value) 26 | :new-instance (tcell)) 27 | 28 | 29 | ;; medium version... for comparison 30 | #| 31 | (undecl-mlist-class-direct-slots 'tcell) 32 | (decl-mlist-class-slots tcell :slots (stmx.util::value)) 33 | (decl-msize-class tcell :slots (stmx.util::value)) 34 | (decl-mwrite-class tcell :slots (stmx.util::value)) 35 | (decl-mread-class tcell :slots (stmx.util::value) :new-instance (tcell)) 36 | |# 37 | 38 | 39 | ;; and long version too. 40 | #| 41 | ;; remove the optional method MLIST-CLASS-DIRECT-SLOTS, 42 | ;; invoked only at compile time by DECL-M...-CLASS macros 43 | (undecl-mlist-class-direct-slots 'tcell) 44 | 45 | (defmethod mlist-class-slots ((class (eql 'tcell))) 46 | "Optional method, invoked only at compile time by DECL-M...-CLASS macros" 47 | '(stmx.util::value)) 48 | 49 | (defmethod msize-object ((c tcell) index) 50 | (declare (type mem-size index)) 51 | 52 | (msize index (_ c value))) 53 | 54 | 55 | (defmethod mwrite-object ((c tcell) ptr index end-index) 56 | (declare (type mem-size index end-index)) 57 | 58 | (mwrite ptr index end-index (_ c value))) 59 | 60 | 61 | (defmethod mread-object ((type (eql 'tcell)) ptr index end-index &key) 62 | (declare (type mem-size index end-index)) 63 | 64 | (multiple-value-bind (value index) (mread ptr index end-index) 65 | (values (tcell value) index))) 66 | |# 67 | -------------------------------------------------------------------------------- /mem/object/tstack.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | ;;;; read and write STMX.UTIL:TSTACK ;;;; 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 21 | 22 | 23 | ;; short version :) 24 | (decl-mserializable-class tstack 25 | :slots (stmx.util::top) 26 | :new-instance (tstack)) 27 | 28 | ;; medium version... for comparison 29 | #| 30 | (undecl-mlist-class-direct-slots 'tstack) 31 | (decl-mlist-class-slots tstack :slots (stmx.util::top)) 32 | (decl-msize-class tstack :slots (stmx.util::top)) 33 | (decl-mwrite-class tstack :slots (stmx.util::top)) 34 | (decl-mread-class tstack :slots (stmx.util::top) :new-instance (tstack)) 35 | |# 36 | 37 | 38 | ;; and long version too. 39 | #| 40 | (undecl-mlist-class-direct-slots 'tstack) 41 | 42 | (defmethod mlist-class-slots ((class (eql 'tstack))) 43 | "Optional method, invoked only at compile time by DECL-M...-CLASS macros" 44 | '(stmx.util::top)) 45 | 46 | (defmethod msize-object ((obj tstack) index) 47 | (declare (type mem-size index)) 48 | 49 | (msize index (_ obj top))) 50 | 51 | 52 | (defmethod mwrite-object ((obj tstack) ptr index end-index) 53 | (declare (type mem-size index end-index)) 54 | 55 | (mwrite ptr index end-index (_ obj top))) 56 | 57 | 58 | (defmethod mread-object ((type (eql 'tstack)) ptr index end-index &key) 59 | (declare (type mem-size index end-index)) 60 | 61 | (multiple-value-bind (top index) (mread ptr index end-index) 62 | (let ((obj (tstack))) 63 | (setf (_ obj top) top) 64 | (values obj index)))) 65 | |# 66 | -------------------------------------------------------------------------------- /mem/package.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | ;;;; * HYPERLUMINAL-MEM 17 | 18 | (in-package :cl-user) 19 | 20 | (stmx.lang:enable-#?-syntax) 21 | 22 | (defpackage #:hyperluminal-mem 23 | 24 | (:nicknames #:hlm-mem #:hlmem) 25 | 26 | (:use #:cl #:hyperluminal-mem-lang #:hyperluminal-mem-ffi) 27 | 28 | (:import-from #:stmx.lang 29 | 30 | #:eval-always #:enable-#?-syntax #:get-feature 31 | #:set-feature #:set-features 32 | 33 | 34 | #:define-global #:define-constant-once 35 | #:with-gensym #:with-gensyms) 36 | 37 | (:import-from #:stmx 38 | #:+unbound-tvar+) 39 | 40 | (:import-from #:stmx.util 41 | 42 | #:fixnum< #:fixnum> #:fixnum= 43 | 44 | #:_ #:tcell #:tcons #:tlist #:tstack #:tfifo 45 | 46 | #:tmap #:rbmap #:gmap #:gmap-pred #:gmap-count 47 | #:get-gmap #:set-gmap #:do-gmap 48 | 49 | #:thash-table #:ghash-table 50 | #:ghash-table-count #:get-ghash #:set-ghash #:do-ghash 51 | 52 | ;; ghash-table-test and ghash-table-hash require STMX >= 2.0.1 53 | #?+(symbol :stmx.util :ghash-table-test) #:ghash-table-test 54 | #?+(symbol :stmx.util :ghash-table-hash) #:ghash-table-hash) 55 | 56 | 57 | 58 | (:export #:hlmem-version #:hlmem-abi-version 59 | 60 | #:maddress #:mem-word #:mem-size 61 | #:mread-word #:mwrite-word #:mread-magic #:mwrite-magic 62 | 63 | #:mget-unboxed #:mset-unboxed #:mset-fulltag-and-value 64 | #:msize #:mwrite #:mread 65 | #:msize* #:mwrite* #:with-mread* 66 | 67 | #:msize-object #:mwrite-object #:mread-object 68 | #:msize-object-slots #:mwrite-object-slots #:mread-object-slots 69 | #:mlist-object-slots #:mwrite-object-slot #:mwrite-slot 70 | #:mread-object-slots-using-names 71 | 72 | #:with-mem-bytes #:with-mem-words #:with-vector-mem 73 | #:malloc #:malloc-words #:mfree 74 | #:mzero-words #:memset-words #:memcpy-words 75 | 76 | #:decl-msize-class #:decl-mwrite-class #:decl-mread-class 77 | #:decl-mserializable-class 78 | 79 | #:*mread-symbol-not-found-handler* 80 | 81 | #:+msizeof-word+ #:+most-positive-word+ 82 | #:!mdump #:!mdump-bytes #:!mdump-bytes-reverse)) 83 | -------------------------------------------------------------------------------- /mem/symbols.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | (enable-#?-syntax) 19 | 20 | (eval-always 21 | (define-symbol-macro +stmx-unbound-tvar+ stmx::+unbound-tvar+) 22 | 23 | (define-symbol-macro +stmx-empty-tcell+ 24 | ;; stmx.util::+empty-tcell+ requires STMX >= 2.0.1 25 | #?+(symbol :stmx.util :+empty-tcell+) stmx.util::+empty-tcell+ 26 | #?-(symbol :stmx.util :+empty-tcell+) stmx.util::*empty-tcell*) 27 | 28 | 29 | (define-global +package-keyword+ (find-package '#:keyword)) 30 | (define-global +package-common-lisp+ (find-package '#:common-lisp)) 31 | (define-global +package-common-lisp-user+ (find-package '#:common-lisp-user)) 32 | 33 | (defun collect-symbols (package-designator &key expected-count skip-list) 34 | "Return a sorted list containing all external symbols of a package." 35 | (declare (type (or null fixnum) expected-count) 36 | (type list skip-list)) 37 | 38 | (let ((package package-designator) 39 | (skip-n 0) 40 | (n 0) 41 | (syms nil)) 42 | (declare (type fixnum skip-n n) 43 | (type list syms)) 44 | (with-package-iterator (iter package :external) 45 | (loop do 46 | (multiple-value-bind (found sym) (iter) 47 | (unless found 48 | (return)) 49 | (incf n) 50 | (if (member sym skip-list) 51 | (incf skip-n) 52 | (push sym syms))))) 53 | 54 | (unless (= skip-n (length skip-list)) 55 | (error "HYPERLUMINAL-MEM: cannot compile! ~R of the symbols ~S are not present in package ~S" 56 | (- (length skip-list) skip-n) skip-list (package-name package))) 57 | 58 | (when (and expected-count 59 | (not (eql n expected-count))) 60 | (error "HYPERLUMINAL-MEM: cannot compile! found ~S external symbols in package ~S, expecting ~S" 61 | n (package-name package) expected-count)) 62 | 63 | (sort syms (lambda (sym1 sym2) 64 | (string< (symbol-name sym1) (symbol-name sym2)))))) 65 | 66 | 67 | (defun symbols-vector-to-table (refs &key (first-key 0)) 68 | (declare (type vector refs) 69 | (type fixnum first-key)) 70 | (let* ((n-refs (length refs)) 71 | (htable (make-hash-table :test 'eql :size n-refs))) 72 | (dotimes (i n-refs) 73 | (let ((ref (svref refs i))) 74 | (unless (eql 0 ref) 75 | (setf (gethash ref htable) (the fixnum (+ i first-key)))))) 76 | htable))) 77 | 78 | 79 | 80 | ;; sorted vector of all external symbols in package COMMON-LISP 81 | #-(and) 82 | (define-global +symbols-vector+ 83 | (collect-symbols '#:common-lisp :expected-n-symbols 978 :start-with '(nil t))) 84 | 85 | (eval-always 86 | (define-global +symbols-vector+ (coerce `( 87 | 88 | nil t ,+stmx-unbound-tvar+ ,+stmx-empty-tcell+ 89 | 90 | ,@(collect-symbols '#:common-lisp :expected-count 978 :skip-list '(nil t)) 91 | 92 | 0 0 0 0 0 0 0 0 0 0 0 0 0 93 | 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 94 | 0 0 0 0 0 0 0 0 0 0 0 0 95 | 96 | ,+package-common-lisp-user+ 97 | ,+package-common-lisp+ 98 | ,+package-keyword+ 99 | 100 | :compile-toplevel :load-toplevel :execute ;; eval-when options 101 | :inherited :external :internal ;; intern options 102 | :element-type :initial-element :initial-contents :adjustable :fill-pointer :displaced-to :displaced-index-offset ;; make-array options 103 | :test :size :rehash-size :rehash-threshold ;; make-hash-table options 104 | :case :common :local ;; make-pathname options 105 | :absolute :relative :wild :newest :unspecific :oldest :previous :installed ;; used inside pathnames 106 | :before :after :around ;; defmethod options 107 | 108 | ) 'vector))) 109 | 110 | 111 | 112 | 113 | 114 | (eval-always 115 | (define-global +symbols-table+ (symbols-vector-to-table +symbols-vector+))) 116 | 117 | (eval-always 118 | (defconstant +mem-pkg/common-lisp-user+ 1021 119 | "persistent representation of the package COMMON-LISP-USER")) 120 | 121 | (eval-always 122 | (defconstant +mem-pkg/common-lisp+ 1022 123 | "persistent representation of the package COMMON-LISP")) 124 | 125 | (eval-always 126 | (defconstant +mem-pkg/keyword+ 1023 127 | "persistent representation of the package KEYWORD")) 128 | 129 | (eval-always 130 | (defconstant +mem-syms/first+ 0 131 | "first value used by predefined symbols")) 132 | 133 | (eval-always 134 | (defconstant +mem-syms/last+ (+ +mem-syms/first+ (length +symbols-vector+) -1) 135 | "last value used for predefined symbols")) 136 | 137 | 138 | (eval-always 139 | (defconstant +mem-syms-user/first+ 2048 140 | "first value available for user-defined symbols")) 141 | 142 | 143 | 144 | 145 | (eval-always 146 | (loop for (sym . expected-pos) 147 | in `((nil . ,+mem-sym/nil+) 148 | (t . ,+mem-sym/t+) 149 | (&whole . 11) 150 | (and . 86) 151 | (car . 182) 152 | (cons . 257) 153 | (do . 319) 154 | (if . 443) 155 | (map . 565) 156 | (nth . 633) 157 | (setf . 785) 158 | (string . 852) 159 | (vector . 949) 160 | (zerop . 979) 161 | (,+package-common-lisp-user+ . ,+mem-pkg/common-lisp-user+) 162 | (,+package-common-lisp+ . ,+mem-pkg/common-lisp+) 163 | (,+package-keyword+ . ,+mem-pkg/keyword+) 164 | (:compile-toplevel . 1024) 165 | (:around . 1054)) 166 | for pos = (gethash sym +symbols-table+) 167 | do 168 | (unless (eql pos expected-pos) 169 | (error "HYPERLUMINAL-MEM: unexpected contents of ~S, cannot compile! 170 | symbol ~S is associated to value ~S, it must be associated to value ~S instead" 171 | '+symbols-table+ sym pos expected-pos)))) 172 | 173 | -------------------------------------------------------------------------------- /mem/unicode.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | ;;;; Unicode functions: codepoints, UTF-8 ;;;; 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | (enable-#?-syntax) 24 | 25 | (deftype utf8-n-bytes () '(integer 0 4)) 26 | (deftype word-n-bytes () '(integer 0 #.+msizeof-word+)) 27 | 28 | (defmacro %code-is-high-surrogate (code) 29 | `(<= #xD800 ,code #xDBFF)) 30 | 31 | (defmacro %code-is-low-surrogate (code) 32 | `(<= #xDC00 ,code #xDFFF)) 33 | 34 | (declaim (inline %codepoint-is-reserved)) 35 | (defun %codepoint-is-reserved (code) 36 | (declare (type codepoint code)) 37 | (<= #xD800 code #xDFFF)) ;; high and low surrogates 38 | 39 | 40 | 41 | (defmacro %char-is-high-surrogate (ch) 42 | `(%code-is-high-surrogate (char-code ,ch))) 43 | 44 | (defmacro %char-is-low-surrogate (ch) 45 | `(%code-is-low-surrogate (char-code ,ch))) 46 | 47 | 48 | 49 | 50 | #?-hlmem/character=utf-16 51 | (progn 52 | (declaim (inline %codepoint->character)) 53 | (defun %codepoint->character (code) 54 | "Convert Unicode codepoint to a character" 55 | (declare (optimize (speed 3) (safety 0) (debug 1)) 56 | (type fixnum code)) 57 | (code-char (logand code +character/mask+)))) 58 | 59 | 60 | 61 | 62 | 63 | ;; support UTF-16 strings used at least by CMUCL and ABCL 64 | #?+hlmem/character=utf-16 65 | (progn 66 | (defmacro %utf-16->codepoint (code string char-func i n-chars) 67 | "Convert utf-16 CODE to Unicode codepoint. If CODE is a high-surrogate, 68 | check next char in STRING: if it's a low-surrogate, consume it, 69 | otherwise assume a low-surrogate equal #xDC00. 70 | In any case, convert the code or the high/low surrogate pair to a codepoint." 71 | (with-gensyms (hi lo) 72 | `(let ((,hi ,code)) 73 | (if (%code-is-high-surrogate ,hi) 74 | (let ((,lo (if (< ,i ,n-chars) (char-code (,char-func ,string ,i)) 0))) 75 | (if (%code-is-low-surrogate ,lo) 76 | (incf (the fixnum ,i)) ;; low-surrogate, consume it 77 | (setf ,lo #xDC00)) ;; invalid, pretend we found #xDC00 78 | (+ (ash ,hi 10) ,lo #x-35FDC00)) 79 | ,hi)))) 80 | 81 | (declaim (inline %codepoint->utf-16)) 82 | (defun %codepoint->utf-16 (code) 83 | "Convert Unicode codepoint to one or two UTF-16 characters" 84 | (declare (optimize (speed 3) (safety 0) (debug 1)) 85 | (type fixnum code)) 86 | 87 | (if (<= code #xFFFF) 88 | (code-char code) 89 | (values (code-char (+ (ash code -10) #xD7C0)) ;; i.e. (+ (ash (- code #x10000) -10) #xD800) 90 | (code-char (+ (logand code #x3FF) #xDC00)))))) 91 | 92 | 93 | 94 | 95 | 96 | (declaim (inline %codepoint->utf-8-word)) 97 | (defun %codepoint->utf-8-word (n) 98 | (declare (optimize (speed 3) (safety 0) (debug 1)) 99 | (type codepoint n)) 100 | 101 | (let ((word n) 102 | (bits 8)) 103 | (declare (type (unsigned-byte 32) word) 104 | (type (member 8 16 24 32) bits)) 105 | (cond 106 | ((<= n #x7F)) 107 | ((<= n #x7FF) (setf word (logior #x80C0 108 | (ash (logand n #x03F) 8) 109 | (ash (logand n #x7C0) -6)) 110 | bits 16)) 111 | ((<= n #xFFFF) (setf word (logior #x8080E0 112 | (ash (logand n #x003F) 16) 113 | (ash (logand n #x0FC0) 2) 114 | (ash (logand n #xF000) -12)) 115 | bits 24)) 116 | (t (setf word (logior #x808080F0 117 | (ash (logand n #x00003F) 24) 118 | (ash (logand n #x000FC0) 10) 119 | (ash (logand n #x03F000) -4) 120 | (ash (logand n #x1C0000) -18)) 121 | bits 32))) 122 | (values word bits))) 123 | 124 | 125 | 126 | (defun invalid-utf8-error (byte) 127 | (declare (type (unsigned-byte 8) byte)) 128 | (error "invalid byte. UTF-8 sequence cannot start with #x~X" byte)) 129 | 130 | (defun invalid-utf8-continuation-error (byte) 131 | (declare (type (unsigned-byte 8) byte)) 132 | (error "invalid byte. UTF-8 sequence cannot continue with #x~X" byte)) 133 | 134 | 135 | (declaim (inline %utf-8-is-single-byte?)) 136 | (defun %utf-8-is-single-byte? (byte) 137 | (declare (optimize (speed 3) (safety 0) (debug 1)) 138 | (type (unsigned-byte 8) byte)) 139 | (<= byte #x7F)) 140 | 141 | (declaim (inline %utf-8-is-first-byte?)) 142 | (defun %utf-8-is-first-byte? (byte) 143 | (declare (optimize (speed 3) (safety 0) (debug 1)) 144 | (type (unsigned-byte 8) byte)) 145 | (or (<= byte #x7F) (>= byte #xC0))) 146 | 147 | 148 | (declaim (inline %utf-8-first-byte->length)) 149 | (defun %utf-8-first-byte->length (byte) 150 | "Return the expected length, in bytes, of a UTF-8 multi-byte sequence 151 | given its first byte. Return 0 if BYTE is not a valid first byte for UTF-8 sequences" 152 | (declare (optimize (speed 3) (safety 0) (debug 1)) 153 | (type (unsigned-byte 8) byte)) 154 | (cond ((<= byte #x7F) 1) 155 | ((<= byte #xBF) 0) 156 | ((<= byte #xDF) 2) 157 | ((<= byte #xEF) 3) 158 | ((<= byte #xF7) 4) 159 | (t 0))) 160 | 161 | 162 | 163 | 164 | (declaim (inline %utf-8-word->codepoint)) 165 | (defun %utf-8-word->codepoint (word) 166 | (declare (optimize (speed 3) (safety 0) (debug 1)) 167 | (type mem-word word)) 168 | 169 | (let ((n 0) 170 | (bits 8) 171 | (byte0 (logand #xFF word))) 172 | 173 | (declare (type codepoint n) 174 | (type (member bits 8 16 24 32 bits))) 175 | (cond 176 | ((<= byte0 #x7F) (setf n byte0)) 177 | 178 | ((<= byte0 #xBF) (invalid-utf8-error byte0)) 179 | 180 | ((<= byte0 #xDF) 181 | (setf n (logior (ash (logand #x3F00 word) -8) 182 | (ash (logand #x001F word) 6)) 183 | bits 16)) 184 | 185 | ((<= byte0 #xEF) 186 | (setf n (logior (ash (logand #x3F0000 word) -16) 187 | (ash (logand #x003F00 word) -2) 188 | (ash (logand #x00000F word) 12)) 189 | bits 24)) 190 | 191 | ((<= byte0 #xF7) 192 | (setf n (logior (ash (logand #x3F000000 word) -24) 193 | (ash (logand #x003F0000 word) -10) 194 | (ash (logand #x00003F00 word) 4) 195 | (ash (logand #x00000007 word) 18)) 196 | bits 32)) 197 | 198 | (t 199 | (invalid-utf8-error byte0))) 200 | 201 | (values (the codepoint n) bits))) 202 | 203 | -------------------------------------------------------------------------------- /mem/version.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem) 17 | 18 | 19 | (define-constant-once +hlmem-version+ '(0 6 2)) 20 | 21 | (define-constant-once +hlmem-abi-version+ '(2 6 0)) 22 | 23 | 24 | (defun hlmem-version () 25 | "Return HYPERLUMINAL-MEM version, in the form '(major minor patch) 26 | as for example '(0 4 0)" 27 | +hlmem-version+) 28 | 29 | 30 | (defun hlmem-abi-version () 31 | "Return HYPERLUMINAL-MEM ABI version, in the form '(major minor patch) 32 | as for example '(0 1 0)" 33 | +hlmem-abi-version+) 34 | -------------------------------------------------------------------------------- /sbcl/compiler.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-sbcl) 17 | 18 | 19 | (deftype word () 'sb-ext:word) 20 | 21 | (defconstant +n-fixnum-tag-bits+ sb-vm:n-fixnum-tag-bits 22 | "Number of low bits that are always ZERO 23 | in the representation of a FIXNUM") 24 | 25 | (defconstant +fixnum-zero-mask+1+ (ash 1 sb-vm:n-fixnum-tag-bits) 26 | "1+ mask of the low bits that are always ZERO 27 | in the representation of a FIXNUM") 28 | 29 | ;;;; compiler intrinsic functions 30 | 31 | (defconstant +defknown-has-overwrite-fndb-silently+ 32 | (dolist (arg (second (sb-kernel:type-specifier (sb-int:info :function :type 'sb-c::%defknown)))) 33 | (when (and (consp arg) 34 | (eq (first arg) :overwrite-fndb-silently)) 35 | (return t)))) 36 | 37 | (defmacro defknown (&rest args) 38 | `(sb-c:defknown ,@args 39 | ,@(if +defknown-has-overwrite-fndb-silently+ '(:overwrite-fndb-silently t) ()))) 40 | 41 | 42 | ;;;;; check sbcl features 43 | 44 | ;; return '(:and) if sbcl version is >= version-int-list, otherwise '(:or) 45 | (defun lisp-version>= (version-int-list) 46 | (declare (type (or string list) version-int-list)) 47 | (stmx.asm::compile-if 48 | (stmx.asm::lisp-version>= version-int-list))) 49 | 50 | ;; return '(:and) if symbol exists in given package and is (fboundp), otherwise '(:or) 51 | (defun compile-if-func (pkg-name sym-name) 52 | (declare (type symbol pkg-name sym-name)) 53 | (stmx.asm::compile-if 54 | (let ((pkg (find-package pkg-name))) 55 | (when pkg 56 | (let ((sym (find-symbol (symbol-name sym-name) pkg))) 57 | (fboundp sym)))))) 58 | -------------------------------------------------------------------------------- /sbcl/export.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | ;;;; * HYPERLUMINAL-SBCL 17 | 18 | (in-package :cl-user) 19 | 20 | 21 | (macrolet ((define-package/reexport (package-name (&key reexport-from) &rest body) 22 | (let ((reexport (find-package reexport-from))) 23 | `(defpackage ,package-name 24 | ,@body 25 | (:use ,(package-name reexport)) 26 | (:export 27 | ,@(loop for s being the external-symbols of (find-package reexport-from) 28 | collect (symbol-name s))))))) 29 | 30 | (define-package/reexport #:hyperluminal-mem-asm 31 | (:reexport-from #:hlm-sbcl) 32 | (:nicknames #:hlm-asm))) 33 | -------------------------------------------------------------------------------- /sbcl/package.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | ;;;; * HYPERLUMINAL-SBCL 17 | 18 | (in-package :cl-user) 19 | 20 | (stmx.lang:enable-#?-syntax) 21 | 22 | (defpackage #:hyperluminal-mem-sbcl 23 | (:nicknames #:hlm-sbcl) 24 | (:use #:cl #:hyperluminal-mem-lang #:hyperluminal-mem-ffi) 25 | (:import-from #:stmx.asm 26 | #:find-symbol*) 27 | (:import-from #:stmx.lang 28 | #:enable-#?-syntax #:eval-always #:with-gensym #:with-gensyms) 29 | 30 | #+arm 31 | (:export #:fast-mread/4 #:fast-mwrite/4 #:fast-mword/4=>fixnum 32 | #:fast-memcpy/4 #:fast-memset/4) 33 | 34 | #+x86 35 | (:export #:fast-mread/4 #:fast-mwrite/4 #:fast-mword/4=>fixnum 36 | #:fast-memcpy/4 #:fast-memset/4) 37 | 38 | #+x86-64 39 | (:export #:fast-mread/4 #:fast-mwrite/4 #:fast-mword/4=>fixnum 40 | #:fast-mread/8 #:fast-mwrite/8 #:fast-mword/8=>fixnum 41 | #:fast-memcpy/4 #:fast-memset/4 42 | #:fast-memcpy/8 #:fast-memset/8)) 43 | -------------------------------------------------------------------------------- /test/abi.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-test) 17 | 18 | (def-suite abi-suite :in suite) 19 | (in-suite abi-suite) 20 | 21 | ;; #xFFFEFDFCFBFAF9F8F7F6F5F4F3F2F1F0EFEEEDECEBEAE9E8E7E6E5E4E3E2E1E0DFDEDDDCDBDAD9D8D7D6D5D4D3D2D1D0CFCECDCCCBCAC9C8C7C6C5C4C3C2C1C0BFBEBDBCBBBAB9B8B7B6B5B4B3B2B1B0AFAEADACABAAA9A8A7A6A5A4A3A2A1A09F9E9D9C9B9A999897969594939291908F8E8D8C8B8A898887868584838281807F7E7D7C7B7A797877767574737271706F6E6D6C6B6A696867666564636261605F5E5D5C5B5A595857565554535251504F4E4D4C4B4A494847464544434241403F3E3D3C3B3A393837363534333231302F2E2D2C2B2A292827262524232221201F1E1D1C1B1A191817161514131211100F0E0D0C0B0A09080706050403020100 22 | (defconstant +abi-n+ (loop for i from 0 to #xFF 23 | for bits = 0 then (logior bits (ash (logand i #xFF) (* i 8))) 24 | finally (return bits))) 25 | 26 | (defun mset-float/inline-test (ptr count) 27 | (declare (type fixnum count)) 28 | 29 | ;; on Intel Core i7-4770, 30 | ;; HW transactions succeed very often when writing up to 16KBytes 31 | ;; as long as the mmapped RAM is already dirty: 32 | ;; each RAM page must be written to *before* the HW transaction. 33 | 34 | ;; WARNING: 35 | ;; calling (hlmem::mset-unboxed) instead of (hlmem::mset-float/inline) 36 | ;; at low settings of (optimize (speed)) sometimes causes *all* HW transactions to fail! 37 | ;; the problem disappears by setting (optimize (speed 3)) before loading HYPERLUMINAL-MEM 38 | 39 | (loop for idx from 0 below count by 512 40 | for value = (hlmem::mget-word ptr idx) do 41 | (hlmem::mset-word ptr idx value)) 42 | 43 | (stmx::hw-atomic2 () 44 | (loop for idx from 0 below count 45 | for value from 0.0 by 0.1 do 46 | #-(and) (hlmem::mset-float/inline :sfloat ptr idx value) 47 | #+(and) (hlmem::mset-unboxed ptr idx value) 48 | finally (return :hw-tx)) 49 | :fallback)) 50 | 51 | 52 | 53 | (defun mwrite-mread-test (ptr index end-index x &key (comparator #'equalp)) 54 | (declare (type maddress ptr) 55 | (type mem-size index end-index) 56 | (type function comparator)) 57 | (let ((send (msize index x)) 58 | (xend (mwrite ptr index end-index x))) 59 | ;;(format t "(msize ~S ~S) = ~S~%" index x send) 60 | (is (= send xend)) 61 | (multiple-value-bind (y yend) (mread ptr index end-index) 62 | (is (= xend yend)) 63 | (is-true (funcall comparator x y) 64 | (if (and (integerp x) (integerp y)) 65 | "(mread (mrite #x~X)) returned #x~X" 66 | "(mread (mrite ~S)) returned ~S") x y)))) 67 | 68 | 69 | (defun mem-int-test () 70 | ;; only test MEM-INTs. if they fail, bignums may be non-functional. 71 | (let* ((iterations 20) 72 | (n1 +most-negative-int+) 73 | (n2 (truncate iterations -2)) 74 | (n3 (- +most-positive-int+ (1- iterations))) 75 | (index 0) 76 | (end-index (max (msize index n1) (msize index n2) (msize index n3)))) 77 | (with-mem-words (ptr end-index) 78 | (dolist (i (list n1 n2 n3)) 79 | (dotimes (j iterations) 80 | (mwrite-mread-test ptr index end-index (+ i j))))))) 81 | 82 | (def-test mem-int (:compile-at :definition-time) 83 | (mem-int-test)) 84 | 85 | 86 | (defun bignum-test (count) 87 | (let ((index 0) 88 | (end-index (+ 10 (truncate count +msizeof-word+)))) 89 | (with-mem-words (ptr end-index) 90 | (loop for i from 0 below count 91 | for x = 0 then (logior (ash x 8) (logand i #xff)) do 92 | (mwrite-mread-test ptr index end-index x) 93 | (mwrite-mread-test ptr index end-index (- x)))))) 94 | 95 | ;; test after MEM-INT. if that fails, bignums may be non-functional. 96 | (def-test mem-bignum (:compile-at :definition-time :depends-on mem-int) 97 | (bignum-test 400)) 98 | 99 | 100 | (defun ratio-test () 101 | (let* ((n-bits hlmem::+mem-ratio/numerator/bits+) 102 | (n-mask (1- (ash 1 n-bits))) 103 | (d-bits hlmem::+mem-ratio/denominator/bits+) 104 | (d-mask (1- (ash 1 d-bits))) 105 | (index 0) 106 | (end-index (max (msize 0 (/ (* 2 n-mask) 3)) 107 | (msize 0 (/ 1 (* 2 d-mask)))))) 108 | (with-mem-words (ptr end-index) 109 | (loop for i from (- d-mask 10) to (+ d-mask 10) do 110 | (mwrite-mread-test ptr index end-index (/ 1 i)) 111 | (mwrite-mread-test ptr index end-index (/ -1 i))) 112 | 113 | (loop for i from (- n-mask 10) to (+ n-mask 10) do 114 | (mwrite-mread-test ptr index end-index (/ i d-mask)) 115 | (mwrite-mread-test ptr index end-index (/ -1 d-mask)))))) 116 | 117 | 118 | ;; test after MEM-INT. if that fails, ratios may be non-functional. 119 | (def-test mem-ratio (:compile-at :definition-time :depends-on mem-int) 120 | (ratio-test)) 121 | 122 | 123 | (defparameter *abi-tree* 124 | (list #(0 1 -1 2 -2 1/2 -2/3 3/4 -4/5) 125 | 126 | most-positive-fixnum most-negative-fixnum 127 | (ash most-positive-fixnum 10) (ash most-negative-fixnum 10) 128 | +abi-n+ (- +abi-n+) 129 | 130 | #(0.0 0.1 -0.9999) 131 | most-positive-single-float most-negative-single-float 132 | least-positive-normalized-single-float least-negative-normalized-single-float 133 | least-positive-single-float least-negative-single-float 134 | 135 | #(0.0d0 0.1d0 -0.9999999999d0) 136 | most-positive-double-float most-negative-double-float 137 | least-positive-normalized-double-float least-negative-normalized-double-float 138 | least-positive-double-float least-negative-double-float 139 | 140 | #2A((#C(0.7 0.8) #C(-0.3d0 -0.4d0)) 141 | (#C(1/5 2/5) #C(0 -1/123456789012345678901234567890))) 142 | 143 | #0A42 ;; zero-dimensional array 144 | #*010010001 ;; bit-vector 145 | "foobarbaz" ;; string 146 | (make-array 3 :element-type 'base-char :initial-contents "xyz") ;; base-string 147 | #P"/a/b/c" ;; pathname 148 | 149 | (let ((h (make-hash-table))) 150 | (setf (gethash 'foo h) 'bar) 151 | h) 152 | 153 | nil t 'get-universal-time 'zerop 'foobar 154 | +stmx-unbound-tvar+ 155 | +stmx-empty-tcell+ 156 | :compile-toplevel :load-toplevel :execute)) 157 | 158 | 159 | (defun tree-test () 160 | (let ((tree *abi-tree*) 161 | (index 0)) 162 | (with-mem-words (ptr (msize index tree) end-index) 163 | (dolist (e tree) 164 | (mwrite-mread-test ptr index end-index e)) 165 | (mwrite-mread-test ptr index end-index tree)))) 166 | 167 | 168 | 169 | (def-test mem-tree (:compile-at :definition-time :depends-on (and mem-bignum mem-ratio)) 170 | (tree-test)) 171 | -------------------------------------------------------------------------------- /test/magic.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-test) 17 | 18 | (def-suite magic-suite :in suite) 19 | (in-suite magic-suite) 20 | 21 | (defun compact-test (&optional (count 1000000)) 22 | (declare (type integer count)) 23 | (dotimes (i count) 24 | (let ((c (hlmem::compact-sizeof i))) 25 | (when c 26 | (is (eql i (hlmem::uncompact-sizeof c))))))) 27 | 28 | (def-test compact (:compile-at :definition-time) 29 | (compact-test)) 30 | 31 | 32 | (defun uncompact-test () 33 | (dotimes (i 255) 34 | (let ((u (hlmem::uncompact-sizeof i))) 35 | (is (eql i (hlmem::compact-sizeof u)))))) 36 | 37 | 38 | (def-test uncompact (:compile-at :definition-time) 39 | (uncompact-test)) 40 | -------------------------------------------------------------------------------- /test/mem.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-test) 17 | 18 | (declaim (notinline array-mwrite-test array-mwrite-slow-test)) 19 | 20 | (defun array-mwrite-slow-test (ptr index end-index array) 21 | (declare (type maddress ptr) 22 | (type mem-size index end-index) 23 | (type array array)) 24 | 25 | (loop for j from 0 below (array-total-size array) 26 | for e = (row-major-aref (the (array * *) array) j) 27 | do 28 | (setf index (mwrite ptr index end-index e))) 29 | index) 30 | 31 | 32 | (defun array-mwrite-test (ptr index end-index array) 33 | (declare (type maddress ptr) 34 | (type mem-size index end-index) 35 | (type array array)) 36 | 37 | (let ((type (array-element-type array)) 38 | (simple (typep array 'simple-array)) 39 | (rank (array-rank array))) 40 | 41 | (if (and simple (eql rank 1) (eq type 'fixnum)) 42 | 43 | (loop 44 | for e across (the (simple-array fixnum (*)) array) 45 | do 46 | (hlmem::mset-int ptr index (the fixnum e)) 47 | (hlmem::incf-mem-size index)) 48 | 49 | (array-mwrite-slow-test ptr index end-index array)))) 50 | 51 | 52 | (defun array-test (&optional (len (truncate 1048576 +msizeof-word+))) 53 | (declare (type fixnum len)) 54 | 55 | (let* ((array (make-array len 56 | :element-type 'fixnum 57 | :initial-element 1234)) 58 | (idx 0) 59 | (end (msize idx array))) 60 | 61 | (declare (type mem-size idx end)) 62 | 63 | (with-mem-words (ptr end) 64 | (time 65 | 66 | #+(and) 67 | (dotimes (i 1024) 68 | (mwrite ptr idx end array)) 69 | 70 | #-(and) 71 | (progn 72 | (mwrite ptr idx end array) 73 | (dotimes (i 1024) 74 | (mread ptr idx end))) 75 | 76 | #-(and) 77 | (dotimes (i 1024) 78 | (hlmem::mwrite-box ptr idx end array (hlmem::mdetect-box-type array))) 79 | 80 | #-(and) 81 | (dotimes (i 1024) 82 | (hlmem::call-box-func 83 | hlmem::+mwrite-box-funcs+ 84 | (hlmem::mdetect-box-type array) 85 | ptr 86 | (hlmem::mem-size+ idx hlmem::+mem-box/header-words+) 87 | end array)) 88 | 89 | #-(and) 90 | (dotimes (i 1024) 91 | (hlmem::mwrite-box/vector ptr idx end array)) 92 | 93 | #-(and) 94 | (dotimes (i 1024) 95 | (array-mwrite-test ptr idx end array)) 96 | 97 | #-(and) 98 | (dotimes (i 1024) 99 | (loop with j = 0 100 | for e across array 101 | do (hlmem::mset-int ptr j (the fixnum e)) 102 | (incf (the fixnum j)))) 103 | 104 | #-(and) 105 | (dotimes (i 1024) 106 | (dotimes (j len) 107 | (mwrite ptr j end (row-major-aref array j)))))))) 108 | -------------------------------------------------------------------------------- /test/memcpy.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-test) 17 | 18 | (def-suite memcpy-suite :in suite) 19 | (in-suite memcpy-suite) 20 | 21 | (defun set-words (ptr index end-index start-value) 22 | (declare (type maddress ptr) 23 | (mem-size index end-index) 24 | (mem-word start-value)) 25 | (let ((value start-value)) 26 | (declare (type mem-word value)) 27 | (loop while (< index end-index) do 28 | (hlmem::mset-word ptr index value) 29 | (incf value) 30 | (incf index)))) 31 | 32 | (defun check-words (ptr index end-index start-value) 33 | (declare (type maddress ptr) 34 | (mem-size index end-index) 35 | (mem-word start-value)) 36 | (let ((value start-value)) 37 | (declare (type mem-word value)) 38 | (loop 39 | while (< index end-index) do 40 | (let ((word (hlmem::mget-word ptr index))) 41 | (is (= word value) 42 | "word at ~S contains #x~X instead of #x~X" index word value) 43 | (incf value) 44 | (incf index))))) 45 | 46 | (defun memcpy-test (&optional (n-words 16)) 47 | (declare (type mem-size n-words)) 48 | 49 | (with-mem-words (src n-words) 50 | (with-mem-words (dst n-words) 51 | 52 | (dotimes (algo #-abcl 3 #+abcl 2) 53 | (let* ((seed1 (the mem-word (logxor #x4321 (* algo #x0F0F)))) 54 | (seed2 (the mem-word (logand hlmem::+most-positive-word+ 55 | (ash (lognot seed1) -1))))) 56 | (set-words src 0 n-words seed1) 57 | (check-words src 0 n-words seed1) 58 | (set-words dst 0 n-words seed2) 59 | (check-words dst 0 n-words seed2) 60 | 61 | (case algo 62 | (0 (dotimes (i n-words) 63 | (hlmem::mset-word dst i (hlmem::mget-word src i)))) 64 | (1 (memcpy-words dst 0 src 0 n-words)) 65 | #-abcl 66 | (2 (osicat-posix:memcpy dst src (the mem-word (* n-words +msizeof-word+))))) 67 | 68 | (check-words src 0 n-words seed1) 69 | (check-words dst 0 n-words seed1)))))) 70 | 71 | 72 | (def-test memcpy (:compile-at :definition-time) 73 | (loop for n-words in '(0 1 2 3 4 5 6 7 8 9 15 16 17 31 32 33 63 64 65) do 74 | (memcpy-test n-words))) 75 | -------------------------------------------------------------------------------- /test/mset-int.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-test) 17 | 18 | 19 | (defun mset-int-test (ptr index &optional (num-threads 8) (iterations 300000000)) 20 | (declare (type maddress ptr) 21 | (type mem-size index num-threads) 22 | (type mem-int iterations)) 23 | 24 | (let ((threads 25 | (loop for i from 0 below num-threads collect 26 | ;; assume cache lines are 64 bytes 27 | (let ((offset (the mem-size (+ index (* i (truncate 64 +msizeof-word+)))))) 28 | (bt:make-thread 29 | (lambda () 30 | (let* ((num-failed 0) 31 | (cons (cons 0 0)) 32 | (func (lambda () 33 | (mset-int ptr offset (first cons))))) 34 | 35 | (loop for i from 0 below iterations 36 | do 37 | #-(and) 38 | (if (eql (sb-transaction:transaction-begin) 39 | sb-transaction:+transaction-started+) 40 | (progn 41 | (mset-int ptr offset i) 42 | (sb-transaction:transaction-end)) 43 | (progn 44 | (mset-int ptr offset i) 45 | (incf (the fixnum num-failed)))) 46 | 47 | #+(and) 48 | (stmx::hw-atomic2 (nil :test-for-running-tx? nil) 49 | (mset-int ptr offset i) 50 | (progn 51 | (setf (first cons) i) 52 | (stmx::%run-sw-atomic func) 53 | (incf (the fixnum num-failed)))) 54 | 55 | #-(and) 56 | (progn 57 | (setf (first cons) i) 58 | (stmx:atomic 59 | (mset-int ptr offset (first cons))))) 60 | 61 | num-failed))))))) 62 | 63 | (loop for th in threads collect 64 | (bt:join-thread th)))) 65 | 66 | 67 | (defun mset-int-test-report (ptr index &optional (num-threads 8) (iterations 300000000)) 68 | (declare (type maddress ptr) 69 | (type mem-size index num-threads) 70 | (type mem-int iterations)) 71 | 72 | (let* ((start-tics (get-internal-real-time)) 73 | (fails (mset-int-test ptr index num-threads iterations)) 74 | (end-tics (get-internal-real-time)) 75 | (seconds (/ (- end-tics start-tics) (float internal-time-units-per-second)))) 76 | 77 | ;; benchmark results for 64 bit SBCL running on Intel Core i7 4770 78 | ;; 79 | ;; if SW transactions are not used, 80 | ;; speed is 367 millions HW transactions per second. 81 | ;; 82 | ;; if SW transactions are used as fallback, and thus HW transactions 83 | ;; are augmented with compatibility constraints, 84 | ;; speed drops to 225 millions (hybrid) transactions per second 85 | ;; 86 | ;; the unoptimized version (stmx:atomic (mset-int ptr offset (first cons))) 87 | ;; reaches 197 millions (hybrid) transactions per second 88 | ;; 89 | ;; in all cases, HW transactions success rate is > 99.999% 90 | (format t "elapsed time: ~S seconds~%HW transactions per second: ~S~%" 91 | seconds 92 | (/ (* num-threads iterations) seconds)) 93 | 94 | (loop for fail in fails 95 | initially (format t "HW transactions success rate: ") 96 | do (format t "~5$% " (* 100 (1+ (- (/ fail (float iterations)))))) 97 | finally (format t "~%")))) 98 | 99 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | ;;;; * HYPERLUMINAL-MEM-TEST 16 | 17 | (in-package :cl-user) 18 | 19 | (defpackage #:hyperluminal-mem-test 20 | 21 | (:nicknames #:hlm-test #:hlmem-test) 22 | 23 | (:use #:cl 24 | #:fiveam 25 | #:stmx.util 26 | #:hyperluminal-mem) 27 | 28 | (:import-from #:stmx.lang 29 | #:enable-#?-syntax) 30 | 31 | (:import-from #:hyperluminal-mem 32 | #:!mdump #:+most-negative-int+ #:+most-positive-int+ 33 | #:+stmx-unbound-tvar+ #:+stmx-empty-tcell+) 34 | 35 | (:export #:suite #:loop-run-tests)) 36 | 37 | 38 | 39 | 40 | (in-package :hyperluminal-mem-test) 41 | 42 | (fiveam:def-suite suite) 43 | -------------------------------------------------------------------------------- /test/run-suite.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of STMX. 4 | ;; Copyright (c) 2013-2016 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-test) 17 | 18 | (defun time-to-string (&optional (time (get-universal-time))) 19 | (multiple-value-bind (ss mm hh day month year day-of-week daylight tz) 20 | (decode-universal-time time) 21 | (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~A~2,'0D:00" 22 | year month day hh mm ss (if (minusp tz) #\+ #\-) (abs tz)))) 23 | 24 | (defun show-failed-test (test &key (interactive t)) 25 | (if interactive 26 | (inspect test) 27 | (describe test)) 28 | nil) 29 | 30 | (defun loop-run-tests (&key (suite 'suite) (interactive t)) 31 | (loop 32 | do (format t "~&~A~&" (time-to-string)) 33 | always 34 | (loop for test in (fiveam:run suite) 35 | always (or (typep test 'fiveam::test-passed) 36 | (show-failed-test test :interactive interactive))))) 37 | 38 | -------------------------------------------------------------------------------- /test/stmx-objects.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-test) 17 | 18 | (enable-#?-syntax) 19 | 20 | #?+(and (symbol :stmx.util :ghash-table-test) 21 | (symbol :stmx.util :ghash-table-hash)) 22 | (progn 23 | (def-suite mem-stmx-suite :in suite) 24 | (in-suite mem-stmx-suite) 25 | 26 | (defun equalp-ghash-table (h1 h2) 27 | (declare (type ghash-table h1 h2)) 28 | 29 | (let ((hash (ghash-table-hash h1)) 30 | (test (ghash-table-test h1))) 31 | 32 | (let ((n1 (ghash-table-count h1)) 33 | (n2 (ghash-table-count h2)) 34 | (hash2 (ghash-table-hash h2)) 35 | (test2 (ghash-table-test h2))) 36 | 37 | (unless (eql n1 n2) 38 | (format *terminal-io* "hash-table H1 and H2 are not equal! 39 | H1 has ~S elements, while H2 has ~S elements~%" n1 n2) 40 | (return-from equalp-ghash-table nil)) 41 | 42 | (unless (and (eq hash hash2) 43 | (eq test test2)) 44 | (format *terminal-io* "hash-table H1 and H2 are not equal! 45 | H1 uses TEST ~S and HASH ~S, while H2 uses TEST ~S and hash ~S~%" 46 | test hash test2 hash2) 47 | (return-from equalp-ghash-table nil))) 48 | 49 | 50 | (do-ghash (key val1) h1 51 | (multiple-value-bind (val2 present2) (get-ghash h2 key) 52 | (unless (and present2 53 | (equalp val1 val2)) 54 | (if present2 55 | (format t "hash-table H1 and H2 are not equal! 56 | H1 contains ~S ~S, while H2 contains ~S ~S~%" key val1 key val2) 57 | (format t "hash-table H1 and H2 are not equal! 58 | H1 contains ~S ~S, while H2 does not contain ~S~%" key val1 key)) 59 | 60 | (return-from equalp-ghash-table nil))))) 61 | t) 62 | 63 | 64 | (defun %ghash-table-test () 65 | (let ((h (make-instance 'ghash-table :test 'equalp)) 66 | (tree *abi-tree*) 67 | (index 0)) 68 | 69 | (loop for key = (pop tree) 70 | for val = (pop tree) 71 | while tree 72 | ;; given two similar(*) objects, sxhash is guaranteed to be the same only 73 | ;; if they have one these types: 74 | when (typep key '(or bit-vector character cons number pathname string symbol)) 75 | do 76 | (setf (get-ghash h key) val)) 77 | 78 | (with-mem-words (ptr (msize index h) end-index) 79 | (mwrite-mread-test ptr index end-index h 80 | :comparator #'equalp-ghash-table)))) 81 | 82 | 83 | ;; do not use the symbol ghash-table as test name, it's imported from stmx.util 84 | ;; and already used as test name in stmx.test 85 | (def-test mem-ghash-table (:compile-at :definition-time) 86 | (%ghash-table-test)) 87 | 88 | 89 | (defun equalp-gmap (m1 m2) 90 | (declare (type gmap m1 m2)) 91 | (equalp (gmap-pairs m1) 92 | (gmap-pairs m2))) 93 | 94 | 95 | (defun %gmap-test () 96 | (let ((m (make-instance 'rbmap :pred 'fixnum<)) 97 | (tree *abi-tree*) 98 | (index 0)) 99 | 100 | (loop for key = 0 then (the fixnum (1+ key)) 101 | for val = (pop tree) 102 | while tree 103 | do 104 | (setf (get-gmap m key) val)) 105 | 106 | (with-mem-words (ptr (msize index m) end-index) 107 | (mwrite-mread-test ptr index end-index m :comparator #'equalp-gmap)))) 108 | 109 | ;; do not use the symbol gmap as test name, it's imported from stmx.util 110 | ;; and already used as test name in stmx.test 111 | (def-test mem-gmap (:compile-at :definition-time) 112 | (%gmap-test))) 113 | -------------------------------------------------------------------------------- /test/string.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-test) 17 | 18 | (enable-#?-syntax) 19 | 20 | (def-suite mem-string-suite :in suite) 21 | (in-suite mem-string-suite) 22 | 23 | 24 | #?+hlmem/character=utf-16 25 | (defun make-rainbow-string () 26 | (let* ((n #x110000) 27 | (string (make-array n :element-type 'character :adjustable t :fill-pointer 0))) 28 | 29 | (dotimes (code n) 30 | ;; UTF-16 cannot represent Unicode codepoints in the range #xD800 .. #xDFFF 31 | ;; which are anyway permanently reserved for high and low surrogates. 32 | ;; 33 | ;; It can represent the codepoints #xFFFE and #xFFFF, 34 | ;; but they are reserved too so we do not test them. 35 | (unless (hlmem::%codepoint-is-reserved code) 36 | (multiple-value-bind (ch1 ch2) (hlmem::%codepoint->utf-16 code) 37 | (vector-push-extend ch1 string) 38 | (when ch2 39 | (vector-push-extend ch2 string))))) 40 | string)) 41 | 42 | 43 | #?-hlmem/character=utf-16 44 | (defun make-rainbow-string () 45 | (let* ((n #x110000) 46 | (string (make-string n))) 47 | (dotimes (i n) 48 | ;; CCL (and possibly others) interpret strictly the Unicode standard: 49 | ;; (code-char I) returns NIL for reserved Unicode codepoints. 50 | (unless (hlmem::%codepoint-is-reserved i) 51 | (setf (char string i) (code-char i)))) 52 | string)) 53 | 54 | 55 | (defun string-test () 56 | (let ((x (make-rainbow-string)) 57 | (index 0)) 58 | (with-mem-words (ptr (msize index x) end-index) 59 | (mwrite-mread-test ptr index end-index x)))) 60 | 61 | 62 | (def-test mem-string (:compile-at :definition-time) 63 | (string-test)) 64 | 65 | -------------------------------------------------------------------------------- /tree/b+leaf.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-tree) 17 | 18 | (defun b+leaf (&key (leaf t) size capacity contents contents-start contents-end) 19 | (declare (type (or null b+size) size capacity contents-start contents-end) 20 | (type (or null simple-vector) contents)) 21 | (the (values b+node &optional) 22 | (b+node :leaf leaf 23 | :size (and size (1+ size)) 24 | :capacity (and capacity (1+ capacity)) 25 | :contents contents 26 | :contents-start (when (or contents contents-start) 27 | (1- (or contents-start 0))) 28 | :contents-end contents-end))) 29 | 30 | (declaim (inline b+leaf-next)) 31 | (defun b+leaf-next (node) 32 | (declare (type b+node node)) 33 | (let ((idx (b+size- (b+node-lo node) 1))) 34 | (the (values (or null b+node)) 35 | (svref node idx)))) 36 | 37 | 38 | (declaim (inline (setf b+leaf-next))) 39 | (defun (setf b+leaf-next) (value node) 40 | (declare (type b+node node value)) 41 | (let ((idx (b+size- (b+node-lo node) 1))) 42 | (setf (svref node idx) value))) 43 | 44 | 45 | (declaim (inline b+leaf-find)) 46 | (defun b+leaf-find (node key &optional default) 47 | (declare (type b+node node) 48 | (type fixnum key)) 49 | (let ((lo (b+node-lo node)) 50 | (hi (b+node-hi node))) 51 | ;; (>= lo hi) means no keys, and leaves cannot have children, 52 | ;; much less a lone child without keys 53 | (when (< lo hi) 54 | (loop 55 | ;; lo, mid and hi point to keys and must always be even, 56 | ;; because odd positions contain values 57 | :do 58 | (let* ((mid (the b+size (logand -2 (ash (+ lo hi) -1)))) 59 | (kmid (the fixnum (b+node-ref node mid)))) 60 | (cond 61 | ((fixnum< key kmid) (setf hi mid)) 62 | ((fixnum> key kmid) (setf lo mid)) 63 | (t (return-from b+leaf-find (values (b+node-ref node (1+ mid)) t))))) 64 | :while (< (+ lo 2) hi)) 65 | (when (fixnum= key (b+node-ref node lo)) 66 | (return-from b+leaf-find (values (b+node-ref node (1+ lo)) t))))) 67 | (values default nil)) 68 | -------------------------------------------------------------------------------- /tree/b+node.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-tree) 17 | 18 | (eval-when (:compile-toplevel :load-toplevel :execute) 19 | (defconstant most-positive-b+size 20 | #+(and) (ash most-positive-fixnum -1) 21 | #-(and) #xFFFFFF)) 22 | 23 | (deftype b+size () '(integer 0 #.most-positive-b+size)) 24 | (deftype ufixnum () '(integer 0 #.most-positive-fixnum)) 25 | 26 | (declaim (inline b+size+ b+size- fixnum+ fixnum- )) 27 | 28 | (defun b+size+ (a b) 29 | (declare (type b+size a b)) 30 | (the b+size (+ a b))) 31 | 32 | (defun b+size- (a b) 33 | (declare (type b+size a b)) 34 | (the b+size (- a b))) 35 | 36 | (defun fixnum+ (a b) 37 | (declare (type fixnum a b)) 38 | (the fixnum (+ a b))) 39 | 40 | (defun fixnum- (a b) 41 | (declare (type fixnum a b)) 42 | (the fixnum (- a b))) 43 | 44 | (deftype b+node () 'simple-vector) 45 | (deftype b+leaf () 'b+node) 46 | 47 | (declaim (inline b+node-ref b+node-tag b+node-lo b+node-hi 48 | (setf b+node-ref) (setf b+node-tag) (setf b+node-lo) (setf b+node-hi))) 49 | 50 | (defun b+node-ref (node index) 51 | (declare (type b+node node) 52 | (type b+size index)) 53 | (svref node index)) 54 | (defun (setf b+node-ref) (value node index) 55 | (declare (type b+node node) 56 | (type b+size index)) 57 | (setf (svref node index) value)) 58 | 59 | (defun b+node-tag (node) 60 | (declare (type b+node node)) 61 | (the (or (member t nil) b+node) (svref node 0))) 62 | (defun (setf b+node-tag) (value node) 63 | (declare (type b+node node) 64 | (type (or (member t nil) b+node) value)) 65 | (setf (svref node 0) value)) 66 | 67 | (defun b+node-lo (node) 68 | (declare (type b+node node)) 69 | (the b+size (svref node 1))) 70 | (defun (setf b+node-lo) (value node) 71 | (declare (type b+node node) 72 | (b+size value)) 73 | (setf (svref node 1) value)) 74 | 75 | (defun b+node-hi (node) 76 | (declare (type b+node node)) 77 | (the b+size (svref node 2))) 78 | (defun (setf b+node-hi) (value node) 79 | (declare (type b+node node) 80 | (b+size value)) 81 | (setf (svref node 2) value)) 82 | 83 | (declaim (inline b+node-empty?)) 84 | (defun b+node-empty? (node) 85 | (declare (type b+node node)) 86 | (> (b+node-lo node) (b+node-hi node))) 87 | 88 | (declaim (inline next-power-of-2)) 89 | (defun next-power-of-2 (n) 90 | (declare (type b+size n)) 91 | (ash 1 (integer-length n))) 92 | 93 | (declaim (inline round-n-items)) 94 | (defun round-n-items (n) 95 | (declare (type b+size n)) 96 | (b+size- (next-power-of-2 (b+size+ 2 n)) 97 | 3)) 98 | 99 | (defun b+node (&key leaf size capacity contents contents-start contents-end) 100 | (declare (type (or null b+size) size capacity contents-end) 101 | (type (or null (member -1) b+size) contents-start) 102 | (type (or null simple-vector) contents)) 103 | ;; size and capacity should be odd or zero 104 | ;; for non-leaves, (length contents) should be odd or zero 105 | ;; for leaves, (length contents) should be even 106 | (let* ((contents-len (the b+size (if contents 107 | (length contents) 108 | 0))) 109 | (contents-start (the (or (member -1) b+size) (or contents-start 0))) 110 | (contents-end (the b+size (if contents-end 111 | (min contents-end contents-len) 112 | contents-len))) 113 | (size (the b+size (or size (fixnum- contents-end contents-start)))) 114 | (capacity (cond 115 | ((null capacity) (round-n-items (logior 1 size))) 116 | ((plusp capacity) (logior 1 capacity)) 117 | (t 0))) 118 | (node (make-array (b+size+ 3 capacity)))) 119 | (setf (b+node-tag node) (not leaf) 120 | ;; position of first key, if present. first child would be at 3. 121 | (b+node-lo node) 4 122 | (b+node-hi node) (b+size+ 3 size)) 123 | 124 | (loop 125 | :for i fixnum :from (if leaf 1 0) :below (min size (fixnum- contents-end 126 | contents-start)) 127 | :for j fixnum = (+ i contents-start) 128 | :when (>= j 0) 129 | :do (setf (svref node (fixnum+ 3 i)) (svref contents j))) 130 | node)) 131 | 132 | (declaim (inline b+node-find)) 133 | 134 | (defun b+node-find (node key) 135 | (declare (type b+node node) 136 | (type fixnum key)) 137 | (let ((lo (b+node-lo node)) 138 | (hi (b+node-hi node))) 139 | (cond 140 | ((< lo hi) 141 | (loop 142 | ;; lo, mid and hi point to keys and must always be even, 143 | ;; because odd positions contain children 144 | :do 145 | (let* ((mid (the b+size (logand -2 (ash (+ lo hi) -1)))) 146 | (kmid (the fixnum (b+node-ref node mid)))) 147 | (cond 148 | ((fixnum< key kmid) (setf hi mid)) 149 | ((fixnum> key kmid) (setf lo mid)) 150 | (t (return-from b+node-find (b+node-ref node (1+ mid)))))) 151 | :while (< (+ lo 2) hi)) 152 | (b+node-ref node (if (fixnum< key (b+node-ref node lo)) 153 | (1- lo) 154 | (1+ lo)))) 155 | ((= lo hi) (b+node-ref node (1- lo))) ;; no keys, only one child 156 | ((> lo hi) nil)))) 157 | 158 | (declaim (inline b+node-append)) 159 | 160 | (defun b+node-append (node item) 161 | (declare (type b+node node)) 162 | (let ((hi (b+node-hi node)) 163 | (cap (length node))) 164 | (when (< hi cap) 165 | (setf (svref node hi) item) 166 | (setf (b+node-hi node) (fixnum+ 1 hi)) 167 | t))) 168 | 169 | 170 | 171 | 172 | 173 | -------------------------------------------------------------------------------- /tree/b+tree.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-tree) 17 | 18 | (defstruct (b+tree (:constructor %b+tree)) 19 | (root nil :type (or null b+node)) 20 | (depth 0 :type b+size)) 21 | 22 | (defun b+tree (&key (items-per-node 1021) contents contents-start contents-end) 23 | (declare (type (integer 3 #.most-positive-b+size) items-per-node) 24 | (type (or null simple-vector) contents) 25 | (type (or null ufixnum) contents-start contents-end)) 26 | (check-type items-per-node (integer 3 #.most-positive-b+size)) 27 | (let* ((tree (%b+tree)) 28 | (items-per-node (round-n-items (logior 1 items-per-node))) 29 | (items-per-node-1 (1- items-per-node)) 30 | (contents-len (if contents (length contents) 0)) 31 | (contents-start (or contents-start 0)) 32 | (contents-end (min contents-len (or contents-end most-positive-fixnum))) 33 | (size (max 0 (- contents-end contents-start)))) 34 | (declare (type ufixnum size)) 35 | (when (plusp size) 36 | (let ((node (b+node :capacity items-per-node))) 37 | (loop :until (zerop size) 38 | :do (let* ((n (min size items-per-node-1)) 39 | (leaf (b+leaf :size n 40 | :capacity items-per-node-1 41 | :contents contents 42 | :contents-start contents-start 43 | ;; no need for :contents-end 44 | ))) 45 | (unless (b+node-empty? node) 46 | (b+node-append node (svref contents contents-start))) 47 | (b+node-append node leaf) 48 | 49 | (incf (the ufixnum contents-start) n) 50 | (decf (the ufixnum size) n))) 51 | (setf (b+tree-root tree) node 52 | (b+tree-depth tree) 1))) 53 | tree)) 54 | 55 | 56 | 57 | 58 | 59 | (defun b+tree-find (tree key &optional default) 60 | (declare (type b+tree tree) 61 | (type fixnum key)) 62 | (let ((node (b+tree-root tree)) 63 | (depth (b+tree-depth tree))) 64 | (loop 65 | :until (zerop depth) 66 | :do (decf depth) 67 | :do (unless 68 | (setf node (b+node-find node key)) 69 | (return-from b+tree-find (values default nil)))) 70 | (b+leaf-find node key default))) 71 | 72 | -------------------------------------------------------------------------------- /tree/package.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | ;;;; * HYPERLUMINAL-MEM-TREE 17 | 18 | (in-package :cl-user) 19 | 20 | (stmx.lang:enable-#?-syntax) 21 | 22 | (defpackage #:hyperluminal-mem-tree 23 | 24 | (:nicknames #:hlm-tree) 25 | 26 | (:use #:cl) 27 | 28 | (:import-from #:stmx.lang 29 | 30 | #:eval-always #:enable-#?-syntax #:get-feature 31 | #:set-feature #:set-features 32 | 33 | #:define-global #:define-constant-once 34 | #:with-gensym #:with-gensyms) 35 | 36 | (:import-from #:stmx.util 37 | 38 | #:fixnum< #:fixnum> #:fixnum=) 39 | 40 | 41 | (:export #:b+tree)) 42 | -------------------------------------------------------------------------------- /tree/test-b+tree.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | 3 | ;; This file is part of Hyperluminal-mem. 4 | ;; Copyright (c) 2013-2015 Massimiliano Ghilardi 5 | ;; 6 | ;; This library is free software: you can redistribute it and/or 7 | ;; modify it under the terms of the Lisp Lesser General Public License 8 | ;; (http://opensource.franz.com/preamble.html), known as the LLGPL. 9 | ;; 10 | ;; This library is distributed in the hope that it will be useful, 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty 12 | ;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 | ;; See the Lisp Lesser General Public License for more details. 14 | 15 | 16 | (in-package :hyperluminal-mem-tree) 17 | 18 | 19 | (defun test-b+node-args (&key node min-key max-key expected-results) 20 | (declare (type b+node node) 21 | (type fixnum min-key max-key) 22 | (type simple-vector expected-results)) 23 | (loop :for key :from min-key :to max-key 24 | :for expected :across expected-results 25 | :for actual = (b+node-find node key) 26 | :unless (eql actual expected) 27 | :do (error "TEST-B+NODE failed: searching key ~S in ~S returned value ~S, expected ~S" 28 | key node actual expected)) 29 | t) 30 | 31 | 32 | (defun test-b+node () 33 | (test-b+node-args :node (b+node :capacity 0) 34 | :min-key 0 :max-key 0 35 | :expected-results #(nil)) 36 | 37 | (test-b+node-args :node (b+node :capacity 1 :contents #(a)) 38 | :min-key 0 :max-key 1 39 | :expected-results #(a a)) 40 | 41 | (test-b+node-args :node (b+node :capacity 3 :contents #(a 10 b)) 42 | :min-key 8 :max-key 11 43 | :expected-results #(a a b b)) 44 | 45 | (test-b+node-args :node (b+node :capacity 11 46 | :contents #(a 10 b 12 c 14 d 16 e 18 f)) 47 | :min-key 8 :max-key 19 48 | :expected-results #(a a b b c c d d e e f f))) 49 | 50 | 51 | (defun test-b+tree () 52 | (let ((tree (b+tree :items-per-node 13 :contents #(1 a 2 b 3 c 4 d 5 e 6 f 7 g 8 h 9 i 10 j))) 53 | (expected-tree (%b+tree 54 | :root #(t 4 6 55 | #(nil 4 16 0 1 a 2 b 3 c 4 d 5 e 6 f) 56 | 7 57 | #(nil 4 12 0 7 g 8 h 9 i 10 j 0 0 0 0) 58 | 0 0 0 0 0 0 0 0 0 0) 59 | :depth 1))) 60 | (or (equalp tree expected-tree) 61 | (error "TEST-B+TREE failed: test B+TREE contains ~S, expected ~S" 62 | tree expected-tree)))) 63 | --------------------------------------------------------------------------------