├── .gitignore ├── doc ├── stmx-ELS-2014.pdf ├── supported-systems.md ├── benchmark-ccl64.md ├── benchmark-abcl.md ├── benchmark-cmucl.md └── introduction.md ├── CHANGES ├── util ├── fit.lisp ├── print.lisp ├── tsequence.lisp ├── b-tree.lisp ├── tmap.lisp ├── tvar.lisp ├── thash-table.lisp ├── tstack.lisp ├── container.lisp ├── simple-tvector.lisp ├── tfifo.lisp ├── tcell.lisp ├── package.lisp ├── tchannel.lisp └── misc.lisp ├── test ├── hash-table.lisp ├── run-suite.lisp ├── thash-table.lisp ├── accessors.lisp ├── simple-tvector.lisp ├── package.lisp ├── on-commit.lisp ├── txhash.lisp ├── tmap.lisp └── retry.lisp ├── asm ├── package.lisp ├── x86-32,64-known.lisp ├── cpuid.lisp ├── compiler.lisp ├── x86-32,64-vops.lisp ├── notransaction.lisp └── transaction.lisp ├── stmx.test.asd ├── main ├── version.lisp ├── package.lisp ├── optimize-for-transaction.lisp ├── tvar-slot.lisp ├── hw-atomic.lisp └── atomic.lisp ├── lang ├── print.lisp ├── cons.lisp ├── class-precedence-list.lisp ├── package.lisp ├── macro.lisp ├── features.lisp ├── atomic-ops.lisp ├── features-reader.lisp ├── hw-transactions.lisp ├── hash-table.lisp └── thread.lisp ├── example ├── bank-account.stmx.lisp ├── long-hw-tx.lisp ├── bank-account.lock.lisp ├── concurrent-queue.lisp └── dining-philosophers.lock.lisp ├── BUGS ├── LLGPL.LICENSE ├── NEWS.md └── TODO /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | -------------------------------------------------------------------------------- /doc/stmx-ELS-2014.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/cosmos72/stmx/HEAD/doc/stmx-ELS-2014.pdf -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | Changes in STMX 1.9.0: 2 | * Added support for hardware transactions on CPUs that support Intel 3 | Transactional Synchronization Extensions (TSX) 4 | 5 | * Implemented global clock API and implementations for GV1, GV5, GV6. 6 | The latter still needs to be optimized. 7 | 8 | * Small API change: renamed $ and (SETF $) to $-SLOT and (SETF $-SLOT) respectively. 9 | They behaves as before the rename: ($-SLOT VAR) signals an error if VAR is unbound. 10 | 11 | The functions $ and (SETF $) still exist but now have slightly different - and faster - 12 | behaviour: if VAR is unbound, ($ VAR) returns +UNBOUND-TVAR+ instead of signaling an error. 13 | -------------------------------------------------------------------------------- /util/fit.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 :stmx.util) 17 | 18 | (defun least-square-fit-3 (x1 y1 x2 y2 x3 y3) 19 | (let* ((n 3) 20 | (x (/ (+ x1 x2 x3) n)) 21 | (y (/ (+ y1 y2 y3) n)) 22 | (xx (/ (+ (* x1 x1) (* x2 x2) (* x3 x3)) n)) 23 | (xy (/ (+ (* x1 y1) (* x2 y2) (* x3 y3)) n)) 24 | (m (/ (- xy (* x y)) (- xx (* x x)))) 25 | (q (- y (* m x)))) 26 | (values m q))) 27 | 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /util/print.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 :stmx.util) 17 | 18 | ;;;; ** Printing utilities 19 | 20 | (defgeneric print-object-contents (stream obj)) 21 | 22 | (defmethod print-object-contents ((stream (eql 'nil)) obj) 23 | (with-output-to-string (s) 24 | (print-object-contents s obj))) 25 | 26 | (defmethod print-object-contents (stream obj) 27 | (format stream "~A" obj)) 28 | 29 | (defmethod print-object-contents (stream (obj hash-table)) 30 | (format stream "{") 31 | (let1 first t 32 | (do-hash (key value) obj 33 | (format stream "~A~S=~S" (if first "" ", ") key value) 34 | (setf first nil))) 35 | (format stream "}")) 36 | -------------------------------------------------------------------------------- /test/hash-table.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 :stmx.test) 17 | 18 | 19 | (defun hash-table-to-sorted-keys (hash pred) 20 | (declare (type hash-table hash)) 21 | (let ((pred-func (if (functionp pred) pred (fdefinition pred)))) 22 | 23 | (sort (hash-table-keys hash) pred-func))) 24 | 25 | 26 | (defun hash-table-to-sorted-pairs (hash pred) 27 | (declare (type hash-table hash)) 28 | (let ((pred-func (if (functionp pred) pred (fdefinition pred)))) 29 | 30 | (sort (hash-table-pairs hash) pred-func :key #'first))) 31 | 32 | 33 | (defun hash-table-to-sorted-values (hash pred) 34 | (declare (type hash-table hash)) 35 | (loop for pair in (hash-table-to-sorted-pairs hash pred) 36 | collect (rest pair))) 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /util/tsequence.lisp: -------------------------------------------------------------------------------- 1 | ;;;; sequence functions 2 | 3 | 4 | (defgeneric treverse (x) 5 | (:documentation 6 | "Return a new transactional sequence containing the same elements but in reverse order.")) 7 | 8 | (defmethod treverse ((x (eql nil))) 9 | nil) 10 | 11 | (defmethod treverse ((x tcons)) 12 | (declare (type tcons x)) 13 | (let ((copy)) 14 | (do-tlist (obj x) 15 | (tpush obj copy)) 16 | copy)) 17 | 18 | 19 | 20 | (defgeneric tnreverse (x) 21 | (:documentation 22 | "Return a transactional sequence of the same elements in reverse order; 23 | the argument is destroyed.")) 24 | 25 | (defmethod tnreverse ((x (eql nil))) 26 | nil) 27 | 28 | (defmethod tnreverse ((x tcons)) 29 | #-(and) 30 | (loop 31 | for top = x then curr 32 | for curr = (prog1 (tcons-rest x) 33 | (setf (tcons-rest x) nil)) then next 34 | with next 35 | until (tendp curr) 36 | do 37 | (setf next (tcons-rest curr) 38 | (tcons-rest curr) top) 39 | finally (return top)) 40 | 41 | ;; equivalent to loop above, shorter compiled code on SBCL 42 | #+(and) 43 | (do ((top x curr) 44 | (curr (prog1 (tcons-rest x) (setf (tcons-rest x) nil)) 45 | next) 46 | (next)) 47 | ((tendp curr) top) 48 | 49 | (setf next (tcons-rest curr) 50 | (tcons-rest curr) top))) 51 | 52 | 53 | -------------------------------------------------------------------------------- /asm/package.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 | ;; this code is VERY non-portable: 17 | ;; 18 | ;; it only builds with SBCL running on a x86-64 CPU, 19 | ;; and (except for CPUID and TRANSACTION-SUPPORTED-P) defines CPU instructions 20 | ;; that require RTM support, i.e. hardware memory transactions. 21 | 22 | 23 | (in-package :cl-user) 24 | 25 | (defpackage #:stmx.asm 26 | (:use #:cl) 27 | 28 | (:export #:+impl-package+ #:find-symbol* #:symbol-name* 29 | #:compile-if #:compile-if-package #:compile-if-symbol 30 | 31 | #:cpuid #:lock-elision-supported-p #:transaction-supported-p 32 | 33 | #:transaction-begin #:transaction-end 34 | #:transaction-abort #:transaction-running-p 35 | #:transaction-rerun-may-succeed-p 36 | 37 | #:+transaction-started+ #:+transaction-user-abort+)) 38 | 39 | -------------------------------------------------------------------------------- /stmx.test.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :stmx.test 2 | :name "STMX.TEST" 3 | :version "2.0.5" 4 | :author "Massimiliano Ghilardi" 5 | :license "LLGPL" 6 | :description "test suite for STMX" 7 | 8 | :depends-on (:log4cl 9 | :bordeaux-threads 10 | :fiveam 11 | :stmx) 12 | 13 | :components 14 | ((:module :test 15 | :components ((:file "package") 16 | (:file "hash-table" :depends-on ("package")) 17 | (:file "txhash" :depends-on ("hash-table")) 18 | (:file "ghash-table" :depends-on ("hash-table")) 19 | (:file "thash-table" :depends-on ("hash-table")) 20 | (:file "rbmap" :depends-on ("hash-table")) 21 | (:file "atomic" :depends-on ("package")) 22 | (:file "conflict" :depends-on ("package")) 23 | (:file "on-commit" :depends-on ("atomic")) 24 | (:file "retry" :depends-on ("package")) 25 | (:file "orelse" :depends-on ("package")) 26 | (:file "accessors" :depends-on ("atomic")) 27 | (:file "tmap" :depends-on ("rbmap" "orelse")) 28 | (:file "run-suite" :depends-on ("tmap"))))) 29 | 30 | :perform (asdf:test-op 31 | (o c) 32 | (eval (read-from-string "(fiveam:run! 'stmx.test:suite)")))) 33 | 34 | -------------------------------------------------------------------------------- /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 :stmx.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 | -------------------------------------------------------------------------------- /main/version.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 :stmx) 17 | 18 | ;;;; ** constants 19 | 20 | (declaim (type cons *stmx-version*)) 21 | (defparameter *stmx-version* '(2 0 5)) 22 | 23 | 24 | (defun stmx-internal-error (datum &rest arguments) 25 | (error "STMX internal error!~& ~A" 26 | (apply #'format nil datum arguments))) 27 | 28 | 29 | (defun stmx-internal-error/bug (datum &rest arguments) 30 | (stmx-internal-error 31 | "~A~&~A" 32 | (apply #'format nil datum arguments) 33 | " You may have discovered a bug in STMX, or in one of its dependencies, 34 | or in the Lisp compiler (unlikely, but possible). 35 | Please check if it's a known bug at https://github.com/cosmos72/stmx/issues 36 | If not already present, you can report it including at least the following: 37 | * CPU model 38 | * Operating system, including version 39 | * Lisp compiler, including version 40 | * STMX version: report both stmx:*stmx-version* and (ql:system-apropos \"stmx\") 41 | * a short, self-contained example that causes the bug.")) 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /asm/x86-32,64-known.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 :stmx.asm) 17 | 18 | ;;; cpuid intrinsic 19 | 20 | (defknown %cpuid 21 | ;;arg-types 22 | ((unsigned-byte 32) (unsigned-byte 32)) 23 | ;;result-type 24 | (values (unsigned-byte 32) (unsigned-byte 32) 25 | (unsigned-byte 32) (unsigned-byte 32)) 26 | (sb-c::always-translatable)) 27 | 28 | 29 | 30 | ;;; RTM (restricted transactional memory) intrinsics 31 | 32 | (defknown %transaction-begin () (values (unsigned-byte 32) &optional) 33 | (sb-c::always-translatable)) 34 | 35 | (defknown %transaction-end () (values &optional) 36 | (sb-c::always-translatable)) 37 | 38 | (defknown %transaction-abort ((unsigned-byte 8)) (values &optional) 39 | (sb-c::always-translatable)) 40 | 41 | (defknown %transaction-running-p () (values boolean &optional) 42 | ;; do NOT add the sb-c::movable and sb-c:foldable attributes: either of them 43 | ;; would declare that %transaction-running-p result only depends on its arguments, 44 | ;; which is NOT true: it also depends on HW state. 45 | (sb-c::flushable sb-c::important-result sb-c::always-translatable)) 46 | -------------------------------------------------------------------------------- /test/thash-table.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 :stmx.test) 17 | 18 | (def-suite thash-table-suite :in suite) 19 | (in-suite thash-table-suite) 20 | 21 | 22 | 23 | (def-test new-thash-table (:compile-at :definition-time) 24 | (let1 h (new 'thash-table :test '= :hash 'identity) 25 | (is (= 0 (ghash-table-count h))) 26 | (do-ghash (key value) h 27 | (fail "unexpected entry ~A = ~A in empty thash-table" key value)))) 28 | 29 | 30 | 31 | (defun test-new-thash-table (pred &key (count 16)) 32 | (dolist (thash 33 | (list 34 | (new 'thash-table :test 'eql) 35 | (new 'thash-table :test 'eql :hash 'identity) 36 | (new 'thash-table :test 'equal) 37 | (new 'thash-table :test 'equal :hash 'identity) 38 | (new 'thash-table :test '= :hash 'sxhash) 39 | (new 'thash-table :test '= :hash 'identity) 40 | (new 'thash-table :test 'fixnum= :hash 'sxhash) 41 | (new 'thash-table :test 'fixnum= :hash 'identity))) 42 | (test-ghash-table thash pred :count count))) 43 | 44 | 45 | 46 | (def-test thash-table (:compile-at :definition-time) 47 | (test-new-thash-table #'fixnum<)) 48 | 49 | -------------------------------------------------------------------------------- /doc/supported-systems.md: -------------------------------------------------------------------------------- 1 | STMX 2 | ====== 3 | 4 | Supported systems 5 | ----------------- 6 | 7 | The following table summarizes all the known Common Lisp implementations 8 | where STMX has been tested. 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 |
Linux distributions
Debian 7.0Ubuntu 12.04LTSRaspbian
x86_64x86x86armhf (Raspberry Pi)
SBCL1.1.11x86_64ok
1.0.55.0x86okok
ABCL1.1.1OpenJDK 6b27ok
CCL1.9-r15769x86_64ok
x86 okokok
1.9-dev-r15475M-trunkarmhf ok
CMUCL20c Unicodex86???ok, need [1]ok, need [1]
20d Unicodex86?????????
ECL13.5.1x86_64fail
x86 failfail
33 | 34 | [1] all tested CMUCL versions need to be started with option -fpu x87, 35 | otherwise the following problems will happen on CPUs that support SSE2 or later: 36 | a) CMUCL 20c fails to load the ASDF provided by quicklisp (the builtin one is too old) 37 | with a "division by zero" error. 38 | b) all tested CMUCL versions sometimes hang in STMX test suite 39 | -------------------------------------------------------------------------------- /util/b-tree.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 :stmx.util) 17 | 18 | ;;;; ** non-transactional b-tree 19 | 20 | (declaim (inline %make-b-tree %b-tree-root (setf %b-tree-root) 21 | %b-tree-pred-func)) 22 | 23 | (defstruct (b-tree (:constructor %make-b-tree) (:conc-name %b-tree-)) 24 | (root nil :type (or null tvar b-node)) 25 | (pred-func (error "missing ~S argument instantiating ~S" 'pred 'b-tree) 26 | :type function :read-only t) 27 | (pred-sym nil :type symbol :read-only t)) 28 | 29 | 30 | (defun make-b-tree (pred) 31 | "Instantiate a B-TREE, using function named PRED to order its keys" 32 | (declare (type symbol pred)) 33 | (%make-b-tree :pred-func (fdefinition pred) :pred-sym pred)) 34 | 35 | 36 | 37 | 38 | (defun get-b-tree (b key &optional default) 39 | "Find KEY in B-TREE B and return its value and T as multiple values. 40 | If M does not contain KEY, return (values DEFAULT NIL)." 41 | (declare (type b-tree)) 42 | (let ((node (%b-tree-root b)) 43 | (pred (%b-tree-pred-func b))) 44 | (loop while node 45 | for xkey = (_ node key) do 46 | (case (compare-keys pred key xkey) 47 | (#.k< (setf node (_ node left))) 48 | (#.k> (setf node (_ node right))) 49 | (t (return-from get-gmap (values (_ node value) t))))) 50 | (values default nil))) 51 | 52 | -------------------------------------------------------------------------------- /util/tmap.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 :stmx.util) 17 | 18 | ;;;; ** Transactional sorted map, implemented with red-black trees. 19 | ;;;; For a non-transactional version, see rbmap.lisp 20 | 21 | (transactional 22 | (defclass tnode (rbnode) 23 | ;; override all inherited slots to make them transactional. 24 | ;; No need to specify :initform, :initarg, :accessor or :type 25 | ;; unless we want to override the settings found in superclasses 26 | 27 | ((left ) ;; :type (or null tnode) ;; this sends SBCL in infinite recursion at (optimize (speed 3)) 28 | (right ) ;; :type (or null tnode) ;; idem 29 | (key ) 30 | (value ) 31 | (color )) 32 | (:documentation "Node of transactional sorted map, implemented with red-black tree"))) 33 | 34 | 35 | (transactional 36 | (defclass tmap (rbmap) 37 | ;; override inherited slots to make them transactional 38 | ((root :type (or null tnode)) 39 | ;; inherited slot PRED is immutable -> no need to make it transactional 40 | ;; -> no need to override it 41 | (count) 42 | (foo)) 43 | (:documentation "Transactional sorted map, implemented with red-black tree"))) 44 | 45 | 46 | 47 | ;;;; ** Public API: all functions/methods are inherited from rbmap 48 | 49 | ;;;; ** Abstract methods to be implemented by GMAP subclasses 50 | 51 | (defmethod gmap/new-node ((m tmap) key value) 52 | (new 'tnode :key key :value value)) 53 | 54 | 55 | -------------------------------------------------------------------------------- /test/accessors.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 :stmx.test) 17 | 18 | (def-suite accessors-suite :in suite) 19 | (in-suite accessors-suite) 20 | 21 | (transactional 22 | (defclass point () 23 | ((x :initform 0 :initarg :x :accessor point-x) 24 | (y :initform 0 :initarg :y :accessor point-y)))) 25 | 26 | (defun point-slots (p) 27 | (atomic 28 | (values (slot-value p 'x) 29 | (slot-value p 'y)))) 30 | 31 | 32 | (defun point-readers (p) 33 | (atomic 34 | (values (point-x p) 35 | (point-y p)))) 36 | 37 | (defun point-readers-test () 38 | (let ((p (make-instance 'point :x 1 :y 2))) 39 | (atomic 40 | (setf (slot-value p 'x) 3 41 | (slot-value p 'y) 4) 42 | (multiple-value-bind (xs ys) (point-slots p) 43 | (multiple-value-bind (xa ya) (point-readers p) 44 | (is (eql 3 xs)) 45 | (is (eql 3 xa)) 46 | (is (eql 4 ys)) 47 | (is (eql 4 ya))))))) 48 | 49 | 50 | (defun point-writers-test () 51 | (let ((p (make-instance 'point :x 1 :y 2))) 52 | (atomic 53 | (setf (point-x p) 5 54 | (point-y p) 6) 55 | (multiple-value-bind (xs ys) (point-slots p) 56 | (multiple-value-bind (xa ya) (point-readers p) 57 | (is (eql 5 xs)) 58 | (is (eql 5 xa)) 59 | (is (eql 6 ys)) 60 | (is (eql 6 ya))))))) 61 | 62 | 63 | (def-test point-accessors (:compile-at :definition-time) 64 | (point-readers-test) 65 | (point-writers-test)) 66 | 67 | -------------------------------------------------------------------------------- /test/simple-tvector.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 :stmx.test) 17 | 18 | (def-suite simple-tvector-suite :in suite) 19 | (in-suite simple-tvector-suite) 20 | 21 | 22 | (def-test new-simple-tvector (:compile-at :definition-time) 23 | (let* ((n 10) 24 | (tvec (simple-tvector n))) 25 | ;; default initial-element is 0 26 | (is (= n (simple-tvector-length tvec))) 27 | (let1 count 0 28 | (do-simple-tvector (e) tvec 29 | (is (= 0 e)) 30 | (incf count)) 31 | (is (= n count))))) 32 | 33 | (def-test new-simple-tvector2 (:compile-at :definition-time) 34 | (let* ((n 10) 35 | (tvec (simple-tvector n :initial-element n))) 36 | (let1 count 0 37 | (do-simple-tvector (e) tvec 38 | (is (= n e)) 39 | (incf count)) 40 | (is (= n count))))) 41 | 42 | 43 | (def-test new-simple-tvector3 (:compile-at :definition-time) 44 | (let* ((n 10) 45 | (tvec (simple-tvector n :initial-contents 46 | (loop for i from 0 to (1- n) 47 | collect i)))) 48 | (let1 count 0 49 | (do-simple-tvector (e) tvec 50 | (is (= count e)) 51 | (incf count)) 52 | (is (= n count))))) 53 | 54 | 55 | 56 | (def-test svref-simple-tvector (:compile-at :definition-time) 57 | (let* ((n 10) 58 | (tvec (simple-tvector n))) 59 | ;; default initial-element is 0 60 | (dotimes (i n) 61 | (is (= 0 (tsvref tvec i))) 62 | (setf (tsvref tvec i) i)) 63 | 64 | (dotimes (i n) 65 | (is (= i (tsvref tvec i)))) 66 | 67 | (let1 count 0 68 | (do-simple-tvector (e) tvec 69 | (is (= count e)) 70 | (incf count)) 71 | (is (= n count))))) 72 | -------------------------------------------------------------------------------- /test/package.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 :cl-user) 17 | 18 | (defpackage #:stmx.test 19 | (:use #:cl 20 | #:bordeaux-threads 21 | #:fiveam 22 | #:stmx.lang 23 | #:stmx 24 | #:stmx.util) 25 | 26 | ;; no need for closer-mop version of typep and subtypep; 27 | ;; they even cause some tests to fail 28 | #+cmucl 29 | (:shadowing-import-from #:cl 30 | #:typep 31 | #:subtypep) 32 | 33 | (:import-from #:stmx 34 | #:+invalid-version+ #:set-tvar-value-and-version 35 | #:raw-value-of #:tx-read-of #:tx-write-of 36 | 37 | #:tlog #:make-tlog 38 | #:rerun-error #:rerun 39 | #:retry-error #:retry 40 | #:commit 41 | #:valid? #:valid-and-unlocked? 42 | #:valid-and-own-or-unlocked? 43 | #:current-tlog 44 | #:with-recording-to-tlog 45 | 46 | #:tvar> #:try-lock-tvar #:unlock-tvar 47 | #:txhash-table #:make-txhash-table 48 | #:txhash-table-count 49 | #:get-txhash #:set-txhash #:do-txhash) 50 | 51 | (:import-from #:stmx.util 52 | #:_ 53 | #:print-object-contents 54 | #:print-gmap 55 | #:gmap-node #:rbnode #:tnode #:color-of 56 | #:gmap/new-node 57 | #:+red+ #:+black+ 58 | #:red? #:black?) 59 | 60 | (:export #:suite)) 61 | 62 | 63 | (in-package :stmx.test) 64 | 65 | (fiveam:def-suite suite) 66 | 67 | (defun configure-log4cl () 68 | (log:config :clear :sane :this-console ;; :daily "log.txt" 69 | :pattern "%D{%H:%M:%S} %-5p <%c{}{}{:downcase}> {%t} %m%n") 70 | (log:config :info)) 71 | -------------------------------------------------------------------------------- /lang/print.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 :stmx.lang) 17 | 18 | ;;;; * Printing utilities 19 | 20 | 21 | (defgeneric id-of (obj)) 22 | (defgeneric (setf id-of) (value obj)) 23 | 24 | #-sbcl 25 | (defun compute-string-of (obj) 26 | (handler-case 27 | (format nil "~A" obj) 28 | (t () 29 | (handler-case 30 | (format nil "~S" obj) 31 | (t () 32 | ""))))) 33 | 34 | 35 | (defun compute-id-of (obj) 36 | (declare (type t obj)) 37 | #+sbcl 38 | (format nil "~X" (sb-impl::get-lisp-obj-address obj)) 39 | #-sbcl 40 | (let* ((str (the string (compute-string-of obj))) 41 | (beg (position #\{ str)) 42 | (end (position #\} str))) 43 | (the string 44 | (if (and beg end) 45 | (subseq str (1+ beg) end) 46 | str)))) 47 | 48 | 49 | 50 | (defvar *print-ids* 51 | (trivial-garbage:make-weak-hash-table :test 'eq :size 100 :weakness :key :weakness-matters t)) 52 | 53 | (defmethod id-of (obj) 54 | (the string 55 | (or 56 | (get-hash *print-ids* obj) 57 | (set-hash *print-ids* obj (compute-id-of obj))))) 58 | 59 | (defmethod (setf id-of) (value obj) 60 | (set-hash *print-ids* obj (format nil "~A" value))) 61 | 62 | 63 | (declaim (inline ~ (setf ~))) 64 | 65 | (defun ~ (obj) 66 | (id-of obj)) 67 | 68 | (defun (setf ~) (value obj) 69 | (setf (id-of obj) value)) 70 | 71 | 72 | 73 | (defmacro defprint-object ((obj class &key (type t) (identity t)) &rest body) 74 | (let1 stream (gensym "STREAM-") 75 | `(defmethod print-object ((,obj ,class) ,stream) 76 | (print-unreadable-object (,obj ,stream :type ,type :identity ,identity) 77 | (let1 *standard-output* ,stream 78 | (handler-case 79 | (progn 80 | ,@body) 81 | (t () 82 | (write-string "")))))))) 83 | -------------------------------------------------------------------------------- /util/tvar.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 :stmx.util) 17 | 18 | ;;;; ** Transactional cell implemented with a TVAR 19 | 20 | ;;; Max: we could use the same trick as in tcell.lisp: 21 | ;;; a special *empty-tvar* value to mean "cell is empty". 22 | ;;; Anyway, using tvar functions bound-$? and unbind-$ is less verbose 23 | ;;; and feels more "natural". 24 | 25 | 26 | ;; no need to wrap empty? in a transaction: 27 | ;; bound-$? is atomic, transaction aware, and performs a single read 28 | (defmethod empty? ((var tvar)) 29 | (not (bound-$? var))) 30 | 31 | 32 | (defmethod empty! ((var tvar)) 33 | "Remove value from tvar." 34 | (fast-atomic 35 | (unbind-$ var))) 36 | 37 | ;; no need to specialize (full?) on TVARs: the method in container.lisp is enough 38 | ;; 39 | ;; (defmethod full? ((var tvar)) 40 | ;; (not (empty? var))) 41 | 42 | 43 | (defmethod peek ((var tvar) &optional default) 44 | (peek-$ var default)) 45 | 46 | (defmethod take ((var tvar)) 47 | (fast-atomic 48 | (multiple-value-bind (took? value) (try-take-$ var) 49 | (if took? 50 | value 51 | (retry))))) 52 | 53 | (defmethod put ((var tvar) value) 54 | (fast-atomic 55 | (if (try-put-$ var value) 56 | value 57 | (retry)))) 58 | 59 | (defmethod try-take ((var tvar)) 60 | "hand-made, nonblocking version of (take place) for TVARs. 61 | Less general but approx. 3 times faster (on SBCL 1.0.57.0.debian, 62 | Linux amd64) than the unspecialized (try-take place) which calls 63 | \(atomic (nonblocking (take place)))" 64 | (fast-atomic 65 | (try-take-$ var))) 66 | 67 | (defmethod try-put ((var tvar) value) 68 | "hand-made, nonblocking version of (put place) for TVARs. 69 | Less general but approx. 3 times faster (on SBCL 1.0.57.0.debian, 70 | Linux amd64) than the unspecialized (try-put place) which calls 71 | \(atomic (nonblocking (put place value)))" 72 | (fast-atomic 73 | (try-put-$ var value))) 74 | -------------------------------------------------------------------------------- /util/thash-table.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 :stmx.util) 17 | 18 | ;;;; * support class for THASH-TABLE 19 | 20 | (transactional 21 | (defclass thash-pair (ghash-pair) 22 | ;; Override inherited slots to make them transactional. 23 | ;; Do NOT override the slots that must remain non-transactional. 24 | ;; No need to specify :initform, :initarg, :accessor or :type 25 | ;; unless we want to override the settings found in superclasses 26 | ((key) 27 | (value) 28 | (next)))) 29 | 30 | 31 | 32 | ;;;; ** Transactional hash table 33 | 34 | (transactional 35 | (defclass thash-table (ghash-table) 36 | ;; Override inherited slots to make them transactional. 37 | ;; Do NOT override the slots that must remain non-transactional. 38 | ;; No need to specify :initform, :initarg, :accessor or :type 39 | ;; unless we want to override the settings found in superclasses 40 | ((vec) 41 | (count)) 42 | 43 | (:documentation "Transactional hash table."))) 44 | 45 | 46 | (defmethod initialize-instance :after ((hash thash-table) &rest other-keys) 47 | (declare (ignore other-keys)) 48 | 49 | (setf (_ hash aref-fun) #'tsvref 50 | (_ hash set-aref-fun) #'set-tsvref)) ;; (setf tsvref) has a defsetf expansion :( 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | (defmethod ghash/new-pair ((hash thash-table) key value next) 60 | ;; Allocate a GHASH-PAIR, initialize it with KEY, VALUE and NEXT and return it. 61 | (declare (ignore hash) 62 | (type (or null thash-pair) next)) 63 | 64 | (new 'thash-pair :key key :value value :next next)) 65 | 66 | 67 | (defmethod ghash/new-vec ((hash thash-table) capacity) 68 | ;; Allocate a new GHASH-VECTOR with length = CAPACITY, 69 | ;; initialize all its elements to NIL and return it. 70 | (declare (ignore hash) 71 | (type fixnum capacity)) 72 | 73 | (simple-tvector capacity :initial-element nil)) 74 | 75 | 76 | 77 | -------------------------------------------------------------------------------- /main/package.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 | ;;;; * STMX 17 | 18 | (in-package :cl-user) 19 | 20 | (defpackage #:stmx 21 | 22 | (:use #:cl 23 | #:bordeaux-threads 24 | #:closer-mop 25 | #:stmx.lang) 26 | 27 | (:shadowing-import-from #:closer-mop 28 | #:defclass 29 | #:standard-class 30 | #:standard-generic-function 31 | #:standard-method 32 | #:defmethod 33 | #:defgeneric) 34 | 35 | ;; no need for closer-mop version of typep and subtypep; 36 | ;; they even cause some tests to fail 37 | #+cmucl 38 | (:shadowing-import-from #:cl 39 | #:typep 40 | #:subtypep) 41 | 42 | (:export #:*stmx-version* 43 | 44 | #:atomic #:run-atomic 45 | #:retry 46 | #:orelse #:run-orelse 47 | 48 | ;; hardware transactions. 49 | #:hw-atomic2 50 | #:hw-transaction-supported? 51 | #:hw-transaction-supported-and-running? 52 | 53 | ;; defining classes, structs, functions and methods 54 | #:transactional #:transaction #:transaction? 55 | #:transactional-class 56 | 57 | #:transactional-struct #:non-transactional-struct #:analyze-struct 58 | 59 | ;; utilities 60 | #:nonblocking 61 | #:before-commit #:call-before-commit 62 | #:after-commit #:call-after-commit 63 | 64 | ;; metaclasses 65 | #:transactional-object 66 | #:transactional-class 67 | 68 | ;; low-level API to use TVARs directly 69 | #:tvar #:+unbound-tvar+ #:$-slot #:$ 70 | ;; also (setf $-slot) (setf $) 71 | 72 | #:bound-$? #:unbind-$ 73 | 74 | ;; helpers to optimize code 75 | #:fast-atomic #:optimize-for-transaction #:optimize-for-transaction*)) 76 | 77 | -------------------------------------------------------------------------------- /main/optimize-for-transaction.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 :stmx) 17 | 18 | 19 | (defmacro transaction ((defun-or-defmethod name (&rest args) &body body)) 20 | (let ((docstrings nil)) 21 | (if (and (stringp (first body)) (rest body)) 22 | (setf docstrings (list (pop body)))) 23 | 24 | (when (or (not (eq 'defun defun-or-defmethod)) 25 | (intersection args '(&whole &optional &key &rest &allow-other-keys &aux))) 26 | (return-from transaction 27 | `(,defun-or-defmethod ,name ,args ,@docstrings (atomic ,@body)))) 28 | 29 | (let ((fun-hwtx (gensym "FUN-HWTX")) 30 | (fun-swtx (gensym "FUN-SWTX")) 31 | (fun-notx (gensym "FUN-NOTX")) 32 | (form (gensym "FORM")) 33 | (compiling (gensym "COMPILING")) 34 | (tx-arg (gensym "TX-ARG"))) 35 | `(progn 36 | (compile-for-tx :hwtx (defun ,fun-hwtx ,args ,@body)) 37 | (compile-for-tx :swtx (defun ,fun-swtx ,args ,@body)) 38 | (compile-for-tx :notx (defun ,fun-notx ,args ,@body)) 39 | (,defun-or-defmethod ,name ,args 40 | ,@docstrings 41 | (let ((,tx-arg *hwtx*)) 42 | (if (/= ,tx-arg -2) 43 | (,fun-hwtx ,tx-arg ,@args) 44 | (let ((,tx-arg *tlog*)) 45 | (if ,tx-arg 46 | (,fun-swtx ,tx-arg ,@args) 47 | (atomic ,fun-swtx ,tx-arg ,@args)))))) 48 | (,defun-or-defmethod ,name ,args (atomic ,@body)) 49 | (define-compiler-macro ,name (&whole ,form ,@args) 50 | (print *compiling-transaction*) 51 | (let ((,compiling (car *compiling-transaction*)) 52 | (,tx-arg (cdr *compiling-transaction*))) 53 | (case ,compiling 54 | (:hwtx `(,,fun-hwtx ,,tx-arg ,,@args)) 55 | (:swtx `(,,fun-swtx ,,tx-arg ,,@args)) 56 | (:notx `(,,fun-notx ,,@args)) 57 | (otherwise form)))) 58 | ',name)))) 59 | -------------------------------------------------------------------------------- /util/tstack.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 :stmx.util) 17 | 18 | ;;;; ** Transactional stack (first-in-last-out) buffer 19 | 20 | (transactional 21 | (defclass tstack () 22 | ((top :type list :initarg top :initform nil :accessor top-of)))) 23 | 24 | (declaim (ftype (function () (values tstack &optional)) tstack)) 25 | 26 | (defun tstack () 27 | "Create and return a new TSTACK." 28 | (new 'tstack)) 29 | 30 | (defmethod empty? ((s tstack)) 31 | (null (_ s top))) 32 | 33 | (transaction 34 | (defmethod empty! ((s tstack)) 35 | (setf (_ s top) nil) 36 | s)) 37 | 38 | (defmethod full? ((s tstack)) 39 | "A tstack is never full, so this method always returns nil." 40 | nil) 41 | 42 | 43 | (defmethod peek ((s tstack) &optional default) 44 | "Return the first value in tstack S without removing it, and t as multiple values. 45 | Return (values DEFAULT nil) if S contains no values." 46 | (with-ro-slots (top) s 47 | (if (null top) 48 | (values default nil) 49 | (values (first top) t)))) 50 | 51 | 52 | (transaction 53 | (defmethod take ((s tstack)) 54 | "Wait until tstack S contains at least one value, then remove 55 | and return the first value." 56 | (with-rw-slots (top) s 57 | (if (null top) 58 | (retry) 59 | (pop top))))) 60 | 61 | 62 | (transaction 63 | (defmethod put ((s tstack) value) 64 | "Insert VALUE as first element in tstack S and return VALUE. 65 | Since tstack can contain unlimited values, this method never blocks." 66 | (push value (_ s top)) 67 | value)) 68 | 69 | 70 | (transaction 71 | (defmethod try-take ((s tstack)) 72 | "If tstack S contains at least one value, remove the first value 73 | and return t and the first value as multiple values. 74 | Otherwise return (values nil nil)" 75 | (with-rw-slots (top) s 76 | (if (null top) 77 | (values nil nil) 78 | (values t (pop top)))))) 79 | 80 | 81 | (defmethod try-put ((s tstack) value) 82 | "Append VALUE to tstack S and return (values t VALUE). 83 | Since fifo can contain unlimited values, this method never fails." 84 | (values t (put s value))) 85 | 86 | 87 | 88 | 89 | (defprint-object (obj tstack :identity nil) 90 | (with-ro-slots (top) obj 91 | (if top 92 | (format t "~S" (reverse top)) 93 | (write-string "()")))) 94 | 95 | -------------------------------------------------------------------------------- /util/container.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 :stmx.util) 17 | 18 | ;;;; ** Abstract methods for transactional containers 19 | 20 | (defgeneric full? (place) 21 | (:documentation "Return t if PLACE cannot contain more values, otherwise return nil.")) 22 | 23 | (defgeneric empty? (place) 24 | (:documentation "Return nil if PLACE contains at least one value, otherwise return t.")) 25 | 26 | (defgeneric empty! (place) 27 | (:documentation "Remove all values contained in PLACE. Return PLACE.")) 28 | 29 | (defgeneric peek (place &optional default) 30 | (:documentation "Return one value stored in PLACE without removing it, and t as multiple values. 31 | If PLACE contains no values, return (values DEFAULT nil).")) 32 | 33 | (defgeneric take (place) 34 | (:documentation "Wait until PLACE contains at least one value, then remove and return one value.")) 35 | 36 | (defgeneric put (place value) 37 | (:documentation "Wait until PLACE can contain more values, then store VALUE in it and return VALUE.")) 38 | 39 | (defgeneric try-take (place) 40 | (:documentation "If PLACE contains at least one value, remove one value and return t and it as multiple values. 41 | Otherwise return (values nil nil)")) 42 | 43 | (defgeneric try-put (place value) 44 | (:documentation "If PLACE can contain more values, store VALUE it and return t and VALUE 45 | as multiple values. Otherwise return (values nil nil)")) 46 | 47 | 48 | 49 | ;; no need to wrap (defmethod full? ...) in (transaction ...) 50 | ;; or in an atomic block: it just calls (not (empty?)); 51 | ;; (empty?) must be already atomic and (full?) does not read or write 52 | ;; other transactional memory 53 | (defmethod full? (place) 54 | "Default implementation: assumes that PLACE can contain only one value." 55 | (not (empty? place))) 56 | 57 | (transaction 58 | (defmethod try-take (place) 59 | "this method shows a general technique to convert a blocking, atomic operation 60 | into a nonblocking, atomic one: simply wrap it in (atomic (nonblocking ...))" 61 | (nonblocking 62 | (take place)))) 63 | 64 | (transaction 65 | (defmethod try-put (place value) 66 | "this method shows a general technique to convert a blocking, atomic operation 67 | into a nonblocking, atomic one: simply wrap it in (atomic (nonblocking ...))" 68 | (nonblocking 69 | (put place value)))) 70 | 71 | -------------------------------------------------------------------------------- /test/on-commit.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 :stmx.test) 17 | 18 | (def-suite on-commit-suite :in suite) 19 | (in-suite on-commit-suite) 20 | 21 | (def-test on-commit (:compile-at :definition-time) 22 | (let (x) 23 | (atomic 24 | (before-commit 25 | (is (null x)) 26 | (setf x 'before)) 27 | (after-commit 28 | (is (eq 'before x)) 29 | (setf x 'after))) 30 | (is (eq 'after x)))) 31 | 32 | 33 | (def-test before-commit-fails (:compile-at :definition-time) 34 | (let ((var (tvar 'original))) 35 | 36 | (signals test-error 37 | (atomic 38 | (setf ($ var) 'changed) 39 | (is (eq 'changed ($ var))) 40 | (before-commit 41 | (is (eq 'changed ($ var))) 42 | (is (eq 'original (raw-value-of var))) 43 | (setf ($ var) 'before-commit)) 44 | (before-commit 45 | (is (eq 'before-commit ($ var))) 46 | (is (eq 'original (raw-value-of var))) 47 | (error 'test-error)) 48 | (before-commit 49 | (fail "before-commit function unexpectedly invoked after another one signalled an error")) 50 | (after-commit 51 | (fail "after-commit function unexpectedly invoked after before-commit signalled an error")))) 52 | (is (eq 'original ($ var))) 53 | (is (eq 'original (raw-value-of var))))) 54 | 55 | 56 | (def-test after-commit-fails (:compile-at :definition-time) 57 | (let ((var (tvar 'original))) 58 | 59 | (signals test-error 60 | (atomic 61 | (setf ($ var) 'changed) 62 | (is (eq 'changed ($ var))) 63 | (before-commit 64 | (is (eq 'changed ($ var))) 65 | (is (eq 'original (raw-value-of var))) 66 | (setf ($ var) 'before-commit)) 67 | ;; after-commit blocks are executed in forward order. 68 | ;; they can read and write transactional memory, 69 | ;; but they are executed OUTSIDE any transaction 70 | (after-commit 71 | (is (eq 'before-commit (raw-value-of var))) 72 | (is (eq 'before-commit ($ var))) 73 | (setf ($ var) 'after-commit) 74 | (error 'test-error)) 75 | (after-commit 76 | (fail "after-commit function unexpectedly invoked after another one signalled an error")))) 77 | 78 | (is (eq 'after-commit ($ var))) 79 | (is (eq 'after-commit (raw-value-of var))))) 80 | -------------------------------------------------------------------------------- /example/bank-account.stmx.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 :cl-user) 17 | 18 | (defpackage #:stmx.example.bank-account.stmx 19 | (:use #:cl #:stmx) 20 | 21 | (:import-from #:stmx.lang 22 | #:new #:defprint-object)) 23 | 24 | (in-package :stmx.example.bank-account.stmx) 25 | 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | 28 | (deftype unsigned-fixnum () '(integer 0 #.most-positive-fixnum)) 29 | 30 | (transactional 31 | (defclass account () 32 | ((balance :initform 0 :initarg :balance :type unsigned-fixnum :accessor account-balance) 33 | (name :initform "" :initarg :name :type string :reader account-name 34 | :transactional nil)))) 35 | 36 | 37 | (defprint-object (obj account :identity nil) 38 | (format t "~S ~S" (account-name obj) (account-balance obj))) 39 | 40 | 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | 43 | (defun withdraw (delta account) 44 | "decrease ACCOUNT balance by DELTA. return T if successful" 45 | (declare (type unsigned-fixnum delta) 46 | (type account account)) 47 | 48 | (atomic 49 | (when (>= (account-balance account) delta) 50 | (decf (account-balance account) delta) 51 | t))) 52 | 53 | 54 | (defun deposit (delta account) 55 | "increase ACCOUNT balance by DELTA. return T if successful" 56 | (declare (type unsigned-fixnum delta) 57 | (type account account)) 58 | 59 | (atomic 60 | (when (<= (account-balance account) (- most-positive-fixnum delta)) 61 | (incf (account-balance account) delta) 62 | t))) 63 | 64 | 65 | (defun transfer (delta account1 account2) 66 | "transfer DELTA from ACCOUNT1 to ACCOUNT2. return t if successful." 67 | (declare (type unsigned-fixnum delta) 68 | (type account account1 account2)) 69 | 70 | (atomic 71 | (when (withdraw delta account1) 72 | (if (deposit delta account2) 73 | t 74 | (if (deposit delta account1) 75 | t 76 | (error "cannot happen! cannot deposit ~S back into ~S!" delta account1)))))) 77 | 78 | 79 | (defparameter *account1* (new 'account :name "Mario rossi" :balance 1000)) 80 | (defparameter *account2* (new 'account :name "Giuseppe Verdi")) 81 | 82 | (defun test-bank-accounts (&optional (account1 *account1*) (account2 *account2*)) 83 | (log:info (transfer 700 account1 account2)) 84 | (log:info (transfer 500 account2 account1))) 85 | 86 | -------------------------------------------------------------------------------- /lang/cons.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 :stmx.lang) 17 | 18 | ;;;; ** CONS pool 19 | 20 | (declaim (type list *cons-pool*)) 21 | (defvar *cons-pool* nil) 22 | 23 | (eval-when (:load-toplevel :execute) 24 | (save-thread-initial-bindings *cons-pool*)) 25 | 26 | (declaim (ftype (function (&optional t t) cons) cons^) 27 | (ftype (function (cons) null) free-cons^) 28 | (inline cons^ 29 | free-cons^)) 30 | 31 | (defun cons^ (&optional a b) 32 | "Get a CONS from free cons pool, otherwise allocate it. Return the CONS." 33 | (if-bind cell *cons-pool* 34 | (progn 35 | (setf *cons-pool* (rest cell) 36 | (first cell) a 37 | (rest cell) b) 38 | cell) 39 | (cons a b))) 40 | 41 | (defun free-cons^ (cell) 42 | "Add a CONS cell to free cons pool." 43 | (declare (type cons cell)) 44 | (setf (first cell) nil 45 | (rest cell) *cons-pool* 46 | *cons-pool* cell) 47 | nil) 48 | 49 | (defun free-list^ (list) 50 | "Add a list of CONS cells to free cons pool." 51 | (declare (type list list)) 52 | (when list 53 | (loop for cell = list then next 54 | for next = (rest cell) 55 | while next do 56 | (setf (first cell) nil) 57 | finally 58 | (setf (first cell) nil 59 | (rest cell) *cons-pool* 60 | *cons-pool* list)))) 61 | 62 | 63 | 64 | (defmacro push^ (value place) 65 | "Equivalent to PUSH, but uses CONS pool to speedup allocation. 66 | Inserts VALUE as the first element in PLACE. 67 | Return the modified PLACE." 68 | (multiple-value-bind (temps vals stores store-form get-form) 69 | (get-setf-expansion place) 70 | (let1 value-to-push (gensym (symbol-name 'value-to-push-)) 71 | `(let* ((,value-to-push ,value) 72 | ,@(loop for temp in temps 73 | for val in vals 74 | collect `(,temp ,val)) 75 | (,(first stores) (cons^ ,value-to-push ,get-form))) 76 | ,store-form)))) 77 | 78 | 79 | (defmacro pop-free-cons^ (place) 80 | "Equivalent to POP, but also assumes the CONS at PLACE is no longer 81 | used and can be added to free CONS pool. 82 | Removes and returns the first element in PLACE." 83 | (multiple-value-bind (temps vals stores store-form get-form) 84 | (get-setf-expansion place) 85 | (let1 get-place (gensym (symbol-name 'get-place-)) 86 | `(let* (,@(loop for temp in temps 87 | for val in vals 88 | collect `(,temp ,val)) 89 | (,get-place ,get-form) 90 | (,(first stores) (rest ,get-place))) 91 | (prog1 92 | (first ,get-place) 93 | ,store-form 94 | (free-cons ,get-place)))))) 95 | -------------------------------------------------------------------------------- /asm/cpuid.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 :stmx.asm) 17 | 18 | 19 | 20 | (declaim (ftype (function ((unsigned-byte 32) &optional (unsigned-byte 32)) 21 | (values (unsigned-byte 32) (unsigned-byte 32) 22 | (unsigned-byte 32) (unsigned-byte 32) &optional)) 23 | cpuid) 24 | (inline cpuid)) 25 | 26 | (defun cpuid (eax &optional (ecx 0)) 27 | (%cpuid eax ecx)) 28 | 29 | 30 | 31 | (defun lock-elision-supported-p () 32 | "Test for HLE, i.e. hardware lock elision. 33 | HLE is supported if (cpuid 7) returns ebx with bit 4 set. 34 | If a processor does not support HLE, it will ignore the 35 | assembler instruction prefixes XACQUIRE and XRELEASE." 36 | (let ((max-cpuid (cpuid 0))) 37 | (when (>= max-cpuid 7) 38 | (let ((ebx (nth-value 1 (cpuid 7)))) 39 | (not (zerop (logand ebx #x10))))))) 40 | 41 | 42 | (declaim (ftype (function () boolean) transaction-supported-p)) 43 | 44 | (defun transaction-supported-p () 45 | "Test for RTM, i.e. hardware memory transactions. 46 | RTM is supported if (cpuid 7) returns ebx with bit 11 set. 47 | If a processor does not support HLE, trying to execute 48 | the assembler instructions XBEGIN, XEND, XABORT and XTEST 49 | will generate faults." 50 | (let ((max-cpuid (cpuid 0))) 51 | (when (>= max-cpuid 7) 52 | (let ((ebx (nth-value 1 (cpuid 7)))) 53 | (not (zerop (logand ebx #x800))))))) 54 | 55 | 56 | #| 57 | (defmacro word->extract-byte (word offset) 58 | `(ldb (byte 8 (ash (the (integer 0 3) ,offset) 3)) 59 | (the (unsigned-byte 32) ,word))) 60 | 61 | (defmacro word->extract-byte (word offset) 62 | `(logand #xff 63 | (ash (the (unsigned-byte 32) ,word) 64 | (* -8 (the (integer 0 3) ,offset))))) 65 | 66 | (defun cpuid-vendor () 67 | (multiple-value-bind (eax ebx ecx edx) (cpuid 0) 68 | (declare (ignore eax)) 69 | (let ((s (make-string 12)) 70 | (i 0)) 71 | (declare (type (mod 13) i)) 72 | (dolist (word (list ebx edx ecx)) 73 | (dotimes (j 4) 74 | (let ((code (word->extract-byte word j))) 75 | (setf (char s i) (code-char code)) 76 | (incf i)))) 77 | s))) 78 | 79 | (defun cpuid-processor-brand () 80 | (let ((s (make-string (* 32 3))) 81 | (i 0)) 82 | (dolist (n '(#x80000002 #x80000003 #x80000004)) 83 | (declare (type (unsigned-byte 32) n)) 84 | (multiple-value-bind (eax ebx ecx edx) (cpuid n) 85 | (dolist (word (list eax ebx ecx edx)) 86 | (dotimes (j 4) 87 | (let ((code (word->extract-byte word j))) 88 | (unless (zerop code) 89 | (setf (char s i) (code-char code)) 90 | (incf i))))))) 91 | (subseq s 0 i))) 92 | |# 93 | 94 | -------------------------------------------------------------------------------- /BUGS: -------------------------------------------------------------------------------- 1 | Note: only historical bugs are listed in this file. 2 | For up-to-date buglist, see https://github.com/cosmos72/stmx/issues 3 | 4 | 5 | KNOWN BUGS 6 | 7 | see https://github.com/cosmos72/stmx/issues 8 | 9 | 32-bit CCL: "# is not of required type short-float" in retry-funs 10 | 11 | 12 | FIXED BUGS: 13 | 14 | 7) fixed race condition in GV6/%UPDATE-STAT - it was also the cause of bug 6 15 | 16 | 6) with HW-TRANSACTIONS enabled, test suite no longer hangs - thanks to bugfix 7. 17 | 18 | 5) consistent reads were not fully guaranteed. The implementation allowed 19 | transactions to read inconsistent TVARs in some circumstances. 20 | Reason: when reading TVARs, version must be read twice (and depending on the compiler/CPU, 21 | other things are needed as well). 22 | See doc/consistent-reads.md for a full solution, which has been implemented. 23 | 24 | 4) initargs of transactional classes were wrapped in TVARs multiple times, 25 | depending on the length of list returned by (closer-mop:slot-definition-initargs slot) 26 | 27 | 3) when a transaction signals an error, (run-atomic) was calling (valid? log) without locking, 28 | so it could get spurious "invalid" answers and unnecessarily re-run the transaction 29 | (only a waste of resources, not a bug) 30 | but it could even get spurious "valid" answers in case read TVARs match the current values 31 | partially before another thread commits, and partially after. 32 | In the latter case, (run-atomic) would propagate the error to the caller 33 | => BUG, it must instead re-run the transaction. 34 | How to fix: when a transaction signals an error, also validate the log WITH locking. 35 | 36 | 2) (wait-once) was returning without removing the log from tvars 37 | waiting list. Each tvar would remove all the waiting logs when it 38 | notified it has changed, but unchanged vars could accumulate a LOT 39 | of enqueued logs, leaking memory. 40 | 41 | Solution: replaced tvar waiting queue with a hash-table, so now 42 | (wait-once) before returning explicitly removes its log from tvars 43 | waiting list. 44 | 45 | 1) (commit) could call (condition-notify) too early, before the relevant thread 46 | is sleeping in (condition-wait) inside (wait-once). 47 | 48 | Solution: since we cannot keep locks on tlogs while also locking 49 | tvars (DEADLOCK!), we added a flag 'prevent-sleep to tlog, 50 | and always read/write it while holding a lock on the tlog, 51 | 52 | then we do in (commit): 53 | (with-lock-held (lock-of log) 54 | (setf (prevent-sleep-of log) t) 55 | (condition-notify log (lock-of log))) 56 | 57 | and in (wait-once): 58 | (with-lock-held (lock-of log) 59 | (setf (prevent-sleep-of log) nil) ;; needed? should be the initial value 60 | 61 | ;; ... loop on (reads-of log) to enqueue on their waiting list, 62 | ;; WHILE checking if they changed ... 63 | 64 | (with-lock-held (lock-of log) 65 | (unless (prevent-sleep-of log) 66 | (condition-wait log (lock-of log)))) 67 | 68 | NOT BUGS 69 | 70 | 4) (retry) triggers a call to (valid? log) without locking, so in theory it may 71 | get spurious "valid" answers exactly like in bug 3. Is it a bug or not? 72 | Not a bug. 73 | Reason: if tlog appears valid, (wait-tlog) will repeat validity check 74 | with locking before actually sleeping. 75 | -------------------------------------------------------------------------------- /test/txhash.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 :stmx.test) 17 | 18 | (def-suite txhash-suite :in suite) 19 | (in-suite txhash-suite) 20 | 21 | 22 | 23 | (def-test new-txhash (:compile-at :definition-time) 24 | (let1 h (make-txhash-table) 25 | (is (= 0 (txhash-table-count h))) 26 | (do-txhash (key value) h 27 | (fail "unexpected entry ~A = ~A in empty txhash" key value)))) 28 | 29 | 30 | 31 | (defun txhash-table-keys (txh) 32 | (declare (type txhash-table txh)) 33 | (let1 keys nil 34 | (do-txhash (key) txh 35 | (push key keys)) 36 | keys)) 37 | 38 | (defun txhash-table-pairs (txh) 39 | (declare (type txhash-table txh)) 40 | (let1 pairs nil 41 | (do-txhash (key value) txh 42 | (push (cons key value) pairs)) 43 | pairs)) 44 | 45 | 46 | (defun txhash-table-to-sorted-keys (txh pred) 47 | (declare (type txhash-table txh) 48 | (type function pred)) 49 | (sort (txhash-table-keys txh) pred)) 50 | 51 | 52 | (defun txhash-table-to-sorted-pairs (txh pred) 53 | (declare (type txhash-table txh) 54 | (type function pred)) 55 | (sort (txhash-table-pairs txh) pred :key #'first)) 56 | 57 | 58 | (defun txhash-table-to-sorted-values (txh pred) 59 | (declare (type txhash-table txh) 60 | (type function pred)) 61 | (loop for pair in (txhash-table-to-sorted-pairs txh pred) 62 | collect (rest pair))) 63 | 64 | 65 | 66 | (defun is-equal-txhash-and-hash-table (txh hash pred) 67 | (declare (type txhash-table txh) 68 | (type hash-table hash) 69 | (type function pred)) 70 | (is (= (hash-table-count hash) 71 | (txhash-table-count txh))) 72 | (is (equal (txhash-table-to-sorted-keys txh pred) 73 | (hash-table-to-sorted-keys hash pred))) 74 | (is (equal (txhash-table-to-sorted-values txh pred) 75 | (hash-table-to-sorted-values hash pred))) 76 | (is (equal (txhash-table-to-sorted-pairs txh pred) 77 | (hash-table-to-sorted-pairs hash pred)))) 78 | 79 | 80 | (defun is-equal-txhash (txh1 txh2 pred) 81 | (declare (type txhash-table txh1 txh2) 82 | (type function pred)) 83 | (is (equal (txhash-table-to-sorted-pairs txh1 pred) 84 | (txhash-table-to-sorted-pairs txh2 pred)))) 85 | 86 | 87 | (defun test-txhash (pred &key (count 4)) 88 | (declare (type fixnum count)) 89 | (let ((txh (make-txhash-table)) 90 | (hash (make-hash-table :test 'eq))) 91 | (dotimes (i count) 92 | (let ((key (tvar)) 93 | (value (random count))) 94 | (set-txhash txh key value) 95 | (set-hash hash key value) 96 | (is-equal-txhash-and-hash-table txh hash pred))))) 97 | 98 | 99 | (def-test txhash (:compile-at :definition-time) 100 | (test-txhash #'tvar>)) 101 | 102 | 103 | 104 | 105 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /util/simple-tvector.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 :stmx.util) 17 | 18 | ;;;; ** Transactional simple-vector: fixed-size one dimensional array 19 | 20 | (deftype simple-tvector (&optional length) 21 | "SIMPLE-TVECTOR is a transactional, one dimensional array. 22 | It is currently a deftype, not a class or struct: 23 | methods cannot be specialized on it." 24 | `(simple-vector ,(or length '*))) 25 | 26 | (defun simple-tvector (length &key (element-type t) 27 | (initial-element 0) initial-contents) 28 | "Create and return a new SIMPLE-TVECTOR." 29 | (declare (type fixnum length) 30 | (type list initial-contents) 31 | (ignore element-type)) 32 | (let1 tvec (make-array length :element-type 'tvar :initial-element +dummy-tvar+) 33 | (if initial-contents 34 | (loop for i from 0 to (1- length) 35 | for cell = initial-contents then (rest cell) 36 | for element = (first cell) do 37 | (setf (svref tvec i) (tvar element))) 38 | (dotimes (i length) 39 | (setf (svref tvec i) (tvar initial-element)))) 40 | tvec)) 41 | 42 | (declaim (inline simple-tvector-length)) 43 | (defun simple-tvector-length (tvec) 44 | "Return the length of simple-tvector TVEC." 45 | (declare (type simple-tvector tvec)) 46 | (length tvec)) 47 | 48 | 49 | (optimize-for-transaction* 50 | (:inline t) 51 | (defun tsvref (tvec index) 52 | "Return the INDEX-th element of simple-tvector TVEC. 53 | Works both inside and outside transactions" 54 | (declare (type simple-tvector tvec) 55 | (type fixnum index)) 56 | ($ (svref tvec index)))) 57 | 58 | (optimize-for-transaction* 59 | (:inline t) 60 | ;; do NOT (defun (setf tsvref) ..) because 61 | ;; thash-table needs an actual function #'set-tsvref 62 | (defun set-tsvref (tvec index value) 63 | "Set the INDEX-th element of simple-tvector TVEC to VALUE. 64 | Works both inside and outside transactions" 65 | (declare (type simple-tvector tvec) 66 | (type fixnum index)) 67 | (setf ($ (svref tvec index)) value))) 68 | 69 | (defsetf tsvref set-tsvref) 70 | 71 | 72 | 73 | 74 | (defmacro do-simple-tvector ((element) tvec &body body) 75 | "Execute BODY on each ELEMENT contained in simple-tvector TVEC. 76 | 77 | Creates an implicit block named NIL, so (return ...) can be used 78 | to exit early from the loop with an explicit return value." 79 | (with-gensym var 80 | `(loop for ,var across ,tvec 81 | for ,element = ($ ,var) do 82 | (progn ,@body)))) 83 | 84 | 85 | ;; simple-tvector is a deftype, not a class or struct: 86 | ;; cannot specialize methods on it 87 | #| 88 | (defprint-object (tvec simple-tvector :identity nil) 89 | (dotimes (i (length tvec)) 90 | (unless (zerop i) 91 | (write-string " ")) 92 | (let1 var (svref tvec i) 93 | (multiple-value-bind (value present?) (peek-$ var) 94 | (if present? 95 | (format t "~A" value) 96 | (write-string "unbound")))))) 97 | |# 98 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | ### Latest news, 16th January 2015 2 | 3 | Version 2.0.1 released. 4 | It adds support for transactional structs in addition to transactional CLOS objects, 5 | and a faster, struct-based implementation of transactional CONS cells and lists, 6 | including several list-manipulating functions - see [util/tcons.lisp](util/tcons.lisp) 7 | and [util/tlist.lisp](util/tlist.lisp) 8 | 9 | Unluckily, the hardware bug that prompted Intel to disable hardware transactional memory (TSX) 10 | in August 2014 is still there, and *very* few new models are available without the bug. 11 | So for the moment STMX will be software-only on many CPUs. 12 | 13 | ### News, 20th May 2014 14 | 15 | STMX was presented at 16 | [7th European Lisp Symposium (ELS 2014)](http://www.european-lisp-symposium.org/) 17 | in a technical paper titled 18 | [High performance concurrency in Common Lisp - hybrid transactional memory with STMX](doc/stmx-ELS-2014.pdf). 19 | 20 | [Slides](http://www.european-lisp-symposium.org/ghilardi.pdf) 21 | and [video](http://medias.ircam.fr/xcc8494) 22 | of STMX presentation are available from 23 | [ELS 2014 website](http://www.european-lisp-symposium.org/content-programme-full.html). 24 | 25 | Thanks everybody who joined this great event in Paris! 26 | 27 | 28 | ### News, 31st August 2013 29 | 30 | Since version 1.9.0, STMX supports hardware memory transactions in addition to 31 | classic software ones. It uses Transactional Synchronization 32 | Extensions (Intel TSX) available on the following Intel x86_64 processors: 33 | - Intel Core i7 4771 34 | - Intel Core i7 4770, 4770S, 4770T, 4770TE 35 | - Intel Core i7 4765T 36 | - Intel Core i5 4670, 4670S, 4670T 37 | - Intel Core i5 4570, 4570S, 4570T, 4570TE 38 | 39 | To actually use hardware memory transactions with STMX, you will need: 40 | 41 | - a CPU supporting Intel TSX, for example one from the above list 42 | - a 64-bit OS (currently tested on Debian GNU/Linux x86_64) 43 | - a 64-bit installation of Steel Bank Common Lisp (SBCL) version 1.0.55 or later 44 | Note: x86_64 is often named AMD64 - they are the same thing 45 | - the latest STMX version - download it from [GitHub](https://github.com/cosmos72/stmx) 46 | as described in **Installation and loading** below 47 | 48 | The current hardware memory transactions implementation is very fast, yet it 49 | still has room for optimizations. Currently, it can accelerate short 50 | transactions up to 4-5 times while seamlessly falling back on software 51 | transactions when the hardware limits are exceeded. Experiments with 52 | hand-optimized code (not yet included in STMX) show that the maximum possible 53 | performance increase is 7-8 times. 54 | 55 | ### News, 27th July 2013 56 | 57 | Since version 1.3.3, STMX also includes [SB-TRANSACTION](sb-transaction), a 58 | standalone library that does **not** depend on STMX and provides hardware-only 59 | memory transactions on CPUs that support Intel TSX instructions. 60 | It is a low-level library providing raw access to the new CPU instructions 61 | for hardware transactions. 62 | Its performance reaches the theoretical peak supported by the underlying CPU, 63 | and it is obviously faster than STMX - it is usually even faster than 64 | hand-optimized compare-and-swap fine grained locking code (see benchmark 65 | results in [doc/benchmark.md](doc/benchmark.md)). The reason is that it avoids 66 | the overhead and the software compatibility requirements of STMX, providing 67 | only the raw features - and the limitations - of the underlying CPU. 68 | At the moment, SB-TRANSACTION only works on SBCL running in native 64-bit mode 69 | on a CPU with hardware transaction support (see the list above). 70 | 71 | -------------------------------------------------------------------------------- /util/tfifo.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 :stmx.util) 17 | 18 | ;;;; ** Transactional first-in-first-out (fifo) buffer 19 | 20 | (transactional 21 | (defclass tfifo () 22 | ((front :type tcons :accessor front-of) 23 | (back :type tcons :accessor back-of)))) 24 | 25 | 26 | (defun tfifo () 27 | (new 'tfifo)) 28 | 29 | (defmethod initialize-instance :after ((f tfifo) &key &allow-other-keys) 30 | "Initialize tfifo F." 31 | (let1 cell (tcons nil nil) 32 | (setf (front-of f) cell 33 | (back-of f) cell))) 34 | 35 | 36 | (defmethod full? ((f tfifo)) 37 | "A tfifo is never full, so this method always returns nil." 38 | nil) 39 | 40 | (transaction 41 | (defmethod empty? ((f tfifo)) 42 | (eq (front-of f) (back-of f)))) 43 | 44 | (transaction 45 | (defmethod empty! ((f tfifo)) 46 | (setf (front-of f) (back-of f)) 47 | f)) 48 | 49 | 50 | 51 | (transaction 52 | (defmethod peek ((f tfifo) &optional default) 53 | "Return the first value in tfifo F without removing it, and t as multiple values. 54 | Return (values DEFAULT nil) if F contains no value." 55 | (with-ro-slots (front back) f 56 | (if (eq front back) 57 | (values default nil) 58 | (values (tfirst front) t))))) 59 | 60 | 61 | (transaction 62 | (defmethod take ((f tfifo)) 63 | "Wait until tfifo F contains at least one value, 64 | then remove and return the first value." 65 | (with-rw-slots (front back) f 66 | (if (eq front back) 67 | (retry) 68 | (tpop front))))) 69 | 70 | 71 | (transaction 72 | (defmethod put ((f tfifo) value) 73 | "Append VALUE as last element in tfifo F and return VALUE. 74 | Since tfifo can contain unlimited values, this method never blocks." 75 | (with-rw-slots (back) f 76 | (let1 cell (tcons nil nil) 77 | (setf (tfirst back) value 78 | (trest back) cell 79 | back cell))) 80 | value)) 81 | 82 | 83 | (transaction 84 | (defmethod try-take ((f tfifo)) 85 | "If tfifo F contains at least one value, remove the first value 86 | and return t and the first value as multiple values. 87 | Otherwise return (values nil nil)" 88 | (with-rw-slots (front back) f 89 | (if (eq front back) 90 | (values nil nil) 91 | (values t (tpop front)))))) 92 | 93 | 94 | (defmethod try-put ((f tfifo) value) 95 | "Append VALUE as last element in tfifo F and return (values t VALUE). 96 | Since tfifo can contain unlimited values, this method never fails." 97 | (values t (put f value))) 98 | 99 | 100 | (defprint-object (obj tfifo :identity nil) 101 | (write-string "(") 102 | (let ((list (_ obj front)) 103 | (end (_ obj back))) 104 | (unless (eq list end) 105 | (loop 106 | for value = (tfirst list) 107 | for rest = (trest list) 108 | do 109 | (when (eq rest end) 110 | (format t "~S" value) 111 | (return)) 112 | (format t "~S " value) 113 | (setf list rest)))) 114 | (write-string ")")) 115 | -------------------------------------------------------------------------------- /lang/class-precedence-list.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 :stmx.lang) 17 | 18 | (defun mapappend (fn seq) 19 | (apply #'append (mapcar fn seq))) 20 | 21 | (defun collect-superclasses (class) 22 | (remove-duplicates 23 | (cons class 24 | (mapappend #'collect-superclasses 25 | (closer-mop:class-direct-superclasses class))))) 26 | 27 | (defun collect-all-superclasses (classes-names) 28 | (remove-duplicates 29 | (mapappend #'collect-superclasses (mapcar #'find-class classes-names)))) 30 | 31 | (defun local-precedence-ordering (class) 32 | (loop for cell on (cons class (closer-mop:class-direct-superclasses class)) 33 | for class1 = (first cell) 34 | for class2 = (second cell) 35 | while class2 36 | collect (list class1 class2))) 37 | 38 | (defun topological-sort (elements constraints tie-breaker error-msg) 39 | (let ((remaining-elements (copy-list elements)) 40 | (remaining-constraints (copy-list constraints)) 41 | (result nil)) 42 | (loop 43 | (log.trace "~%elements = ~A~%constraints = ~A" elements constraints) 44 | (let ((minimal-elements 45 | (remove-if (lambda (class) (member class remaining-constraints :key #'second)) 46 | remaining-elements))) 47 | (when (null minimal-elements) 48 | (if (null remaining-elements) 49 | (return-from topological-sort (nreverse result)) 50 | (error error-msg))) 51 | (let ((choice (if (null (rest minimal-elements)) 52 | (first minimal-elements) 53 | (funcall tie-breaker 54 | minimal-elements 55 | result)))) 56 | (log.trace "choice = ~A" choice) 57 | (push choice result) 58 | (setf remaining-elements (delete choice remaining-elements) 59 | remaining-constraints (delete choice 60 | remaining-constraints 61 | :test #'member))))))) 62 | 63 | 64 | (defun clos-tie-breaker-rule (minimal-elements reverse-precedence-list) 65 | (log.trace "~%minimal-elements = ~A~%reverse-pcl = ~A" minimal-elements reverse-precedence-list) 66 | (dolist (class reverse-precedence-list) 67 | (let* ((superclasses (closer-mop:class-direct-superclasses class)) 68 | (common (intersection minimal-elements superclasses))) 69 | (when common 70 | (return-from clos-tie-breaker-rule (first common))))) 71 | (first minimal-elements)) 72 | 73 | (defun clos-compute-class-precedence-list (class-name direct-superclasses-names) 74 | (declare (type symbol class-name) 75 | (type list direct-superclasses-names)) 76 | (let ((classes-to-order (collect-all-superclasses direct-superclasses-names))) 77 | (topological-sort classes-to-order 78 | (remove-duplicates 79 | (mapappend #'local-precedence-ordering 80 | classes-to-order) 81 | :test 'equal) 82 | #'clos-tie-breaker-rule 83 | (format nil "Inconsistent precedence list for class ~A" class-name)))) 84 | -------------------------------------------------------------------------------- /test/tmap.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 :stmx.test) 17 | 18 | (enable-#?-syntax) 19 | 20 | (def-suite tmap-suite :in suite) 21 | (in-suite tmap-suite) 22 | 23 | (define-condition rollback-error (error) 24 | ()) 25 | 26 | (defun test-tmap-rollback () 27 | (let* ((m1 (new 'tmap :pred 'fixnum<)) 28 | (m2 (copy-gmap m1))) 29 | 30 | (add-to-gmap m1 1 "x" 2 "y") 31 | (copy-gmap-into m1 m2) 32 | 33 | (signals rollback-error 34 | (atomic 35 | (add-to-gmap m1 1 "z" 3 "w") 36 | (rem-gmap m1 2) 37 | ;;(format t "~&-------------~%") 38 | ;;(print-gmap t m1) 39 | (error 'rollback-error))) 40 | 41 | ;;(format t "~&-------------~%") 42 | ;;(print-gmap t m1) 43 | (is-equal-gmap m1 m2) 44 | t)) 45 | 46 | 47 | (def-test tmap-rollback (:compile-at :definition-time) 48 | (test-tmap-rollback)) 49 | 50 | 51 | (def-test tmap (:compile-at :definition-time) 52 | (test-rbmap-class 'tmap)) 53 | 54 | (def-test tmap-atomic (:compile-at :definition-time) 55 | (atomic (test-rbmap-class 'tmap))) 56 | 57 | 58 | 59 | #?+bt/make-thread 60 | (defun tmap-insert-func (m iterations) 61 | (declare (type gmap m) 62 | (type fixnum iterations)) 63 | (let ((self (bt:thread-name (bt:current-thread))) 64 | (max -1)) 65 | (dotimes (i iterations max) 66 | (let ((result 67 | (atomic 68 | (multiple-value-bind (key value present) (max-gmap m) 69 | (declare (ignore value)) 70 | (unless present (setf key max)) 71 | (set-gmap m (incf (the fixnum key)) self) 72 | key)))) 73 | (setf max (max result max)))))) 74 | 75 | 76 | #?+bt/make-thread 77 | (defun tmap-remove-func (m iterations) 78 | (declare (type gmap m) 79 | (type fixnum iterations)) 80 | (let ((max -1)) 81 | (dotimes (i iterations max) 82 | (let ((result 83 | (atomic 84 | (multiple-value-bind (key value present) (min-gmap m) 85 | (declare (ignore value)) 86 | (unless present (retry)) 87 | (rem-gmap m key) 88 | key)))) 89 | (setf max (max result max)))))) 90 | 91 | 92 | 93 | #?+bt/make-thread 94 | (defun test-tmap-threads (&key (thread-pairs 4) 95 | (iterations #+x86-64 1000 #-x86-64 100)) 96 | (declare (type fixnum thread-pairs iterations)) 97 | 98 | (start-multithreading) 99 | 100 | (let ((m (new 'tmap :pred 'fixnum<))) 101 | 102 | (flet ((tmap-insert () 103 | (tmap-insert-func m iterations)) 104 | (tmap-remove () 105 | (tmap-remove-func m iterations))) 106 | 107 | (let ((threads (loop for i below thread-pairs 108 | collect (start-thread #'tmap-insert :name (format nil "tmap-insert-~S" i)) 109 | collect (start-thread #'tmap-remove :name (format nil "tmap-remove-~S" i))))) 110 | 111 | (loop for thread in threads 112 | do (let ((x (wait4-thread thread))) 113 | (log:debug "thread ~A returned ~A" (thread-name thread) x) 114 | x)) 115 | (when (boundp 'fiveam::current-test) 116 | (is (= 0 (gmap-count m)))))))) 117 | 118 | 119 | #?+bt/make-thread 120 | (def-test tmap-threads (:compile-at :definition-time) 121 | (test-tmap-threads)) 122 | 123 | -------------------------------------------------------------------------------- /util/tcell.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 :stmx.util) 17 | 18 | ;;;; ** Transactional cell, it can be empty or hold a single value 19 | 20 | (declaim (type symbol +unbound-tvar+)) 21 | (defconstant +empty-tcell+ '+empty-tcell+ 22 | "Empty TCELL objects actually contain this symbol in their VALUE slot. Use with care.") 23 | 24 | (transactional 25 | (defclass tcell () 26 | ((value :initarg :value 27 | :initform +empty-tcell+)))) 28 | 29 | (declaim (ftype (function (&optional t) (values tcell &optional)) tcell)) 30 | 31 | (defun tcell (&optional (value +empty-tcell+)) 32 | "Create and return a new TCELL." 33 | (new 'tcell :value value)) 34 | 35 | ;; no need to wrap empty? in a transaction: 36 | ;; (_ cell value) is atomic, transaction aware, and performs a single read 37 | (defmethod empty? ((cell tcell)) 38 | (eq (_ cell value) +empty-tcell+)) 39 | 40 | 41 | (defmethod empty! ((cell tcell)) 42 | "Remove value from CELL. Return CELL." 43 | (fast-atomic 44 | (setf (_ cell value) +empty-tcell+) 45 | cell)) 46 | 47 | ;; no need to specialize (full?) on CELLs: the method in cell.lisp is enough 48 | ;; 49 | ;; (defmethod full? ((cell cell)) 50 | ;; (not (empty? cell))) 51 | 52 | 53 | ;; no need to wrap peek in a transaction: 54 | ;; (_ cell value) is atomic, transaction aware, and performs a single read 55 | (defmethod peek ((cell tcell) &optional default) 56 | (let1 value (_ cell value) 57 | (if (eq value +empty-tcell+) 58 | (values default nil) 59 | (values value t)))) 60 | 61 | 62 | (defmethod take ((cell tcell)) 63 | (fast-atomic 64 | (let1 value (_ cell value) 65 | (if (eq value +empty-tcell+) 66 | (retry) 67 | (progn 68 | (setf (_ cell value) +empty-tcell+) 69 | value))))) 70 | 71 | 72 | (defmethod put ((cell tcell) value) 73 | (fast-atomic 74 | (if (empty? cell) 75 | (setf (_ cell value) value) 76 | (retry)))) 77 | 78 | 79 | (defmethod try-take ((cell tcell)) 80 | "hand-made, nonblocking version of (take place) for cells. 81 | less general but approx. 3 times faster (on SBCL 1.0.57.0.debian, 82 | Linux amd64) than the unspecialized (try-take place) which calls 83 | \(atomic (nonblocking (take place)))" 84 | (fast-atomic 85 | (let1 value (_ cell value) 86 | (if (eq value +empty-tcell+) 87 | nil 88 | (progn 89 | (setf (_ cell value) +empty-tcell+) 90 | (values t value)))))) 91 | 92 | 93 | (defmethod try-put ((cell tcell) value) 94 | "hand-made, nonblocking version of (put place) for tcells. 95 | less general but approx. 3 times faster (on SBCL 1.0.57.0.debian, 96 | Linux amd64) than the unspecialized (try-put place) which calls 97 | \(atomic (nonblocking (put place value)))" 98 | (fast-atomic 99 | (if (empty? cell) 100 | (values t (setf (_ cell value) value)) 101 | nil))) 102 | 103 | 104 | ;;;; ** Printing 105 | 106 | (defprint-object (obj tcell) 107 | ;; (value-of obj) works both inside and outside transactions. 108 | (let1 value (_ obj value) 109 | (if (eq value +empty-tcell+) 110 | (format t "empty") 111 | (format t "[~S]" value)))) 112 | 113 | #-(and) 114 | (defmethod print-object ((obj tcell) stream) 115 | (let1 value (_ obj value) 116 | (if (eq value +empty-tcell+) 117 | (format stream "#@(~S)" 'tcell) 118 | (format stream "#@(~S ~S ~S)" 'tcell :value value)))) 119 | -------------------------------------------------------------------------------- /example/long-hw-tx.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 :cl-user) 17 | 18 | 19 | (defpackage #:stmx.example5 20 | (:use #:cl #:stmx.asm #:stmx.lang)) 21 | 22 | (in-package :stmx.example5) 23 | 24 | 25 | (deftype non-negative-fixnum () '(and (integer 0) fixnum)) 26 | (deftype positive-fixnum () '(and (integer 1) fixnum)) 27 | 28 | (declaim (inline empty-tx)) 29 | (defun empty-tx (cell) 30 | "An empty HW transaction. Used to measure the overhead each HW transaction. 31 | On Intel Core i7 4770 @3.5GHz, the overhead is about 11 nanoseconds." 32 | (declare (type cons cell)) 33 | 34 | (when (= (transaction-begin) +transaction-started+) 35 | (let1 result (first cell) 36 | (transaction-end) 37 | result))) 38 | 39 | 40 | (defun simple-loop-tx (cell) 41 | "An HW transaction that loops on some simple arithmetic operation. 42 | Used to measure the maximum time a HW transaction can last and still 43 | have a significative chance to commit. 44 | On Intel Core i7 4770 @3.5GHz running Debian GNU/Linux 7 (x86_64) and SBCL 1.1.8 45 | with almost no load, some typical results are 46 | 0.1 milliseconds: maximum commit probability about 95% 47 | 0.3 milliseconds: maximum commit probability 65% to 80% 48 | 0.5 milliseconds: maximum commit probability 25% to 40% 49 | 1.0 milliseconds: maximum commit probability 10% to 25% 50 | Beyond that, maximum commit probability goes to zero very quickly." 51 | (declare (type cons cell)) 52 | 53 | (when (= (transaction-begin) +transaction-started+) 54 | (let1 n (the positive-fixnum (first cell)) 55 | (dotimes (i n) 56 | (incf (the fixnum (rest cell)))) 57 | (transaction-end) 58 | n))) 59 | 60 | 61 | (defun alloc-tx (cell) 62 | "At least on SBCL, trying to allocate - even ONE SINGLE cons - 63 | inside a HW transaction appears to abort it with probability > 99.9%" 64 | (declare (type cons cell)) 65 | 66 | (let1 tx-length (the positive-fixnum (first cell)) 67 | 68 | (when (= (transaction-begin) +transaction-started+) 69 | (let1 result 70 | (loop for i from (1- tx-length) downto 0 71 | collect i) 72 | (transaction-end) 73 | result)))) 74 | 75 | 76 | (defun run-tx-loop (&key (tx-length 1000) (runs (ceiling 1000000000 tx-length))) 77 | (declare (type positive-fixnum tx-length runs)) 78 | 79 | (let ((cell (cons 0 0)) 80 | (start (the positive-fixnum (get-internal-real-time))) 81 | (commits 0) 82 | (aborts 0)) 83 | 84 | (declare (type fixnum commits aborts)) 85 | 86 | (dotimes (i runs) 87 | (setf (first cell) tx-length 88 | (rest cell) 0) 89 | 90 | (let1 result (alloc-tx cell) 91 | 92 | (if (null result) 93 | (incf aborts) 94 | (incf commits)))) 95 | 96 | (let* ((end (the positive-fixnum (get-internal-real-time))) 97 | (elapsed-secs (/ (- (float end) start) internal-time-units-per-second))) 98 | 99 | (log:info "~A runs, tx-length ~A" runs tx-length) 100 | 101 | (log:info "~A commits, ~A aborts (~2$%) in ~S seconds" 102 | commits aborts 103 | (if (zerop commits) 104 | 100 105 | (* 100 (/ (float aborts) (+ commits aborts)))) 106 | elapsed-secs) 107 | 108 | (log:info "avg. time in each transaction ~S microseconds" 109 | (* 1000000 (/ elapsed-secs runs)))))) 110 | 111 | -------------------------------------------------------------------------------- /util/package.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 | ;;;; * STMX.UTIL 17 | 18 | (in-package :cl-user) 19 | 20 | (defpackage #:stmx.util 21 | 22 | (:use #:cl 23 | #:stmx.lang 24 | #:stmx) 25 | 26 | ;; no need for closer-mop version of typep and subtypep; 27 | ;; they even cause some tests to fail 28 | #+cmucl 29 | (:shadowing-import-from #:cl 30 | #:typep 31 | #:subtypep) 32 | 33 | (:import-from #:alexandria 34 | #:symbolicate) 35 | 36 | (:import-from #:stmx 37 | #:+dummy-tvar+ #:peek-$ #:try-take-$ #:try-put-$) 38 | 39 | (:export #:tcell #:tfifo #:tstack #:tchannel #:tport ;; transactional containers 40 | 41 | #:full? #:empty? #:empty! ;; methods for transactional containers 42 | #:peek #:take #:put 43 | #:try-take #:try-put 44 | 45 | ;; optimized versions of < > = /= useful with sorted maps 46 | #:fixnum< #:fixnum> 47 | #:fixnum= #:fixnum/= 48 | 49 | #:gmap ;; abstract, generic sorted binary map - see rbmap and tmap implementations 50 | #:rbmap ;; sorted map, implemented with red-black trees 51 | #:tmap ;; transactional sorted map, implemented with red-black trees 52 | 53 | #:gmap-pred #:gmap-count #:gmap-empty? 54 | #:clear-gmap #:copy-gmap #:copy-gmap-into 55 | #:get-gmap #:set-gmap #:rem-gmap ;; also (setf (get-gmap ...) ...) 56 | #:min-gmap #:max-gmap ;; get smallest and largest key/value 57 | #:map-gmap #:do-gmap ;; iterate on gmap or tmap 58 | #:gmap-keys #:gmap-values #:gmap-pairs ;; list all keys, values, or pairs 59 | #:add-to-gmap #:remove-from-gmap ;; add or remove multiple keys 60 | 61 | ;; generic hash table - can be used directly, 62 | ;; see thash-table for a transactional implementation 63 | #:ghash-table 64 | ;; transactional hash table (extends ghash-table) 65 | #:thash-table 66 | 67 | #:ghash-table-test #:ghash-table-hash 68 | #:ghash-table-count #:ghash-table-empty? #:clear-ghash 69 | #:get-ghash #:set-ghash #:rem-ghash ;; also (setf (get-ghash ... ) ... ) 70 | #:map-ghash #:do-ghash ;; iterate on ghash-table or thash-table 71 | ;; list all keys, values, or pairs: 72 | #:ghash-keys #:ghash-values #:ghash-pairs 73 | ;; hash function suitable for :test 'equalp 74 | #:sxhash-equalp 75 | 76 | ;; transactional simple-vector 77 | #:simple-tvector #:simple-tvector-length 78 | #:tsvref #:do-simple-tvector 79 | 80 | ;; transactional CONS cell and list 81 | #:tcons #:tfirst #:trest #:tconsp #:tatom #:tpush #:tpop 82 | #:tlist #:tcar #:tcdr #:tcaar #:tcadr #:tcdar #:tcddr 83 | #:tcaaar #:tcaadr #:tcadar #:tcaddr #:tcdaar #:tcdadr #:tcddar #:tcdddr 84 | 85 | #:tcaaaar #:tcaaadr #:tcaadar #:tcaaddr #:tcadaar #:tcadadr #:tcaddar #:tacdddr 86 | #:tcdaaar #:tcdaadr #:tcdadar #:tcdaddr #:tcddaar #:tcddadr #:tcdddar #:taddddr 87 | 88 | #:tendp #:tlist-length #:tnthcdr #:tnth 89 | #:tsecond #:tthird #:tfourth #:tfifth #:tsixth #:tseventh #:teighth #:tninth #:ttenth 90 | #:ttree-equal #:ttree-equal-test #:ttree-equal-test-not 91 | #:tlast #:tlist* #:make-tlist 92 | 93 | #:tacons #:tpairlis #:copy-talist #:tassoc #:trassoc)) 94 | 95 | 96 | 97 | 98 | -------------------------------------------------------------------------------- /doc/benchmark-ccl64.md: -------------------------------------------------------------------------------- 1 | STMX Performance 2 | ---------------- 3 | 4 | This document is an addition to benchmark.md. Please read it first. 5 | 6 | What follows are some timings obtained on the authors's system, and by no means they 7 | claim to be exact, absolute or reproducible: your mileage may vary. 8 | 9 | Date: 29 June 2013 10 | 11 | Hardware: Intel Core-i7 4770 @3.5 GHz (quad-core w/ hyper-threading), 16GB RAM 12 | 13 | Software: Debian GNU/Linux 7.0 (x86_64), CCL 1.9-r15769 (x86_64), STMX 1.3.3 14 | 15 | 16 | 17 | 21 | 22 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 |
18 | Concurrent benchmarks on a 4-core CPU. They already iterate 19 | ten million times, do not wrap them in (1m ...). 20 |
23 | Dining philosophers, load with
24 | (load "stmx/example/dining-philosophers-stmx.lisp")
25 | (load "stmx/example/dining-philosophers-hw-tx.lisp")
26 | (load "stmx/example/dining-philosophers-lock.lisp")
27 | (in-package :stmx.example{1|2|3}) 28 |
number of threadsexecuted codeSTMX (sw transactions)HW-TX (hw transactions)LOCK (atomic compare-and-swap)LOCK (bordeaux-threads mutex)
millions transactions per second
1 thread(dining-philosophers 1)0.639 8.39
2 threads(dining-philosophers 2)1.115 4.60
3 threads(dining-philosophers 3)0.978 4.96
4 threads(dining-philosophers 4)0.927 6.05
5 threads(dining-philosophers 5)0.937 7.56
6 threads(dining-philosophers 6)0.892 7.54
7 threads(dining-philosophers 7)0.858 8.34
8 threads(dining-philosophers 8)0.864 7.11
10 threads(dining-philosophers 10)0.797 11.63
15 threads(dining-philosophers 15)0.657 14.96
20 threads(dining-philosophers 20)0.066 19.33
30 threads(dining-philosophers 30)0.061 20.42
40 threads(dining-philosophers 40)0.095 19.76
50 threads(dining-philosophers 50)0.125 19.25
100 threads(dining-philosophers 100)0.092 18.11
200 threads(dining-philosophers 200)0.053 17.70
104 | -------------------------------------------------------------------------------- /test/retry.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 :stmx.test) 17 | 18 | (enable-#?-syntax) 19 | 20 | (def-suite retry-suite :in suite) 21 | (in-suite retry-suite) 22 | 23 | (defun cell-test () 24 | (let1 c (tcell 1) 25 | (is-true (full? c)) 26 | (empty! c) 27 | (is-true (empty? c)) 28 | (put c 2) 29 | (is-true (full? c)) 30 | (is-true (= (take c) 2)) 31 | (is-true (empty? c)))) 32 | 33 | (def-test cell (:compile-at :definition-time) 34 | (cell-test)) 35 | 36 | (def-test cell-atomic (:compile-at :definition-time) 37 | (atomic (cell-test))) 38 | 39 | 40 | (defun retry-funs (n c1 c2) 41 | (declare (type fixnum n) 42 | (type tcell c1 c2)) 43 | 44 | (flet ((retry-left () 45 | (let1 x 0.0f0 46 | (declare (type single-float x)) 47 | (dotimes (i n) 48 | (log.trace " <= R") 49 | (setf x (take c2)) 50 | (log.trace " <= ~A <= R" x) 51 | (put c1 x) 52 | (log.trace "L <= ~A" x)) 53 | (log.debug "left ~A in L" x) 54 | x)) 55 | 56 | (retry-right () 57 | (let1 x 0.0f0 58 | (declare (type single-float x)) 59 | (dotimes (i n) 60 | (log.trace "L =>") 61 | (setf x (take c1)) 62 | (log.trace "L => ~A +>" x) 63 | (incf x) 64 | (put c2 x) 65 | (log.trace " ~A => R" x)) 66 | (log.debug "left ~A in R" x) 67 | x))) 68 | (values #'retry-left #'retry-right))) 69 | 70 | (defun retry-threads (&key (two-tokens nil) (thread-pairs 2) (iterations 100)) 71 | (declare (type fixnum thread-pairs iterations)) 72 | 73 | (start-multithreading) 74 | 75 | (let ((c1 (tcell)) ;; cells have unbound value 76 | (c2 (tcell))) 77 | 78 | (multiple-value-bind (f1 f2) (retry-funs iterations c1 c2) 79 | 80 | (let ((ths (loop for i below thread-pairs 81 | collect (start-thread f1 :name (format nil "retry-left-~S" i)) 82 | collect (start-thread f2 :name (format nil "retry-right-~S" i))))) 83 | (atomic 84 | (when two-tokens 85 | (put c1 0.0f0)) 86 | (put c2 0.5f0)) 87 | 88 | (let1 xs (loop for th in ths 89 | collect (wait4-thread th)) 90 | 91 | (values xs (atomic (list (peek c1) (peek c2))))))))) 92 | 93 | 94 | (defun retry-threads-test (threads iterations) 95 | (let* ((thread-pairs (truncate (1+ threads) 2)) 96 | (expected (+ 0.5f0 (* thread-pairs iterations)))) 97 | 98 | (multiple-value-bind (xs cs) 99 | (retry-threads :two-tokens nil :thread-pairs thread-pairs :iterations iterations) 100 | (destructuring-bind (c1 c2) cs 101 | (is-true (null c1)) 102 | (is-true (= expected c2)) 103 | (is-true (= expected (apply #'max xs))))) 104 | 105 | (multiple-value-bind (xs cs) 106 | (retry-threads :two-tokens t :thread-pairs thread-pairs :iterations iterations) 107 | (destructuring-bind (c1 c2) cs 108 | (is-true (not (null c1))) 109 | (is-true (not (null c2))) 110 | (is-true (= expected (+ c1 c2))) 111 | (is-true (= (max c1 c2) (apply #'max xs))))))) 112 | 113 | 114 | #?+bt/make-thread 115 | (def-test retry-threads (:compile-at :definition-time) 116 | #+(and sbcl (or x86 x86-64)) (retry-threads-test 8 10000) 117 | #-(and sbcl (or x86 x86-64)) (retry-threads-test 4 1000)) 118 | -------------------------------------------------------------------------------- /doc/benchmark-abcl.md: -------------------------------------------------------------------------------- 1 | STMX Performance 2 | ---------------- 3 | 4 | This document is an addition to benchmark.md. Please read it first. 5 | 6 | What follows are some timings obtained on the authors's system, and by no means they 7 | claim to be exact, absolute or reproducible: your mileage may vary. 8 | 9 | Date: 29 June 2013 10 | 11 | Hardware: Intel Core-i7 4770 @3.5 GHz (quad-core w/ hyper-threading), 16GB RAM 12 | 13 | Software: Debian GNU/Linux 7.0 (x86_64), OpenJDK 6b27-1.12.5-2 (x86_64), 14 | ABCL 1.1.1, STMX 1.3.3 15 | 16 | 17 | 18 | 22 | 23 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 |
19 | Concurrent benchmarks on a 4-core CPU. They already iterate 20 | ten million times, do not wrap them in (1m ...). 21 |
24 | Dining philosophers, load with
25 | (load "stmx/example/dining-philosophers-stmx.lisp")
26 | (load "stmx/example/dining-philosophers-hw-tx.lisp")
27 | (load "stmx/example/dining-philosophers-lock.lisp")
28 | (in-package :stmx.example{1|2|3}) 29 |
number of threadsexecuted codeSTMX (sw transactions)HW-TX (hw transactions)LOCK (atomic compare-and-swap)LOCK (bordeaux-threads mutex)
millions transactions per second
1 thread(dining-philosophers 1)0.071 0.575
2 threads(dining-philosophers 2)0.143 0.558
3 threads(dining-philosophers 3)0.206 0.561
4 threads(dining-philosophers 4)0.241 0.698
5 threads(dining-philosophers 5)0.246 0.803
6 threads(dining-philosophers 6)0.241 0.954
7 threads(dining-philosophers 7)0.269 1.096
8 threads(dining-philosophers 8)0.276 1.209
10 threads(dining-philosophers 10)0.124 1.424
15 threads(dining-philosophers 15)0.122 1.845
20 threads(dining-philosophers 20)0.129 2.048
30 threads(dining-philosophers 30)0.139 2.130
40 threads(dining-philosophers 40)0.153 2.154
50 threads(dining-philosophers 50)0.163 2.160
100 threads(dining-philosophers 100)0.162 2.156
200 threads(dining-philosophers 200)0.160 2.164
105 | -------------------------------------------------------------------------------- /lang/package.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 | ;;;; * STMX 17 | 18 | (in-package :cl-user) 19 | 20 | (defpackage #:stmx.lang 21 | (:use #:cl 22 | #:bordeaux-threads) 23 | 24 | (:export #:define-global #:define-constant-once 25 | 26 | #:do-tree 27 | #:stringify #:concat-symbols 28 | #:with-gensym #:with-gensyms 29 | #:eval-always #:new #:let1 30 | #:when-bind #:awhen 31 | #:if-bind #:aif 32 | 33 | #:enable-#?-syntax 34 | #:set-feature #:set-features #:default-feature #:default-features 35 | #:get-feature #:all-features #:assoc-feature 36 | 37 | #:log.trace #:log.debug #:log.make-logger 38 | 39 | ;; bordeaux-threads helpers 40 | #:start-multithreading 41 | #:start-thread #:wait4-thread 42 | #:*current-thread* 43 | #:with-lock 44 | #:ensure-thread-initial-binding 45 | #:ensure-thread-initial-bindings 46 | #:save-thread-initial-bindings 47 | 48 | ;; cons pool 49 | #:cons^ #:free-cons^ #:free-list^ 50 | #:push^ #:pop-free-cons^ 51 | 52 | ;; hardware memory transactions. see also feature #?+hw-transactions 53 | #:hw-transaction-supported? 54 | #:hw-transaction-begin 55 | #:hw-transaction-running? 56 | #:hw-transaction-abort 57 | #:hw-transaction-end 58 | #:hw-transaction-rerun-may-succeed? 59 | ;; returned by (hw-transaction-begin) if successful 60 | #:+hw-transaction-started+ 61 | ;; cached result of (hw-transaction-supported?) 62 | #:+hw-transaction-supported+ 63 | ;; equivalent to (and +hw-transaction-supported+ (hw-transaction-running?)) 64 | #:hw-transaction-supported-and-running? 65 | 66 | ;; atomic operations 67 | #:atomic-num 68 | #:atomic-incf #:atomic-decf 69 | #:atomic-compare-and-swap #:atomic-pop 70 | #:mem-read-barrier #:mem-write-barrier 71 | 72 | #:atomic-counter-slot-type #:atomic-counter-num 73 | #:atomic-counter #:make-atomic-counter 74 | #:atomic-counter-mutex ;; exists only if feature #?+fast-atomic-counter is not set 75 | 76 | #:incf-atomic-counter #:incf-atomic-place 77 | #:set-atomic-counter #:set-atomic-place 78 | #:get-atomic-counter #:get-atomic-place 79 | #:get-atomic-counter-plus-delta #:get-atomic-place-plus-delta 80 | 81 | 82 | #:mutex #:make-mutex 83 | #:mutex-owner #:mutex-lock 84 | #:try-acquire-mutex #:try-acquire-mutex/catch-recursion 85 | #:release-mutex 86 | #:mutex-is-free? #:mutex-is-own? 87 | #:mutex-is-own-or-free? 88 | 89 | #:fast-vector #:make-fast-vector 90 | #:fast-vector-length #:fast-vector-capacity 91 | #:fast-vector-pop #:fast-vector-pop-macro 92 | #:fast-vector-push #:fast-vector-push-extend 93 | #:fast-vector-clear #:do-fast-vector 94 | 95 | #:get-hash #:set-hash ;; also (setf get-hash) 96 | #:rem-hash #:clear-hash #:do-hash 97 | 98 | #:hash-table-keys #:hash-table-values #:hash-table-pairs 99 | #:copy-hash-table #:merge-hash-tables 100 | 101 | #:id-of ;; also (setf id-of) 102 | #:~ ;; also (setf ~) 103 | 104 | #:defprint-object 105 | 106 | #:clos-compute-class-precedence-list)) 107 | -------------------------------------------------------------------------------- /main/tvar-slot.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 :stmx) 17 | 18 | (enable-#?-syntax) 19 | 20 | (optimize-for-transaction 21 | (defun $-slot (var) 22 | "Get the value from the transactional variable VAR and return it. 23 | Signal an error if VAR is not bound to a value. 24 | 25 | Works both inside and outside transactions. 26 | During transactions, it uses transaction log to record the read 27 | and to check for any value stored in the log." 28 | (declare (type tvar var)) 29 | 30 | (let1 value ($ var) 31 | (unless (eq value +unbound-tvar+) 32 | (return-from $-slot value)) 33 | (unbound-tvar-error var)))) 34 | 35 | 36 | (optimize-for-transaction* 37 | (:inline t) 38 | (defun (setf $-slot) (value var) 39 | (declare (type tvar var)) 40 | (setf ($ var) value))) 41 | 42 | 43 | ;;;; ** Accessors 44 | 45 | 46 | (defgeneric value-of (place)) 47 | (defgeneric (setf value-of) (value place)) 48 | 49 | (defmethod value-of ((var tvar)) 50 | "Return the value inside a TVAR. Works both outside and inside transactions. 51 | Equivalent to ($-slot var)" 52 | ($-slot var)) 53 | 54 | (defmethod (setf value-of) (value (var tvar)) 55 | "Set the value inside a TVAR. Works both outside and inside transactions. 56 | Equivalent to (setf ($-slot var) value)" 57 | (setf ($-slot var) value)) 58 | 59 | 60 | 61 | (optimize-for-transaction 62 | (defun bound-$? (var) 63 | "Return true if transactional variable VAR is bound to a value. 64 | Works both outside and inside transactions. 65 | 66 | During transactions, it uses transaction log to record the read 67 | and to check for any value stored in the log." 68 | (declare (type tvar var)) 69 | 70 | (not (eq +unbound-tvar+ ($ var))))) 71 | 72 | 73 | (optimize-for-transaction 74 | (defun unbind-$ (var) 75 | "Unbind the value inside transactional variable VAR. 76 | Works both outside and inside transactions. 77 | 78 | During transactions, it uses transaction log to record the 'unbound' value." 79 | (declare (type tvar var)) 80 | 81 | (setf ($ var) +unbound-tvar+) 82 | var)) 83 | 84 | 85 | (optimize-for-transaction 86 | (defun peek-$ (var &optional default) 87 | "Get the value from the transactional variable VAR 88 | and return it and t as multiple values. 89 | If VAR is not bound to a value, return (values DEFAULT nil). 90 | 91 | Works both inside and outside transactions." 92 | (declare (type tvar var)) 93 | 94 | (let1 value ($ var) 95 | (if (eq value +unbound-tvar+) 96 | (values default nil) 97 | (values value t))))) 98 | 99 | 100 | (optimize-for-transaction 101 | (defun try-take-$ (var &optional default) 102 | "Get the value from the transactional variable VAR, 103 | unbind it and and return t and the original value as multiple values. 104 | If VAR is not bound to a value, return (values nil DEFAULT). 105 | 106 | Works both inside and outside transactions." 107 | (declare (type tvar var)) 108 | 109 | (let1 value ($ var) 110 | (if (eq value +unbound-tvar+) 111 | (values nil default) 112 | (progn 113 | (setf ($ var) +unbound-tvar+) 114 | (values t value)))))) 115 | 116 | 117 | (optimize-for-transaction 118 | (defun try-put-$ (var value &optional default) 119 | "If VAR is not bound, bind it to VALUE and return (values VALUE t) 120 | If VAR is already bound to a value, return (values DEFAULT nil). 121 | 122 | Works only inside software transactions." 123 | (declare (type tvar var)) 124 | 125 | (let1 old-value ($ var) 126 | (if (eq old-value +unbound-tvar+) 127 | (values t (setf ($ var) value)) 128 | (values nil default))))) 129 | -------------------------------------------------------------------------------- /doc/benchmark-cmucl.md: -------------------------------------------------------------------------------- 1 | STMX Performance 2 | ---------------- 3 | 4 | This document is an addition to benchmark.md. Please read it first. 5 | 6 | What follows are some timings obtained on the authors's system, and by no means they 7 | claim to be exact, absolute or reproducible: your mileage may vary. 8 | 9 | Date: 29 June 2013 10 | 11 | Hardware: Intel Core-i7 4770 @3.5 GHz (quad-core w/ hyper-threading), 16GB RAM 12 | 13 | Software: Debian GNU/Linux 7.0 (x86_64), CMUCL 20d Unicode (x86), STMX 1.3.3 14 | 15 | Note that CMUCL is stated to support "user level" threads on Linux/x86, not native threads. 16 | So don't expect performance improvements by running more than one thread... :( 17 | 18 | 19 | 20 | 24 | 25 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 |
21 | Concurrent benchmarks on a 4-core CPU. They already iterate 22 | ten million times, do not wrap them in (1m ...). 23 |
26 | Dining philosophers, load with
27 | (load "stmx/example/dining-philosophers-stmx.lisp")
28 | (load "stmx/example/dining-philosophers-hw-tx.lisp")
29 | (load "stmx/example/dining-philosophers-lock.lisp")
30 | (in-package :stmx.example{1|2|3}) 31 |
number of threadsexecuted codeSTMX (sw transactions)HW-TX (hw transactions)LOCK (atomic compare-and-swap)LOCK (bordeaux-threads mutex)
millions transactions per second
1 thread(dining-philosophers 1)0.102 0.194
2 threads(dining-philosophers 2)0.075 0.108
3 threads(dining-philosophers 3)0.077 0.116
4 threads(dining-philosophers 4)0.077 0.122
5 threads(dining-philosophers 5)0.077 0.124
6 threads(dining-philosophers 6)0.078 0.127
7 threads(dining-philosophers 7)0.078 0.128
8 threads(dining-philosophers 8)0.078 0.130
10 threads(dining-philosophers 10)0.078 0.132
15 threads(dining-philosophers 15)0.078
20 threads(dining-philosophers 20)
30 threads(dining-philosophers 30)
40 threads(dining-philosophers 40)
50 threads(dining-philosophers 50)
100 threads(dining-philosophers 100)
200 threads(dining-philosophers 200)
107 | -------------------------------------------------------------------------------- /lang/macro.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 :stmx.lang) 17 | 18 | 19 | ;;;; * Miscellaneous macros 20 | 21 | (defun visit-tree (function tree &optional result) 22 | (let ((function (coerce function 'function))) 23 | (labels ((%visit-tree (tree) 24 | (dolist (e tree) 25 | (if (consp e) 26 | (%visit-tree e) 27 | (funcall function e))))) 28 | (%visit-tree tree) 29 | result))) 30 | 31 | 32 | (defmacro do-tree ((atom tree &optional result) &body body) 33 | "Execute BODY for each atom inside TREE" 34 | `(visit-tree (lambda (,atom) ,@body) ,tree ,result)) 35 | 36 | 37 | (defun stringify (&rest things) 38 | "Print the things to a string and return it" 39 | (let ((s (make-array 0 :element-type 'character :adjustable t :fill-pointer 0)) 40 | (*print-array* t) 41 | (*print-base* 10) 42 | (*print-escape* nil) 43 | (*print-gensym* nil) 44 | (*print-pretty* nil) 45 | (*print-radix* nil) 46 | (*print-readably* nil)) 47 | (do-tree (thing things s) 48 | (format s "~A" thing)))) 49 | 50 | (defun concat-symbols (&rest things) 51 | "Print the things to a string, the convert the string into a symbol interned in current package. 52 | Return the symbol" 53 | (values (intern (apply #'stringify things) *package*))) 54 | 55 | 56 | 57 | (defmacro with-gensym (name &body body) 58 | (let ((sym (if (consp name) (first name) name)) 59 | (str (if (consp name) `(stringify ,@(rest name) '-) (stringify name '-)))) 60 | `(let ((,sym (gensym ,str))) 61 | ,@body))) 62 | 63 | (defmacro with-gensyms ((&rest names) &body body) 64 | `(let ,(loop for name in names 65 | for sym = (if (consp name) (first name) name) 66 | for str = (if (consp name) `(stringify ,@(rest name) '-) (stringify name '-)) 67 | collect `(,sym (gensym ,str))) 68 | ,@body)) 69 | 70 | ;;;; ** A minimal clean-room reimplementation of some macros found in ARNESI 71 | 72 | 73 | (defmacro new (class &rest initargs &key &allow-other-keys) 74 | `(make-instance ,class ,@initargs)) 75 | 76 | 77 | (defmacro eval-always (&body body) 78 | `(eval-when (:compile-toplevel :load-toplevel :execute) 79 | ,@body)) 80 | 81 | 82 | (defmacro let1 (var value &body body) 83 | `(let ((,var ,value)) 84 | ,@body)) 85 | 86 | 87 | (defmacro when-bind (var test &body body) 88 | `(let1 ,var ,test 89 | (when ,var 90 | ,@body))) 91 | 92 | 93 | (defvar +it+ (symbol-name 'it)) 94 | 95 | (defmacro awhen (test &body body) 96 | (let1 it (intern +it+ *package*) 97 | `(when-bind ,it ,test 98 | ,@body))) 99 | 100 | 101 | (defmacro if-bind (var test then &optional else) 102 | `(let1 ,var ,test 103 | (if ,var 104 | ,then 105 | ,else))) 106 | 107 | 108 | (defmacro aif (test then &optional else) 109 | (let1 it (intern +it+ *package*) 110 | `(if-bind ,it ,test 111 | ,then 112 | ,else))) 113 | 114 | ;;;; ** Logging macros. 115 | ;; 116 | ;; Yes, I am so concerned with speed that even wasting some nanoseconds 117 | ;; in a disabled (log:trace) is annoying 118 | 119 | 120 | #| 121 | (defmacro log.debug (&rest args) 122 | `(log:debug ,@args)) 123 | 124 | (defmacro log.trace (&rest args) 125 | `(log:trace ,@args)) 126 | 127 | (defmacro log.make-logger (&rest args) 128 | `(log:make ,@args)) 129 | |# 130 | 131 | 132 | (defmacro log.debug (&rest args) 133 | (declare (ignore args)) 134 | nil) 135 | 136 | (defmacro log.trace (&rest args) 137 | (declare (ignore args)) 138 | nil) 139 | 140 | (defmacro log.make-logger (&rest args) 141 | (declare (ignore args)) 142 | nil) 143 | -------------------------------------------------------------------------------- /util/tchannel.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 :stmx.util) 17 | 18 | ;;;; ** Transactional multicast channel with multiple readers (ports) 19 | 20 | (transactional 21 | (defclass tchannel () 22 | ((back :type tcons :initform (tcons nil nil) :accessor back-of)) 23 | (:documentation "Transactional multicast channel supporting unlimited reading ports. 24 | Values written into the tchannel are available to all reading ports in the same order. 25 | 26 | References to values written into the tchannel are kept only as long as 27 | one or more ports still need to read them."))) 28 | 29 | 30 | (defmethod empty? ((c tchannel)) 31 | "Tchannels are write-only: it is never possible to read values from them, 32 | so assume they are always empty and return t." 33 | t) 34 | 35 | (defmethod full? ((c tchannel)) 36 | "Tchannels can contain unlimited values: they are never full, so always return nil." 37 | nil) 38 | 39 | (transaction 40 | (defmethod put ((c tchannel) value) 41 | "Append VALUE as last element in tchannel C and return VALUE. 42 | Since tchannel can contain unlimited values, this method never blocks." 43 | (with-rw-slots (back) c 44 | (let1 cell (tcons nil nil) 45 | (setf (tfirst back) value 46 | (trest back) cell 47 | back cell))) 48 | value)) 49 | 50 | (defmethod try-put ((c tchannel) value) 51 | "Append VALUE to tchannel C and return (values t VALUE). 52 | Since tchannel can contain unlimited values, this method never fails." 53 | (values t (put c value))) 54 | 55 | 56 | 57 | 58 | 59 | ;;;; ** Transactional reading port for multicast tchannel 60 | 61 | (transactional 62 | (defclass tport () 63 | ((front :type cons :accessor front-of) 64 | (channel :type tchannel 65 | :initform (error "missing :channel argument instantiating ~A or a subclass" 'tport) 66 | :initarg :channel 67 | :reader channel-of 68 | :transactional nil)) 69 | (:documentation "Transactional reading port for a multicast tchannel. 70 | Values written into the tchannel are available to all reading ports in the same order."))) 71 | 72 | 73 | (defun tchannel-back-of (p) 74 | (declare (type tport p)) 75 | (_ (_ p channel) back)) 76 | 77 | (defun tport-empty? (p) 78 | (declare (type tport p)) 79 | (eq (_ p front) (tchannel-back-of p))) 80 | 81 | 82 | (defmethod initialize-instance :after ((p tport) &key &allow-other-keys) 83 | "Initialize the reading tport P for a multicast tchannel." 84 | (setf (_ p front) (tchannel-back-of p))) 85 | 86 | (transaction 87 | (defmethod empty? ((p tport)) 88 | (tport-empty? p))) 89 | 90 | (transaction 91 | (defmethod empty! ((p tport)) 92 | (setf (_ p front) (tchannel-back-of p)) 93 | p)) 94 | 95 | (defmethod full? ((p tport)) 96 | "Tports are read-only: it is never possible to store values in them, 97 | so assume they are always full and return t." 98 | t) 99 | 100 | 101 | (transaction 102 | (defmethod peek ((p tport) &optional default) 103 | "Return the first value in tport P without removing it, and t as multiple values. 104 | Return (values DEFAULT nil) if P contains no value." 105 | (if (tport-empty? p) 106 | (values default nil) 107 | (values (tfirst (_ p front)) t)))) 108 | 109 | 110 | (transaction 111 | (defmethod take ((p tport)) 112 | "Wait until tport P contains at least one value, 113 | then remove and return the first value." 114 | (if (tport-empty? p) 115 | (retry) 116 | (tpop (_ p front))))) 117 | 118 | 119 | (transaction 120 | (defmethod try-take ((p tport)) 121 | "If tport P contains at least one value, remove the first value 122 | and return t and the first value as multiple values. 123 | Otherwise return (values nil nil)" 124 | (if (tport-empty? p) 125 | (values nil nil) 126 | (values t (tpop (_ p front)))))) 127 | -------------------------------------------------------------------------------- /lang/features.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 :stmx.lang) 17 | 18 | (eval-always 19 | 20 | (pushnew :stmx *features*) 21 | 22 | (declaim (type list *feature-list*)) 23 | (defvar *feature-list* nil) 24 | 25 | (defun intern-feature (f) 26 | (declare (type symbol f)) 27 | (if (keywordp f) 28 | f 29 | (the keyword (intern (symbol-name f) :keyword)))) 30 | 31 | (defun assoc-feature (f) 32 | "Return (list F VALUE) if F is present in *FEATURE-LIST*" 33 | (declare (type symbol f)) 34 | (assoc (intern-feature f) *feature-list*)) 35 | 36 | (defun get-feature (f &optional default) 37 | "Return value of F in *FEATURE-LIST* and T, or (values DEFAULT NIL) if not present 38 | or has NIL value." 39 | (declare (type symbol f)) 40 | (let ((value (second (assoc-feature f)))) 41 | (if value 42 | (values value t) 43 | (values default nil)))) 44 | 45 | (defun all-features (&rest list) 46 | "Return T if all features from LIST are present in *FEATURE-LIST* 47 | and have non-NIL value." 48 | (declare (type list list)) 49 | (loop for f in list 50 | always (get-feature f))) 51 | 52 | (defun some-features (&rest list) 53 | "Return T if at least one feature from LIST is present in *FEATURE-LIST* 54 | and have non-NIL value." 55 | (declare (type list list)) 56 | (loop for f in list 57 | thereis (get-feature f))) 58 | 59 | (defun rem-feature (f) 60 | "Remove feature F from *FEATURE-LIST*. 61 | Return T if F was present *FEATURE-LIST*, otherwise return NIL." 62 | (declare (type symbol f)) 63 | (when (assoc-feature f) 64 | (let1 f (intern-feature f) 65 | (setf *feature-list* 66 | (delete-if (lambda (pair) (eql f (first pair))) 67 | *feature-list*)) 68 | t))) 69 | 70 | (defun clear-features () 71 | "Remove all features from *FEATURE-LIST*." 72 | (setf *feature-list* nil)) 73 | 74 | (defun default-feature (f &optional (value t)) 75 | "Add feature F and its VALUE into *FEATURE-LIST*, unless F is already present. 76 | Return (values T VALUE) if F was actually inserted in *FEATURE-LIST*, 77 | otherwise return NIL and the value already present in *FEATURE-LIST*." 78 | (declare (type symbol f)) 79 | (let ((v (assoc-feature f))) 80 | (if v 81 | (values nil (rest v)) 82 | (progn 83 | (push (list (intern-feature f) value) *feature-list*) 84 | (values t value))))) 85 | 86 | (defun default-features (&rest alist) 87 | "Set the value of each feature in ALIST, unless the feature is already 88 | present in *FEATURE-LIST*. Each element in ALIST must be either 89 | a pair (FEATURE VALUE) or a simple atom FEATURE. 90 | In the latter case, the FEATURE value will default to T." 91 | (declare (type list alist)) 92 | (dolist (pair alist) 93 | (let ((feature (if (consp pair) (first pair) pair)) 94 | (value (if (consp pair) (second pair) t))) 95 | (default-feature feature value)))) 96 | 97 | 98 | (defun set-feature (f &optional (value t)) 99 | "Set feature F to VALUE, even if F is already present in *FEATURE-LIST*. 100 | Return VALUE." 101 | (declare (type symbol f)) 102 | (let* ((f (intern-feature f)) 103 | (pair (assoc f *feature-list*))) 104 | (if pair 105 | (setf (second pair) value) 106 | (push (list f value) *feature-list*)) 107 | value)) 108 | 109 | 110 | (defun set-features (&rest plist) 111 | "Set the value of each feature in PLIST, even if the feature is already 112 | present in *FEATURE-LIST*. Each element in PLIST must be either 113 | a pair (FEATURE VALUE) or a simple atom FEATURE. 114 | In the latter case, the FEATURE value will default to T." 115 | (declare (type list plist)) 116 | (dolist (pair plist) 117 | (let ((feature (if (consp pair) (first pair) pair)) 118 | (value (if (consp pair) (second pair) t))) 119 | (set-feature feature value))))) 120 | -------------------------------------------------------------------------------- /lang/atomic-ops.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 :stmx.lang) 17 | 18 | (enable-#?-syntax) 19 | 20 | ;;;; ** atomic operations 21 | 22 | 23 | #?+(eql atomic-ops :sbcl) 24 | (progn 25 | 26 | (deftype atomic-num () 27 | "ATOMIC-NUM must be a type suitable for ATOMIC-INCF and ATOMIC-DECF. 28 | STMX also assumes it is the same or wider than fixnum." 29 | 'sb-ext:word) 30 | 31 | (defmacro atomic-incf (place &optional (delta 1)) 32 | "Atomically increment PLACE by DELTA. Return _previous_ value of PLACE." 33 | `(sb-ext:atomic-incf ,place ,delta)) 34 | 35 | (defmacro atomic-decf (place &optional (delta 1)) 36 | "Atomically decrement PLACE by DELTA. Return _previous_ value of PLACE." 37 | `(sb-ext:atomic-decf ,place ,delta)) 38 | 39 | 40 | (deftype atomic-t () 41 | "ATOMIC-T must be a type suitable for ATOMIC-COMPARE-AND-SWAP. 42 | STMX assumes it can hold at least NIL and values of type BORDEAUX-THREADS:THREAD." 43 | 't) 44 | 45 | (defmacro atomic-compare-and-swap (place old new) 46 | `(sb-ext:compare-and-swap ,place ,old ,new)) 47 | 48 | (defmacro atomic-push (obj place) 49 | "Like PUSH, but atomic. PLACE may be read multiple times before 50 | the operation completes -- the write does not occur until such time 51 | that no other thread modified PLACE between the read and the write. 52 | 53 | Works only on places supported by ATOMIC-COMPARE-AND-SWAP." 54 | #?+(symbol sb-ext atomic-push) 55 | `(sb-ext:atomic-push ,obj ,place) 56 | 57 | #?-(symbol sb-ext atomic-push) 58 | (multiple-value-bind (vars vals old new cas-form read-form) 59 | (sb-ext:get-cas-expansion place) 60 | `(let* (,@(mapcar 'list vars vals) 61 | (,old ,read-form) 62 | (,new (cons ,obj ,old))) 63 | (loop until (eq ,old (setf ,old ,cas-form)) 64 | do (setf (cdr ,new) ,old) 65 | finally (return ,new))))) 66 | 67 | 68 | (defmacro atomic-pop (place) 69 | "Like POP, but atomic. PLACE may be read multiple times before 70 | the operation completes -- the write does not occur until such time 71 | that no other thread modified PLACE between the read and the write. 72 | 73 | Works only on places supported by ATOMIC-COMPARE-AND-SWAP." 74 | #?+(symbol sb-ext atomic-pop) 75 | `(sb-ext:atomic-pop ,place) 76 | 77 | #?-(symbol sb-ext atomic-pop) 78 | (multiple-value-bind (vars vals old new cas-form read-form) 79 | (sb-ext:get-cas-expansion place) 80 | `(let* (,@(mapcar 'list vars vals)) 81 | (loop for ,old = ,read-form 82 | for ,new = (cdr ,old) 83 | until (eq ,old (setf ,old ,cas-form)) 84 | finally (return (car ,old))))))) 85 | 86 | 87 | #?+(eql mem-rw-barriers :sbcl) 88 | (progn 89 | (defmacro mem-read-barrier (&body before) 90 | "Memory read barrier. Execute BEFORE, then put the barrier." 91 | `(sb-thread:barrier (:read) 92 | ,@before)) 93 | 94 | (defmacro mem-write-barrier (&body before) 95 | "Memory write barrier. Execute BEFORE, then put the barrier." 96 | `(sb-thread:barrier (:write) 97 | ,@before))) 98 | 99 | 100 | 101 | #?+(eql mem-rw-barriers :trivial) 102 | (progn 103 | (defmacro mem-read-barrier (&body before) 104 | "Trivial implementation of memory read barrier. It does nothing. 105 | Note: it does not even prevent the compiler from reordering generated 106 | assembler instructions, so use with EXTREME care." 107 | `(progn 108 | ,@before)) 109 | 110 | ;; generic implementation of memory read barrier 111 | (defmacro mem-write-barrier (&body before) 112 | "Trivial implementation of memory write barrier. It does nothing. 113 | Note: it does not even prevent the compiler from reordering generated 114 | assembler instructions, so use with EXTREME care." 115 | `(progn 116 | ,@before))) 117 | 118 | 119 | ;; avoid "unexpected EOF" compiler error 120 | ;; if atomic-ops and mem-rw-barriers are both undefined 121 | nil 122 | 123 | 124 | -------------------------------------------------------------------------------- /util/misc.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 :stmx.util) 17 | 18 | (enable-#?-syntax) 19 | 20 | (deftype ufixnum () `(integer 0 ,most-positive-fixnum)) 21 | 22 | ;;;; ** Some simple functions optimized for FIXNUMs 23 | 24 | (declaim (inline fixnum< fixnum> fixnum= fixnum/=)) 25 | 26 | (defun fixnum< (x y) 27 | "Optimized version of (< x y) for FIXNUM arguments" 28 | (declare (type fixnum x y)) 29 | (the boolean (< x y))) 30 | 31 | (defun fixnum> (x y) 32 | "Optimized version of (> x y) for FIXNUM arguments" 33 | (declare (type fixnum x y)) 34 | (the boolean (> x y))) 35 | 36 | 37 | (defun fixnum= (x y) 38 | "Optimized version of (= x y) for FIXNUM arguments" 39 | (declare (type fixnum x y)) 40 | (the boolean (= x y))) 41 | 42 | (defun fixnum/= (x y) 43 | "Optimized version of (/= x y) for FIXNUM arguments" 44 | (declare (type fixnum x y)) 45 | (the boolean (/= x y))) 46 | 47 | 48 | 49 | ;;;; ** generic comparison 50 | 51 | #+(and) 52 | (eval-always 53 | (defconstant k< -1) 54 | (defconstant k= 0) 55 | (defconstant k> +1)) 56 | 57 | #-(and) 58 | (eval-always 59 | (defconstant k< :<) 60 | (defconstant k= :=) 61 | (defconstant k> :>)) 62 | 63 | (deftype comp-result () `(member ,k< ,k= ,k>)) 64 | 65 | (declaim (inline compare-keys)) 66 | (defun compare-keys (pred key1 key2) 67 | "Compare KEY1 agains KEY2 using the comparison function PRED. 68 | Return K< if KEY1 compares as lesser than KEY2, 69 | return K> if KEY1 compares as greater than KEY2, 70 | return K= if KEY1 and KEY2 compare as equal." 71 | (declare (type function pred)) 72 | (the comp-result 73 | (cond 74 | ((funcall pred key1 key2) k<) 75 | ((funcall pred key2 key1) k>) 76 | (t k=)))) 77 | 78 | 79 | 80 | 81 | #?+sxhash-equalp 82 | (defmacro %sxhash-equalp (x) 83 | (let ((form (get-feature 'sxhash-equalp))) 84 | (etypecase form 85 | (symbol (list form x)) 86 | (cons (substitute x '* form))))) 87 | 88 | #?-sxhash-equalp 89 | (defmacro %sxhash-equalp (x) 90 | #.(log:warn "missing SXHASH-EQUALP on this implementation, 91 | falling back on SXHASH. 92 | GHASH-TABLE and THASH-TABLE instances using :test 'EQUALP may not work properly.") 93 | `(sxhash ,x)) 94 | 95 | 96 | (declaim (inline sxhash-equalp)) 97 | (defun sxhash-equalp (x) 98 | "Variant of SXHASH designed for EQUALP tests, i.e. 99 | \(equalp x y) implies (= (sxhash-equalp x) (sxhash-equalp y)). 100 | A common use is for ghash-tables and thash-tables that use :test 'equalp" 101 | (%sxhash-equalp x)) 102 | 103 | ;;;; ** Utility macros 104 | 105 | ;; for some reason, under certain circumstances SBCL invokes 106 | ;; slot-value-using-class only from slot accessors, not from (slot-value ...) 107 | 108 | ;; LispWorks is much more picky: slot accessors systematically bypass slot-value-using-class 109 | ;; UNLESS the DECLARED class for the object has the flag :optimize-slot-access nil 110 | ;; Instead, (slot-value ...) works fine in LispWorks. 111 | 112 | (let ((pkg (find-package (symbol-name 'stmx.util)))) 113 | (defmacro _ (obj slot) 114 | `(slot-value ,obj ',(if (eq pkg (symbol-package slot)) 115 | slot 116 | (intern (symbol-name slot) pkg))))) 117 | 118 | #| 119 | (eval-always 120 | (let1 of (symbol-name '-of) 121 | (defmacro _ (obj slot-name) 122 | (let1 accessor (intern (concatenate 'string (symbol-name slot-name) of)) 123 | `(,accessor ,obj))))) 124 | |# 125 | 126 | 127 | 128 | (defmacro with-ro-slots ((&rest slots) instance &body body) 129 | (with-gensym obj 130 | `(let ((,obj ,instance)) 131 | (let ,(loop for slot in slots 132 | collect `(,slot (_ ,obj ,slot))) 133 | ,@body)))) 134 | 135 | 136 | (defmacro with-rw-slots ((&rest slots) instance &body body) 137 | (with-gensym obj 138 | `(let ((,obj ,instance)) 139 | (symbol-macrolet ,(loop for slot in slots 140 | collect `(,slot (_ ,obj ,slot))) 141 | ,@body)))) 142 | 143 | 144 | 145 | 146 | -------------------------------------------------------------------------------- /main/hw-atomic.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 :stmx) 17 | 18 | (enable-#?-syntax) 19 | 20 | 21 | ;;;; ** Running hardware transactions 22 | 23 | (defconstant +hw-atomic-max-attempts+ 10) 24 | 25 | (defmacro %hw-atomic2 ((&key hw-write-version err 26 | (test-for-running-tx? t) 27 | (update-stat :hwtx)) 28 | body fallback) 29 | "Run BODY in a hardware memory transaction. 30 | If the transaction aborts, retry it as long as it has chances to succeed. 31 | If it has no chances to succeed, execute FALLBACK. 32 | Warning: if a transaction is already running, execute BODY inside it" 33 | 34 | (let ((tvar-write-version (or hw-write-version (gensym (symbol-name 'tvar-write-version)))) 35 | (err (or err (gensym (symbol-name 'err))))) 36 | 37 | (with-gensyms (tx-begin tx-fallback attempts) 38 | `(cond 39 | ,@(if test-for-running-tx? 40 | `(((hw-transaction?) (with-hwtx ,body)) 41 | ((sw-transaction?) (with-swtx ,body))) 42 | `()) 43 | (t 44 | (prog ((,err 0) 45 | (,attempts +hw-atomic-max-attempts+) 46 | ;; create a a thread-local binding for *hw-tlog-write-version* 47 | (*hw-tlog-write-version* +invalid-version+)) 48 | 49 | (unless (zerop (global-clock/get-nohw-counter)) 50 | (go ,tx-fallback)) 51 | 52 | ,tx-begin 53 | (setf ,err (hw-transaction-begin)) 54 | (when (= ,err +hw-transaction-started+) 55 | ;; hardware transactions are currently incompatible 56 | ;; with software-only transaction commits :-( 57 | (unless (zerop (global-clock/get-nohw-counter)) 58 | (hw-transaction-abort)) 59 | 60 | (let ((,tvar-write-version 61 | (setf *hw-tlog-write-version* 62 | (global-clock/hw/start-write (global-clock/hw/start-read))))) 63 | (declare (ignorable ,tvar-write-version)) 64 | 65 | 66 | (return ;; returns from (prog ...) 67 | (multiple-value-prog1 68 | (with-hwtx ,body) 69 | (hw-transaction-end) 70 | ,(if (eq update-stat :swtx) 71 | `(global-clock/sw/stat-committed) 72 | `(global-clock/hw/stat-committed)))))) 73 | 74 | (unless (zerop (decf (the fixnum ,attempts))) 75 | (when (hw-transaction-rerun-may-succeed? ,err) 76 | ;;(maybe-yield-before-rerun) 77 | (go ,tx-begin))) 78 | 79 | ,(if (eq update-stat :swtx) 80 | `(global-clock/sw/stat-aborted) 81 | `(global-clock/hw/stat-aborted)) 82 | 83 | ,tx-fallback 84 | (return ;; returns from (prog ...) 85 | ,fallback))))))) 86 | 87 | 88 | (defmacro hw-atomic2 ((&key hw-write-version err 89 | (test-for-running-tx? t) 90 | (update-stat :hwtx)) 91 | &optional (body nil body?) fallback) 92 | "Run BODY in a hardware memory transaction. All changes to transactional memory 93 | will be visible to other threads only after BODY returns normally (commits). 94 | If BODY signals an error, its effects on transactional memory are rolled back 95 | and the error is propagated normally. 96 | Also, no work-in-progress transactional memory will ever be visible to other 97 | threads. 98 | 99 | If hardware memory transaction aborts for a conflict, rerun it. 100 | If it fails for some other reason, execute FALLBACK." 101 | (if body? 102 | `(%hw-atomic2 (:hw-write-version ,hw-write-version :err ,err 103 | :test-for-running-tx? ,test-for-running-tx? 104 | :update-stat ,update-stat) 105 | ,body 106 | ,fallback) 107 | `(values))) 108 | 109 | 110 | -------------------------------------------------------------------------------- /asm/compiler.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 :stmx.asm) 17 | 18 | (defconstant +impl-package+ 19 | (loop :for pkg in 20 | #+(or x86 x86-64) '(:sb-x86-64-asm :sb-x86-asm :sb-vm) 21 | #+(or arm arm64) '(:sb-arm64-asm :sb-arm-asm :sb-vm) 22 | #-(or arm arm64 x86 x86-64) '(:sb-vm) 23 | :when (find-package pkg) 24 | :return pkg) 25 | "Designator for the SBCL internal package where we look for VOP-related symbols") 26 | 27 | (defun symbol-name* (symbol-name) 28 | (declare (type (or symbol string) symbol-name)) 29 | (if (stringp symbol-name) 30 | symbol-name 31 | (symbol-name symbol-name))) 32 | 33 | (defun find-symbol* (symbol-name &optional (package-name +impl-package+)) 34 | "Find and return the symbol named SYMBOL-NAME in PACKAGE" 35 | (declare (type (or symbol string) symbol-name)) 36 | (let ((symbol-name (symbol-name* symbol-name))) 37 | (find-symbol symbol-name package-name))) 38 | 39 | ;;;; conditional compile helpers, use as follows: 40 | ;;;; #+#.(stmx.asm::compile-if-package :package-name) (form ...) 41 | ;;;; #+#.(stmx.asm::compile-if-symbol :symbol-name :package-name) (form ...) 42 | ;;;; #+#.(stmx.asm::compile-if-lisp-version>= '(1 2 13)) (form ...) 43 | (defun compile-if (flag) 44 | (if flag '(:and) '(:or))) 45 | 46 | (defun compile-if-package (package-name) 47 | (compile-if (find-package package-name))) 48 | 49 | (defun compile-if-symbol (package-name symbol-name) 50 | (compile-if (find-symbol* symbol-name package-name))) 51 | 52 | 53 | 54 | 55 | 56 | (defun split-string (string separator) 57 | (declare (type string string) 58 | (type character separator)) 59 | (loop :for beg = 0 :then (1+ end) 60 | :for end = (position separator string :start beg) 61 | :collect (subseq string beg end) 62 | :while end)) 63 | 64 | (defun string-to-int-list (string &optional (separator #\.)) 65 | (declare (type string string) 66 | (type character separator)) 67 | (loop 68 | :for token in (split-string string separator) 69 | :for i = (parse-integer token :junk-allowed t) 70 | :while i 71 | :collect i)) 72 | 73 | (defun int-list>= (list1 list2) 74 | (declare (type list list1 list2)) 75 | (loop 76 | :for n1 = (pop list1) 77 | :for n2 = (pop list2) 78 | :do 79 | (cond 80 | ((null n1) (return (null n2))) 81 | ((null n2) (return t)) 82 | ((< n1 n2) (return nil)) 83 | ((> n1 n2) (return t))))) 84 | 85 | (defun lisp-version>= (version-int-list) 86 | (declare (type (or string list) version-int-list)) 87 | (let ((current-version (string-to-int-list 88 | (lisp-implementation-version))) 89 | (min-version (if (listp version-int-list) 90 | version-int-list 91 | (string-to-int-list version-int-list)))) 92 | (int-list>= current-version min-version))) 93 | 94 | (defun compile-if-sbcl-lacks-rtm-instructions () 95 | ;; Instructions XBEGIN XEND XABORT XTEST are defined only in SBCL >= 1.3.4 96 | ;; 97 | ;; Attempts to directly inspect sbcl internals to detect whether 98 | ;; the instructions are defined or not are doomed to break sooner or later, 99 | ;; because they mess with SBCL internal implementation details 100 | ;; subject to change without notice. 101 | ;; 102 | ;; Thus simply check for SBCL version. 103 | (compile-if (not (lisp-version>= '(1 3 4))))) 104 | 105 | (defun compile-if-sbcl-disassem<=32-bit () 106 | ;; SBCL < 1.2.14 disassembler does not support instructions longer than 32 bits, 107 | ;; so we will have to work around it by using a prefilter 108 | ;; to read beyond 32 bits while disassembling 109 | (compile-if (not (lisp-version>= '(1 2 14))))) 110 | 111 | 112 | ;;;; new compiler intrinsic functions 113 | 114 | (defconstant +defknown-has-overwrite-fndb-silently+ 115 | (dolist (arg (second (sb-kernel:type-specifier (sb-int:info :function :type 'sb-c::%defknown)))) 116 | (when (and (consp arg) 117 | (eq (first arg) :overwrite-fndb-silently)) 118 | (return t)))) 119 | 120 | (defmacro defknown (&rest args) 121 | `(sb-c:defknown ,@args 122 | ,@(if +defknown-has-overwrite-fndb-silently+ '(:overwrite-fndb-silently t) ()))) 123 | 124 | 125 | -------------------------------------------------------------------------------- /main/atomic.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 :stmx) 17 | 18 | (enable-#?-syntax) 19 | 20 | ;;;; ** Running hybrid SW/HW transactions 21 | 22 | (defmacro atomic (&rest body) 23 | "Main entry point for STMX. 24 | 25 | Run BODY in a memory transaction. All changes to transactional memory 26 | will be visible to other threads only after BODY returns normally (commits). 27 | If BODY signals an error, its effects on transactional memory are rolled back 28 | and the error is propagated normally. 29 | Also, no work-in-progress transactional memory will ever be visible to other 30 | threads. 31 | 32 | A memory transaction can also retry: in such case ATOMIC will abort it, 33 | wait until some of the value read by the transaction have changed, 34 | then re-run the transaction from the beginning. 35 | 36 | Since STMX transactions do not lock memory, it is possible for different 37 | transactions to try to update the same memory (almost) simultaneously. 38 | In such case, the conflict is detected when they try to commit or rollback, 39 | and only one conflicting transaction is allowed to commit: 40 | all others are immediately re-run again from the beginning. 41 | 42 | For this reason, a transaction SHOULD NOT perform any irreversible 43 | operation such as INPUT/OUTPUT: the result would be that I/O is executed 44 | multiple times, or executed even when it shouldn't have! 45 | Irreversible operations SHOULD be performed OUTSIDE transactions, 46 | for example by queueing them into transactional memory that another thread 47 | will consume and then, OUTSIDE transactions, actually perform them. 48 | 49 | For how to create transactional memory, see TRANSACTIONAL or TVAR. 50 | For another way to run transactions, see also TRANSACTION. 51 | For advanced features inside transactions, see RETRY, ORELSE, NONBLOCKING, 52 | BEFORE-COMMIT and AFTER-COMMIT. 53 | 54 | For pre-defined transactional classes, see the package STMX.UTIL" 55 | 56 | #-(and) 57 | "Run BODY in a hardware memory transaction. All changes to transactional memory 58 | will be visible to other threads only after BODY returns normally (commits). 59 | If BODY signals an error, its effects on transactional memory are rolled back 60 | and the error is propagated normally. 61 | Also, no work-in-progress transactional memory will ever be visible to other 62 | threads. 63 | 64 | If hardware memory transaction aborts for a conflict, rerun it. 65 | If it fails for some other reason, execute BODY in a software memory transaction." 66 | 67 | (if body 68 | #?+hw-transactions 69 | (let ((form `(block nil (locally ,@body)))) 70 | `(%hw-atomic2 () ,form (%run-sw-atomic (lambda () (with-swtx ,form))))) 71 | #?-hw-transactions 72 | `(sw-atomic ,@body) 73 | 74 | `(values))) 75 | 76 | 77 | (defmacro fast-atomic (&rest body) 78 | "Possibly slightly faster variant of ATOMIC. 79 | 80 | On systems supporting hardware transactions (as of July 2013, very few systems 81 | support them), FAST-ATOMIC and ATOMIC are identical. 82 | On other systems, multiple nested FAST-ATOMIC forms may be slightly faster than 83 | multiple nested ATOMIC blocks, at the price of compiling BODY more than once." 84 | #?+hw-transactions 85 | `(atomic ,@body) 86 | 87 | #?-hw-transactions 88 | (if body 89 | (let ((form `(block nil (locally ,@body)))) 90 | `(if (transaction?) 91 | ,form 92 | (%run-sw-atomic (lambda () ,form)))) 93 | `(values))) 94 | 95 | 96 | 97 | (declaim (inline run-atomic)) 98 | 99 | (defun run-atomic (tx) 100 | "Function equivalent of the ATOMIC macro. 101 | 102 | Run the function TX inside a memory transaction. 103 | If the transaction is invalid (conflicts) re-run TX immediately, ignoring 104 | any error it may signal. 105 | 106 | Otherwise, commit if TX returns normally, or rollback if it signals an error. 107 | 108 | Finally, if TX called (retry), re-run it after at least some of the 109 | transactional memory it read has changed." 110 | 111 | (declare (type function tx)) 112 | 113 | #?+hw-transactions 114 | (%hw-atomic2 () (funcall tx) (%run-sw-atomic tx)) 115 | 116 | #?-hw-transactions 117 | (run-sw-atomic tx)) 118 | 119 | 120 | 121 | (defun hw-transaction-test () 122 | (atomic (hw-transaction-supported-and-running?))) 123 | -------------------------------------------------------------------------------- /lang/features-reader.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 :stmx.lang) 17 | 18 | (eval-when (:compile-toplevel :load-toplevel) 19 | 20 | (defun compile-if-error (ch args) 21 | (error "#?~a must be followed by one of: symbol, (or ...), (and ...), (not ...), 22 | (eql ...), (symbol ...). found instead ~S" 23 | ch args)) 24 | 25 | (defun compile-ensure-1-arg (ch args) 26 | (when (or (null (cdr args)) (cddr args)) 27 | (error "#?~a(~a ...) must must have exactly one argument. found instead ~S" 28 | ch (first args) args))) 29 | 30 | (defun compile-ensure-2-args (ch args) 31 | (when (or (null (cddr args)) (cdddr args)) 32 | (error "#?~a(~a ...) must must have exactly two arguments. found instead ~S" 33 | ch (first args) args))) 34 | 35 | 36 | (declaim (ftype (function (t t) boolean) compile-if-eval)) 37 | 38 | (defun compile-if-and (ch args) 39 | "Return T if all the features in ARGS are present in *FEATURE-LIST*, otherwise return NIL." 40 | (declare (type list args)) 41 | (loop for arg in (rest args) ;; skip 'and 42 | always (compile-if-eval ch arg))) 43 | 44 | 45 | (defun compile-if-or (ch args) 46 | "Return T if at least one feature in ARGS is present in *FEATURE-LIST*, otherwise return NIL." 47 | (declare (type list args)) 48 | (loop for arg in (rest args) ;; skip 'or 49 | thereis (compile-if-eval ch arg))) 50 | 51 | 52 | (defun compile-if-not (ch args) 53 | "Return NIL if the feature in ARGS is present in *FEATURE-LIST*, otherwise return T." 54 | (declare (type list args)) 55 | 56 | (compile-ensure-1-arg ch args) 57 | (pop args) ;; skip 'not 58 | 59 | (not (compile-if-eval ch (first args)))) 60 | 61 | 62 | (defun compile-if-eql (ch args) 63 | "Return T if feature has the specified value, otherwise return NIL." 64 | (declare (type list args)) 65 | 66 | (compile-ensure-2-args ch args) 67 | (pop args) ;; skip 'eql 68 | 69 | (let* ((feature (pop args)) 70 | (value (pop args))) 71 | (eql value (get-feature feature)))) 72 | 73 | 74 | (defun compile-if-symbol (ch args) 75 | "Return T if symbol exists in specified package, otherwise return NIL. 76 | Arguments are: package-name symbol-name." 77 | (declare (type list args)) 78 | 79 | (compile-ensure-2-args ch args) 80 | (pop args) ;; skip 'symbol 81 | 82 | (let* ((pkg-name (pop args)) 83 | (symbol-name (pop args))) 84 | (declare (type symbol pkg-name symbol-name)) 85 | (when-bind pkg (find-package pkg-name) 86 | (if (nth-value 1 (find-symbol (symbol-name symbol-name) pkg)) 87 | t 88 | nil)))) 89 | 90 | 91 | (defun compile-if-eval (ch args) 92 | (the (values boolean &optional) 93 | (cond 94 | ((or (keywordp args) (numberp args)) args) 95 | ((symbolp args) (if (get-feature args) t nil)) 96 | ((not (listp args)) (compile-if-error ch args)) 97 | ((eq 'and (first args)) (compile-if-and ch args)) 98 | ((eq 'or (first args)) (compile-if-or ch args)) 99 | ((eq 'not (first args)) (compile-if-not ch args)) 100 | ((eq 'eql (first args)) (compile-if-eql ch args)) 101 | ((eq 'symbol (first args)) (compile-if-symbol ch args)) 102 | (t (compile-if-error ch args))))) 103 | 104 | 105 | (defun compile-if-transformer (stream subchar arg) 106 | (declare (ignore subchar arg)) 107 | (let* ((ch (read-char stream t)) 108 | (ch-flag (ecase ch 109 | (#\+ t) 110 | (#\- nil))) 111 | (args (read stream t))) 112 | 113 | (if (or *read-suppress* (eq ch-flag (compile-if-eval ch args))) 114 | (read stream t nil t) 115 | (let ((*read-suppress* t)) 116 | (read stream t nil t) 117 | (values))))) 118 | 119 | 120 | (defun %enable-#?-syntax () 121 | (setf *readtable* (copy-readtable)) 122 | (set-dispatch-macro-character #\# #\? #'compile-if-transformer)) 123 | 124 | (defmacro enable-#?-syntax () 125 | `(eval-when (:compile-toplevel :load-toplevel :execute) 126 | (%enable-#?-syntax)))) 127 | -------------------------------------------------------------------------------- /example/bank-account.lock.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 :cl-user) 17 | 18 | (defpackage #:stmx.example.bank-account.lock 19 | (:use #:cl) 20 | 21 | (:import-from #:stmx.lang 22 | #:new #:defprint-object)) 23 | 24 | (in-package :stmx.example.bank-account.lock) 25 | 26 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 27 | 28 | (deftype lock () 't) 29 | 30 | (defun make-lock (&optional name) 31 | (bt:make-lock name)) 32 | 33 | (defmacro with-lock ((lock) &body body) 34 | `(bt:with-lock-held (,lock) 35 | ,@body)) 36 | 37 | 38 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 39 | 40 | (deftype unsigned-fixnum () '(integer 0 #.most-positive-fixnum)) 41 | 42 | (defclass account () 43 | ((balance :initform 0 :initarg :balance :type unsigned-fixnum :accessor account-balance) 44 | (lock :initform (make-lock "ACCOUNT") :type lock :reader account-lock) 45 | (name :initform "" :initarg :name :type string :reader account-name))) 46 | 47 | 48 | (defprint-object (obj account :identity nil) 49 | (format t "~S ~S" (account-name obj) (account-balance obj))) 50 | 51 | 52 | (defmacro with-account-lock ((account) &body body) 53 | `(with-lock ((account-lock ,account)) 54 | ,@body)) 55 | 56 | 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | 59 | (defun withdraw (delta account) 60 | "decrease ACCOUNT balance by DELTA. return T if successful" 61 | (declare (type unsigned-fixnum delta) 62 | (type account account)) 63 | 64 | (with-account-lock (account) 65 | (when (>= (account-balance account) delta) 66 | (decf (account-balance account) delta) 67 | t))) 68 | 69 | 70 | (defun deposit (delta account) 71 | "increase ACCOUNT balance by DELTA. return T if successful" 72 | (declare (type unsigned-fixnum delta) 73 | (type account account)) 74 | 75 | (with-account-lock (account) 76 | (when (<= (account-balance account) (- most-positive-fixnum delta)) 77 | (incf (account-balance account) delta) 78 | t))) 79 | 80 | 81 | (defun transfer-broken (delta account1 account2) 82 | "transfer DELTA from ACCOUNT1 to ACCOUNT2. return T if successful." 83 | (declare (type unsigned-fixnum delta) 84 | (type account account1 account2)) 85 | 86 | (when (withdraw delta account1) 87 | (if (deposit delta account2) 88 | t 89 | (if (deposit delta account1) 90 | t 91 | (error "cannot deposit ~S back into ~S or in ~S!" delta account1 account2))))) 92 | 93 | 94 | (defun transfer-deadlock-ugly (delta account1 account2) 95 | "transfer DELTA from ACCOUNT1 to ACCOUNT2. return t if successful." 96 | (declare (type unsigned-fixnum delta) 97 | (type account account1 account2)) 98 | 99 | (with-account-lock (account1) 100 | (with-account-lock (account2) 101 | (when (withdraw delta account1) 102 | (if (deposit delta account2) 103 | t 104 | (if (deposit delta account1) 105 | t 106 | (error "cannot happen! cannot deposit ~S back into ~S!" delta account1))))))) 107 | 108 | 109 | (defun transfer-deadlock-not-oo (delta account1 account2) 110 | "transfer delta from account1 to account2. return t if successful." 111 | (declare (type unsigned-fixnum delta) 112 | (type account account1 account2)) 113 | 114 | (with-account-lock (account1) 115 | (with-account-lock (account2) 116 | (when (>= (account-balance account1) delta) 117 | (when (<= (account-balance account2) (- most-positive-fixnum delta)) 118 | (decf (account-balance account1) delta) 119 | (incf (account-balance account2) delta) 120 | t))))) 121 | 122 | 123 | 124 | (defun transfer (delta account1 account2) 125 | (declare (type unsigned-fixnum delta) 126 | (type account account1 account2)) 127 | 128 | (transfer-deadlock-not-oo delta account1 account2)) 129 | 130 | 131 | (defparameter *account1* (new 'account :name "Mario rossi" :balance 1000)) 132 | (defparameter *account2* (new 'account :name "Giuseppe Verdi")) 133 | 134 | (defun test-bank-accounts (&optional (account1 *account1*) (account2 *account2*)) 135 | (log:info (transfer 700 account1 account2)) 136 | (log:info (transfer 500 account2 account1))) 137 | 138 | -------------------------------------------------------------------------------- /asm/x86-32,64-vops.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 :stmx.asm) 17 | 18 | 19 | ;;;; ** medium-level: define vops 20 | 21 | ;;; cpuid VOP 22 | 23 | (sb-c:define-vop (%cpuid) 24 | (:policy :fast-safe) 25 | (:translate %cpuid) 26 | 27 | (:args (eax-val :scs (sb-vm::unsigned-reg) :target eax) 28 | (ecx-val :scs (sb-vm::unsigned-reg) :target ecx)) 29 | (:arg-types sb-vm::unsigned-num sb-vm::unsigned-num) 30 | (:temporary (:sc sb-vm::unsigned-reg 31 | :offset #.(or (find-symbol* :rax-offset :sb-vm) 32 | (find-symbol* :eax-offset :sb-vm)) 33 | :target r1 :from (:argument 0)) eax) 34 | (:temporary (:sc sb-vm::unsigned-reg 35 | :offset #.(or (find-symbol* :rcx-offset :sb-vm) 36 | (find-symbol* :ecx-offset :sb-vm)) 37 | :target r3 :from (:argument 1)) ecx) 38 | #+x86-64 39 | (:temporary (:sc sb-vm::unsigned-reg 40 | :offset #.(or (find-symbol* :rbx-offset :sb-vm) 41 | (find-symbol* :ebx-offset :sb-vm)) 42 | :target r2) ebx) 43 | #+x86-64 44 | (:temporary (:sc sb-vm::unsigned-reg 45 | :offset #.(or (find-symbol* :rdx-offset :sb-vm) 46 | (find-symbol* :edx-offset :sb-vm)) 47 | :target r4) edx) 48 | (:results 49 | (r1 :scs (sb-vm::unsigned-reg)) 50 | (r2 :scs (sb-vm::unsigned-reg)) 51 | (r3 :scs (sb-vm::unsigned-reg)) 52 | (r4 :scs (sb-vm::unsigned-reg))) 53 | (:result-types sb-vm::unsigned-num sb-vm::unsigned-num 54 | sb-vm::unsigned-num sb-vm::unsigned-num) 55 | (:generator 8 56 | (sb-c:move eax eax-val) 57 | (sb-c:move ecx ecx-val) 58 | #+x86-64 59 | (progn 60 | (sb-assem:inst cpuid) 61 | (sb-c:move r1 eax) 62 | (sb-c:move r2 ebx) 63 | (sb-c:move r3 ecx) 64 | (sb-c:move r4 edx)) 65 | #-x86-64 66 | (let ((ebx sb-vm::ebx-tn) 67 | (edx sb-vm::edx-tn) 68 | (save-ebx t) 69 | (save-edx t)) 70 | (dolist (r (list r1 r2 r3 r4)) 71 | (when (sb-c::location= r ebx) 72 | (setf save-ebx nil)) 73 | (when (sb-c::location= r edx) 74 | (setf save-edx nil))) 75 | (when save-edx 76 | (sb-assem:inst push edx)) 77 | (when save-edx 78 | (sb-assem:inst push ebx)) 79 | (sb-assem:inst cpuid) 80 | (sb-assem:inst push edx) 81 | (sb-assem:inst push ebx) 82 | (sb-c:move r1 eax) 83 | (sb-assem:inst pop r2) 84 | (sb-c:move r3 ecx) 85 | (sb-assem:inst pop r4) 86 | (when save-ebx 87 | (sb-assem:inst pop ebx)) 88 | (when save-edx 89 | (sb-assem:inst pop edx))))) 90 | 91 | 92 | 93 | 94 | ;;; HLE vops - hardware lock elision 95 | 96 | 97 | 98 | 99 | ;;; RTM vops - restricted memory transaction 100 | 101 | (declaim (type fixnum +transaction-started+)) 102 | 103 | (defconstant +transaction-started+ 3 104 | "Value returned by (transaction-begin) if the transaction is successfully started. 105 | It is an implementation-dependent fixnum, different from all possible transactions 106 | abort error codes.") 107 | 108 | 109 | (sb-c:define-vop (%xbegin) 110 | (:policy :fast-safe) 111 | (:translate %transaction-begin) 112 | 113 | (:temporary (:sc sb-vm::unsigned-reg 114 | :offset #.(or (find-symbol* :rax-offset :sb-vm) 115 | (find-symbol* :eax-offset :sb-vm)) 116 | :target r1) eax) 117 | (:results (r1 :scs (sb-vm::unsigned-reg))) 118 | (:result-types sb-vm::unsigned-num) 119 | (:generator 0 120 | (sb-assem:inst mov eax +transaction-started+) 121 | (sb-assem:inst xbegin) 122 | (sb-c:move r1 eax))) 123 | 124 | 125 | (sb-c:define-vop (%xend) 126 | (:policy :fast-safe) 127 | (:translate %transaction-end) 128 | (:generator 0 129 | (sb-assem:inst xend))) 130 | 131 | 132 | (sb-c:define-vop (%xabort) 133 | (:policy :fast-safe) 134 | (:translate %transaction-abort) 135 | (:info err-code) 136 | (:generator 0 137 | (sb-assem:inst xabort err-code))) 138 | 139 | 140 | (sb-c:define-vop (%xtest) 141 | (:policy :fast-safe) 142 | (:translate %transaction-running-p) 143 | (:conditional :ne) 144 | (:generator 1 145 | (sb-assem:inst xtest))) 146 | 147 | -------------------------------------------------------------------------------- /lang/hw-transactions.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 :stmx.lang) 17 | 18 | (enable-#?-syntax) 19 | 20 | ;;;; ** hardware transactions. need CPU support, 21 | ;;;; see package stmx.asm and also stmx/lang/features-detect.lisp 22 | 23 | 24 | #?+(eql hw-transactions :stmx.asm) 25 | (progn 26 | 27 | (defconstant +hw-transaction-started+ stmx.asm:+transaction-started+) 28 | 29 | (defmacro hw-transaction-supported? () 30 | "Return T if the CPU supports hardware memory transactions 31 | and there is a compiler extension to use them, 32 | otherwise return NIL." 33 | `(stmx.asm:transaction-supported-p)) 34 | 35 | (defmacro hw-transaction-begin () 36 | "Start a hardware memory transaction. Return +hw-transaction-started+ 37 | if transaction runs successfully, otherwise return abort reason." 38 | `(stmx.asm:transaction-begin)) 39 | 40 | (defmacro hw-transaction-running? () 41 | "Return T if a hardware memory transaction is in progress." 42 | `(stmx.asm:transaction-running-p)) 43 | 44 | (defmacro hw-transaction-abort () 45 | "Abort a hardware memory transaction currently in progress. 46 | Causes a rollback of *all* transaction effects, execution resumes 47 | at (hw-transaction-begin) by returning abort reason." 48 | `(stmx.asm:transaction-abort)) 49 | 50 | (defmacro hw-transaction-end () 51 | "Try to commit a hardware memory transaction currently in progress. 52 | If commit is successful, return normally. Otherwise execution resumes 53 | at (hw-transaction-begin) by returning abort reason." 54 | `(stmx.asm:transaction-end)) 55 | 56 | (defmacro hw-transaction-rerun-may-succeed? (err-code) 57 | "If ERR-CODE is the result returned by (HW-TRANSACTION-BEGIN) of an *aborted* transaction, 58 | return T if re-running the same transaction has a possibility to succeed, 59 | i.e. if the abort reason was temporary (as for example a conflict with another thread). 60 | Return NIL if re-running the same transaction has no possibility to succeed." 61 | `(stmx.asm:transaction-rerun-may-succeed-p ,err-code)) 62 | 63 | 64 | ;; evaluate (hw-transaction-supported?) only once: CPUID is expensive, 65 | ;; flushes all caches and aborts hardware transactions. 66 | (defconstant +hw-transaction-supported+ (hw-transaction-supported?))) 67 | 68 | 69 | 70 | 71 | #?-hw-transactions 72 | (progn 73 | 74 | ;; stub implementation if no compiler support 75 | 76 | (defconstant +hw-transaction-started+ 3) 77 | 78 | (defmacro hw-transaction-supported? () 79 | "Return T if the CPU supports hardware memory transactions, 80 | and there is a compiler extension to use them, 81 | otherwise return NIL." 82 | `nil) 83 | 84 | (defmacro hw-transaction-begin () 85 | "Start a hardware memory transaction. Return +hw-transaction-started+ 86 | if transaction started successfully, otherwise return abort reason." 87 | `0) 88 | 89 | (defmacro hw-transaction-running? () 90 | "Return T if a hardware memory transaction is in progress." 91 | `nil) 92 | 93 | (defmacro hw-transaction-abort () 94 | "Abort a hardware memory transaction currently in progress. 95 | Causes a rollback of *all* transaction effects, execution resumes 96 | at (hw-transaction-begin) by returning abort reason." 97 | `(error "hardware memory transaction not supported")) 98 | 99 | (defmacro hw-transaction-end () 100 | "Try to commit a hardware memory transaction currently in progress. 101 | If commit is successful, return normally. Otherwise execution resumes 102 | at (hw-transaction-begin) by returning abort reason." 103 | `nil) 104 | 105 | (defmacro hw-transaction-rerun-may-succeed? (err-code) 106 | "If ERR-CODE is the result returned by (HW-TRANSACTION-BEGIN) of an *aborted* transaction, 107 | return T if re-running the same transaction has a possibility to succeed, 108 | i.e. if the abort reason was temporary (as for example a conflict with another thread). 109 | Return NIL if re-running the same transaction has no possibility to succeed." 110 | (declare (ignore err-code)) 111 | `nil) 112 | 113 | 114 | (defconstant +hw-transaction-supported+ nil)) 115 | 116 | 117 | 118 | 119 | 120 | 121 | (defmacro hw-transaction-supported-and-running? () 122 | `(and +hw-transaction-supported+ (hw-transaction-running?))) 123 | 124 | 125 | ;; avoid "unexpected EOF" compiler error 126 | ;; if none of the conditional compilations above are satisfied 127 | nil 128 | -------------------------------------------------------------------------------- /lang/hash-table.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 :stmx.lang) 17 | 18 | ;;;; * Hash-table utilities 19 | 20 | 21 | #-(and) 22 | (eval-always 23 | (defstruct hash-counter 24 | "(stmx.example1::dining-philosophers 4 1000000) on average 25 | does 4.4 million iterations and causes the following 26 | hash table operations for EACH iteration: 27 | 15.0 get 28 | 8.0 set 29 | 11.4 iterations inside do-hash" 30 | 31 | (get 0 :type sb-vm:word) 32 | (set 0 :type sb-vm:word) 33 | (rem 0 :type sb-vm:word) 34 | (clear 0 :type sb-vm:word) 35 | (loop 0 :type sb-vm:word)) 36 | 37 | 38 | (defvar *hash-counter* (make-hash-counter)) 39 | 40 | (defmacro incf-hash-counter (which) 41 | (let1 accessor (intern (concatenate 'string "HASH-COUNTER-" (symbol-name which)) 'stmx.lang) 42 | `(progn 43 | (sb-ext:atomic-incf (,accessor *hash-counter*)) 44 | nil)))) 45 | 46 | #+(and) 47 | (defmacro incf-hash-counter (which) 48 | (declare (ignore which)) 49 | nil) 50 | 51 | 52 | (defmacro do-hash ((key &optional value) hash &body body) 53 | "Execute body on each key/value pair contained in hash table" 54 | `(loop for ,key being each hash-key in ,hash 55 | ,@(when value `(using (hash-value ,value))) 56 | do (progn 57 | (incf-hash-counter loop) 58 | ,@body))) 59 | 60 | (declaim (inline get-hash)) 61 | (defun get-hash (hash key) 62 | "Same as (gethash key hash), only with reversed arguments." 63 | (declare (type hash-table hash)) 64 | (incf-hash-counter get) 65 | (gethash key hash)) 66 | 67 | 68 | (declaim (inline set-hash)) 69 | (defun set-hash (hash key value) 70 | "Shortcut for (setf (gethash key hash) value)" 71 | (declare (type hash-table hash)) 72 | (incf-hash-counter set) 73 | (setf (gethash key hash) value)) 74 | 75 | (declaim (inline (setf get-hash))) 76 | (defun (setf get-hash) (value hash key) 77 | "Same as (setf (gethash key hash) value), only with reversed key and hash arguments." 78 | (declare (type hash-table hash)) 79 | (setf (gethash key hash) value)) 80 | 81 | 82 | 83 | (declaim (inline rem-hash)) 84 | (defun rem-hash (hash key) 85 | "Same as (remhash key hash), only with reversed arguments." 86 | (declare (type hash-table hash)) 87 | (incf-hash-counter rem) 88 | (remhash key hash)) 89 | 90 | 91 | (declaim (inline clear-hash)) 92 | (defun clear-hash (hash) 93 | "Same as (clrhash hash)." 94 | (declare (type hash-table hash)) 95 | (incf-hash-counter clear) 96 | (clrhash hash)) 97 | 98 | 99 | 100 | (defun hash-table-keys (src &optional to-list) 101 | "Return a list containing the keys in hash-table SRC. 102 | If TO-LIST is not nil, it will be appended to the returned list. 103 | TO-LIST contents is not destructively modified." 104 | (declare (type hash-table src) 105 | (type list to-list)) 106 | (do-hash (key) src 107 | (push^ key to-list)) 108 | to-list) 109 | 110 | 111 | (defun hash-table-values (src &optional to-list) 112 | "Return a list containing the values in hash-table SRC. 113 | If TO-LIST is not nil, it will be appended to the returned list. 114 | TO-LIST contents is not destructively modified." 115 | (declare (type hash-table src) 116 | (type list to-list)) 117 | (loop for value being each hash-value in src 118 | do (push^ value to-list)) 119 | to-list) 120 | 121 | 122 | (defun hash-table-pairs (src &optional to-alist) 123 | "Return an alist containing a (key . value) pair for each entry 124 | in hash-table SRC. 125 | If TO-ALIST is not nil, it will be appended to the returned alist. 126 | TO-ALIST contents is not destructively modified." 127 | (declare (type hash-table src) 128 | (type list to-alist)) 129 | (do-hash (key value) src 130 | (push^ (cons^ key value) to-alist)) 131 | to-alist) 132 | 133 | 134 | (defun copy-hash-table (dst src) 135 | "Copy all key/value pairs from hash-table SRC into hash-table DST. 136 | Other keys (and their values) present in DST but not in SRC 137 | are not modified. Return DST." 138 | (declare (type hash-table dst src)) 139 | (do-hash (key value) src 140 | (set-hash dst key value)) 141 | dst) 142 | 143 | 144 | 145 | 146 | (defun merge-hash-tables (dst src) 147 | "Copy hash-table SRC into hash-table DST. 148 | 149 | Return t if SRC and DST are compatible, 150 | i.e. if they contain eq values for the keys common to both, 151 | otherwise return nil. 152 | \(in the latter case, the merge will not be completed)." 153 | 154 | (declare (type hash-table src dst)) 155 | (do-hash (var val1) src 156 | (multiple-value-bind (val2 present2?) (get-hash dst var) 157 | (when (and present2? (not (eq val1 val2))) 158 | (return-from merge-hash-tables nil)) 159 | (set-hash dst var val1))) 160 | t) 161 | -------------------------------------------------------------------------------- /asm/notransaction.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 :stmx.asm) 17 | 18 | 19 | (declaim (ftype (function () (values (unsigned-byte 32) &optional)) transaction-begin) 20 | (ftype (function () (values &optional)) transaction-end) 21 | (ftype (function () (values &optional)) transaction-abort) 22 | (ftype (function () (values boolean &optional)) transaction-running-p) 23 | (ftype (function (fixnum) (values boolean &optional)) transaction-rerun-may-succeed-p) 24 | (inline transaction-begin 25 | transaction-end 26 | transaction-abort 27 | transaction-running-p 28 | transaction-rerun-may-succeed-p)) 29 | 30 | 31 | (declaim (ftype (function () boolean) transaction-supported-p)) 32 | 33 | (defun transaction-supported-p () 34 | "Test for RTM, i.e. hardware memory transactions. 35 | RTM is supported on Intel CPUs if (cpuid 7) returns ebx with bit 11 set. 36 | If a processor does not support HLE, trying to execute 37 | the assembler instructions XBEGIN, XEND, XABORT and XTEST 38 | will generate faults." 39 | nil) 40 | 41 | 42 | (defun transaction-begin () 43 | "Start a hardware memory transaction. 44 | Return +transaction-started+ if transaction started successfully, 45 | otherwise return code of the error that caused the transaction to abort. 46 | 47 | Invoking TRANSACTION-BEGIN while there is already a running hardware 48 | memory transaction has implementation-dependent effects." 49 | (the fixnum (1- +transaction-started+))) 50 | 51 | 52 | (defun transaction-end () 53 | "Commit a hardware memory transaction. 54 | Return normally (with an implementation-dependent value) if commit is successful, 55 | otherwise abort the transaction. 56 | 57 | In case the transaction is aborted, all effects of code between TRANSACTION-BEGIN 58 | and TRANSACTION-END are rolled back (undone): 59 | execution resumes at the instruction immediately after TRANSACTION-BEGIN, 60 | in such a way that TRANSACTION-BEGIN will appear to have returned 61 | a non-zero error code (that describes the abort reason). 62 | 63 | Invoking TRANSACTION-END without a running hardware memory transaction 64 | has undefined consequences." 65 | (values)) 66 | 67 | 68 | 69 | (declaim (type fixnum +transaction-user-abort+)) 70 | 71 | (defconstant +transaction-user-abort+ #x1000001 72 | "Value returned by (transaction-begin) if the transaction was manually aborted 73 | by calling (transaction-abort). 74 | It is an implementation-dependent fixnum, different from +transaction-started+ 75 | and from all error codes indicating a spontaneous abort.") 76 | 77 | 78 | (defmacro transaction-abort-macro (&optional (err-code (ash +transaction-user-abort+ -24))) 79 | "Immediately abort a hardware memory transaction with a user-specified 80 | ERR-CODE, which must be a constant between 0 and 255 (default: 1). 81 | Note: the value returned by (transaction-begin) will also contain \"somewhere\" 82 | the bits of ERR-CODE, but will have a different value. 83 | See Intel x86-64 CPU instruction reference manual, section TSX, for details. 84 | 85 | If a transaction is in progress, TRANSACTION-ABORT-MACRO does not return normally: 86 | execution is resumed at the instruction immediately after the outermost 87 | TRANSACTION-BEGIN. 88 | 89 | If called without a running transaction, TRANSACTION-ABORT-MACRO returns normally 90 | with an implementation-dependent value." 91 | (unless (typep err-code '(unsigned-byte 8)) 92 | (error 'type-error 93 | :expected-type '(unsigned-byte 8) :datum err-code)) 94 | `(values)) 95 | 96 | 97 | 98 | (defun transaction-abort () 99 | "Voluntarily abort a hardware memory transaction 100 | with an error-code equal to +transaction-user-abort+. 101 | 102 | If a transaction is in progress, TRANSACTION-ABORT does not return normally: 103 | execution is resumed at the instruction immediately after the outermost 104 | TRANSACTION-BEGIN. 105 | 106 | If called without an active transaction, TRANSACTION-ABORT returns normally 107 | with an implementation-dependent value." 108 | (transaction-abort-macro)) 109 | 110 | 111 | (defun transaction-running-p () 112 | "Return T if a hardware memory transaction 113 | is currently in progress, otherwise return NIL." 114 | nil) 115 | 116 | 117 | 118 | 119 | (defun transaction-rerun-may-succeed-p (err-code) 120 | "If ERR-CODE is the result returned by (TRANSACTION-BEGIN) of an *aborted* transaction, 121 | return T if re-running the same transaction has a possibility to succeed, 122 | i.e. if the abort reason was temporary (as for example a conflict with another thread). 123 | Return NIL if re-running the same transaction has no possibility to succeed." 124 | (declare (type fixnum err-code) 125 | (ignore err-code)) 126 | nil) 127 | -------------------------------------------------------------------------------- /example/concurrent-queue.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 | 17 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 18 | ;; ;; 19 | ;; UNFINISHED! DO NOT USE! ;; 20 | ;; ;; 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | 23 | 24 | 25 | (in-package :cl-user) 26 | 27 | (defpackage #:stmx.concurrent 28 | (:use #:cl 29 | #:arnesi)) 30 | 31 | (in-package :stmx.concurrent) 32 | 33 | ;;;; ** lock-free concurrent vector 34 | 35 | (defvar *empty-vector* #()) 36 | 37 | (defstruct (cvector (:constructor %make-cvector)) 38 | (data *empty-vector* :type simple-vector) 39 | (mod-hi 0 :type sb-vm:word) 40 | (mod-lo 0 :type sb-vm:word)) 41 | 42 | 43 | (defun make-cvector (size &key (element-type t) 44 | (initial-element nil initial-element?) 45 | (initial-contents nil initial-contents?)) 46 | (declare (type fixnum size) 47 | (type symbol element-type)) 48 | (let1 v (%make-cvector) 49 | (setf (cvector-data v) 50 | (cond 51 | (initial-contents? 52 | (make-array size :element-type element-type :initial-contents initial-contents)) 53 | (initial-element? 54 | (make-array size :element-type element-type :initial-element initial-element)) 55 | (t 56 | (make-array size :element-type element-type)))) 57 | v)) 58 | 59 | 60 | (declaim (inline vref)) 61 | (defun vref (vector subscript) 62 | "AREF for concurrent vectors" 63 | (declare (type cvector vector) 64 | (type fixnum subscript)) 65 | (let1 data (cvector-data vector) 66 | (if (< subscript (length data)) 67 | (aref (cvector-data vector) subscript) 68 | 0))) ;; slow-path-here 69 | 70 | 71 | (declaim (inline (setf vref))) 72 | (defun (setf vref) (element vector subscript) 73 | "(SETF AREF) for concurrent vectors" 74 | (declare (type cvector vector) 75 | (type fixnum subscript)) 76 | ;;(incf (the fixnum (cvector-mod-hi vector))) 77 | (sb-ext:atomic-incf (cvector-mod-hi vector)) 78 | (let1 data (cvector-data vector) 79 | (declare (type simple-vector data)) 80 | (if (< subscript (length data)) 81 | (setf (aref data subscript) element) 82 | nil)) ;; 'slow-path-here 83 | (sb-ext:atomic-incf (cvector-mod-lo vector)) 84 | ;;(incf (the fixnum (cvector-mod-lo vector))) 85 | element) 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | (defmacro 1m (&rest body) 94 | `(time (dotimes (,(gensym) 1000000) 95 | ,@body))) 96 | 97 | (defmacro 1g (&rest body) 98 | `(time (dotimes (,(gensym) 1000000000) 99 | ,@body))) 100 | 101 | 102 | (defun test-cvector-fixnum (&optional (i 0)) 103 | (declare (type fixnum i)) 104 | (let ((v (make-cvector 10 :element-type 'fixnum))) 105 | (declare (type cvector v)) 106 | ;; 9.82 nanoseconds per (vref v i) ;; 10.33 nanoseconds with (if (< subscript (length data)) 107 | ;; 9.85 nanoseconds per (vref v 0) 108 | (1g (incf (the fixnum (vref v i)))))) 109 | 110 | 111 | (defun test-cvector (&optional (i 0)) 112 | (declare (type fixnum i)) 113 | (let ((v (make-cvector 10))) 114 | (declare (type cvector v)) 115 | ;; 11.37 nanoseconds per (vref v i) 116 | ;; 11.11 nanoseconds per (vref v 0) 117 | (1g (incf (vref v i))))) 118 | 119 | 120 | (defun test-simple-vector-fixnum (&optional (i 0)) 121 | (declare (type fixnum i)) 122 | (let ((v (make-array 10 :element-type 'fixnum))) 123 | (declare (type simple-array v)) 124 | ;; 1.77 nanoseconds per (aref v i) 125 | ;; 1.52 nanoseconds per (aref v 0) 126 | (1g (incf (the fixnum (aref v i)))))) 127 | 128 | 129 | (defun test-simple-vector (&optional (i 0)) 130 | (declare (type fixnum i)) 131 | (let ((v (make-array 10))) 132 | (declare (type simple-vector v)) 133 | ;; 2.73 nanoseconds per (aref v i) 134 | ;; 2.28 nanoseconds per (aref v 0) 135 | (1g (incf (aref v i))))) 136 | 137 | 138 | (defun test-vector-fixnum (&optional (i 0)) 139 | (declare (type fixnum i)) 140 | (let ((v (make-array 10 :adjustable t))) 141 | (declare (type (and vector (not simple-array)) v)) 142 | ;; 13.64 nanoseconds per (aref v i) 143 | ;; 13.86 nanoseconds per (aref v 0) 144 | (1g (incf (the fixnum (aref v i)))))) 145 | 146 | (defun test-vector (&optional (i 0)) 147 | (declare (type fixnum i)) 148 | (let ((v (make-array 10 :adjustable t))) 149 | (declare (type (and vector (not simple-array)) v)) 150 | ;; 16.72 nanoseconds per (aref v i) 151 | ;; 15.97 nanoseconds per (aref v 0) 152 | (1g (incf (aref v i))))) 153 | 154 | 155 | 156 | (defun test-hash-fixnum (&optional (i 0)) 157 | (declare (type fixnum i)) 158 | (let ((h (make-hash-table :test 'eql :size 10))) 159 | (dotimes (j 10) 160 | (setf (gethash (the fixnum j) h) (the fixnum 0))) 161 | ;; 15.44 nanoseconds per (gethash i h) 162 | ;; 15.08 nanoseconds per (gethash 0 h) 163 | (1g (incf (the fixnum (gethash i h)))))) 164 | 165 | -------------------------------------------------------------------------------- /lang/thread.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 :stmx.lang) 17 | 18 | (enable-#?-syntax) 19 | 20 | 21 | ;; CMUCL: fix some buggy bordeaux-threads type declarations 22 | #+cmucl (declaim (ftype (function (t) t) bt:join-thread)) 23 | #+cmucl (declaim (ftype (function (t t &key (:timeout t)) t) bt:condition-wait)) 24 | 25 | 26 | ;;;; ** Helpers to initialize thread-local variables 27 | 28 | (eval-always 29 | (defun ensure-thread-initial-binding (sym form) 30 | (declare (type symbol sym) 31 | (type (or atom cons) form)) 32 | (unless (assoc sym bt:*default-special-bindings* :test 'eq) 33 | (push (cons sym form) bt:*default-special-bindings*))) 34 | 35 | (defun ensure-thread-initial-bindings (&rest syms-and-forms) 36 | (declare (type list syms-and-forms)) 37 | (loop for sym-and-form in syms-and-forms do 38 | (unless (assoc (first sym-and-form) bt:*default-special-bindings* :test 'eq) 39 | (push sym-and-form bt:*default-special-bindings*)))) 40 | 41 | (defmacro save-thread-initial-bindings (&rest syms) 42 | `(ensure-thread-initial-bindings 43 | ,@(loop for sym in syms collect `(cons ',sym ,sym))))) 44 | 45 | 46 | 47 | 48 | 49 | 50 | ;;;; * Wrappers around Bordeaux Threads to capture 51 | ;;;; * the return value of functions executed in threads 52 | 53 | (declaim (type t *current-thread*)) 54 | (defparameter *current-thread* (current-thread)) 55 | 56 | (eval-always 57 | (ensure-thread-initial-binding '*current-thread* '(current-thread)) 58 | 59 | 60 | (defun start-multithreading () 61 | ;; on CMUCL, (bt:start-multiprocessing) is blocking! 62 | #-cmucl (bt:start-multiprocessing)) 63 | 64 | (start-multithreading) 65 | 66 | (defmacro compile-log-warn (&rest args) 67 | `(when *compile-file-truename* 68 | (log:warn ,@args))) 69 | 70 | (defun detect-thread-support() 71 | "test for multi-threading support: 72 | :STMX/DISABLE-THREADS most not be present CL:*FEATURES*, 73 | BORDEAUX-THREADS:*SUPPORTS-THREADS-P* must be non-NIL, 74 | and (BT:MAKE-THREAD) and (BT:JOIN-THREAD) must work." 75 | 76 | (set-feature 77 | 'bt/make-thread 78 | (block nil 79 | #+stmx/disable-threads 80 | (progn 81 | (compile-log-warn "Warning: compiling STMX without multi-threading support. 82 | reason: feature :STMX/DISABLE-THREADS found in CL:*FEATURES*") 83 | (return nil)) 84 | 85 | #-stmx/disable-threads 86 | (progn 87 | (unless bt:*supports-threads-p* 88 | (compile-log-warn "Warning: compiling STMX without multi-threading support. 89 | reason: BORDEAUX-THREADS:*SUPPORTS-THREADS-P* is NIL") 90 | (return nil)) 91 | 92 | (handler-case 93 | (let* ((x (gensym)) 94 | (y (bt:join-thread (bt:make-thread (lambda () x))))) 95 | (set-feature 'bt/join-thread (if (eq x y) :sane :broken)) 96 | (return t)) 97 | 98 | (condition (c) 99 | (compile-log-warn "Warning: compiling STMX without multi-threading support. 100 | reason: (BORDEAUX-THREADS:JOIN-THREAD (BORDEAUX-THREADS:MAKE-THREAD ...)) 101 | signaled an exception: ~A" c) 102 | (return nil)))))) 103 | 104 | (if (get-feature 'bt/make-thread) 105 | t 106 | ;; if no thread support, no need to wrap threads to collect their exit value 107 | (progn 108 | (set-feature 'bt/join-thread :sane) 109 | nil))) 110 | 111 | (detect-thread-support)) 112 | 113 | 114 | 115 | #?+(eql bt/join-thread :broken) 116 | (defstruct wrapped-thread 117 | (result nil) 118 | (thread (current-thread) :type bt:thread)) 119 | 120 | 121 | 122 | (defun start-thread (function &key name (initial-bindings bt:*default-special-bindings*)) 123 | 124 | #?-bt/make-thread 125 | (error "STMX compiled without multi-threading support, cannot start a new thread with 126 | function = ~S~% name = ~S~% initial-bindings = ~S" function name initial-bindings) 127 | 128 | #?+bt/make-thread 129 | (progn 130 | 131 | #?+(eql bt/join-thread :sane) 132 | (make-thread function :name name :initial-bindings initial-bindings) 133 | 134 | #?-(eql bt/join-thread :sane) 135 | (let ((th (make-wrapped-thread))) 136 | (setf (wrapped-thread-thread th) 137 | (make-thread (lambda () 138 | (setf (wrapped-thread-result th) 139 | (multiple-value-list (funcall function)))) 140 | :name name 141 | :initial-bindings initial-bindings)) 142 | th))) 143 | 144 | (defun wait4-thread (th) 145 | 146 | #?-bt/make-thread 147 | (error "STMX compiled without multi-threading support, cannot wait for thread ~S" th) 148 | 149 | #?+bt/make-thread 150 | (progn 151 | #?+(eql bt/join-thread :sane) 152 | (join-thread th) 153 | 154 | #?-(eql bt/join-thread :sane) 155 | (progn 156 | (join-thread (wrapped-thread-thread th)) 157 | (values-list (wrapped-thread-result th))))) 158 | 159 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | ========== TO DO ========== 2 | 3 | 17) automatically expand $ to $-tx, $-hwtx or $-notx, and similarly expand 4 | (setf $...) and user-defined functions 5 | 6 | 16) implement with-lock-elision using hw-only transactions. It must abort if a SW 7 | transaction is running (?), and it must check for a running HW transaction to make it nestable: 8 | (with-lock-elision (lock1) 9 | (with-lock-elision (lock2) 10 | ...)) 11 | Implement it for both Bordeaux-threads locks and CAS fast mutexes (if available) 12 | 13 | 15) rewrite GMAP methods as functions 14 | 15 | 14) implement pools of RBNODE and TNODE - check if benchmarks improve or not 16 | 17 | 8) optimize ORELSE. The current implementation is quite naive, 18 | it makes a full copy of the current transaction's read and write sets. 19 | 20 | DO NOT DO THIS as it discards TXPAIRs pools, reducing performance: 21 | Possible optimization: perform a shallow copy of transaction's read 22 | and write sets, i.e. copy the vectors containing references to TXPAIR 23 | but do NOT clone the TXPAIRs. It works because TXPAIRs are immutable 24 | during a transaction. 25 | 26 | 27 | ========== DONE ========== 28 | 29 | 23) fix sb-transaction/x86-64-insts.lisp to work with both sbcl >= 1.3.2 and older ones 30 | 31 | 22) fix (disassemble (lambda () (sb-transaction:transaction-begin))) 32 | 33 | 21) removed method override on SHARED-INITIALIZE (not allowed by CLOS MOP standard), 34 | overridden instead INITIALIZE-INSTANCE and REINITIALIZE-INSTANCE. 35 | 36 | 20) renamed $ and (SETF $) to $-SLOT and (SETF $-SLOT). 37 | The functions $ and (SETF $) still exist but now ($ VAR) returns 38 | +UNBOUND-TVAR+ instead of signaling an error if VAR is not bound. 39 | 40 | 19) (HW-ATOMIC2) now checks for running HW or SW transactions as first thing: 41 | HW transactions **cannot** be started from inside another transaction... 42 | disaster would follow, as HW transactions do not check TVARs values stored 43 | in the TLOG and when committing they write directly into TVARs globaly-visible value. 44 | 45 | 18bis) optimized adaptive global clock GV6 - it was horribly slow, 46 | wrote to global memory after each commit and rollback 47 | 48 | 18) implemented adaptive global clock GV6 49 | 50 | 13) completely rewritten THASH-TABLE from scratch. The old implementation was very slow, 51 | before committing it made a full copy of the original hash table then applied 52 | the changes performed by the transaction. 53 | 54 | 12) reduced consing in (commit): modified TVARs are added to a TXPAIR list, 55 | replaced versioned-value CONS with two TVAR slots - when writing, 56 | update the version first, then the value - when reading, get the value first, 57 | then the version. Beware of reordering, memory barriers are needed. 58 | 59 | 11) used global transaction counters to guarantee consistent memory reads. 60 | This solved a big problem that plagues many STM implementations: 61 | a transaction can see an inconsistent view of transactional memory 62 | and start behaving badly (illegal memory accesses, infinite loops...) 63 | before the STM machinery realizes it and re-executes the transaction. 64 | 65 | 9) contacted Lars Rune Nostdal , author of SW-STM: 66 | see http://blog.nostdal.org/ 67 | "I have a very crude and quite horribly written one laying around for 68 | Common Lisp: https://github.com/lnostdal/SW-STM" 69 | 70 | He said SW-STM was never finished, and to look elsewhere for STM implementations. 71 | He also agreed to remove SW-STM from cliki.net since it cannot be downloaded from anywhere. 72 | 73 | 7bis) implemented transactional red-black trees 74 | 75 | 7) implemented red-black trees (needed for transactional red-black trees) 76 | 77 | 6bis) implemented (thash-count) 78 | 79 | 6) implemented transactional hash tables 80 | 81 | 5) implemented before-commit and after-commit (idea from SW-STM when-commit) 82 | 83 | 4.2) optimized nested transaction. Copying all the parent TLOG reads and writes is slow, 84 | so merge only reads-of log1 log2 when retrying a nested transaction 85 | and simply replace reads and writes of parent tlog when committing a nested transaction 86 | 87 | 4.1) tested that errors signalled by an invalid transaction are *not* propagated to the caller 88 | and the transaction is re-executed 89 | 90 | 4) implemented orelse and nested transactions, including tests 91 | 92 | 3) (error 'retry-error ...) now shows the message "attempt to RETRY outside ATOMIC block" 93 | when printed 94 | 95 | 2) in atomic.lisp (run-once) added handler-case to capture errors signaled by a transaction 96 | 97 | 1) implemented ($ tvar) and (setf ($ tvar) value) 98 | for transactional access to tvars. 99 | useful when dealing directly with tvars, 100 | for example in cases transactional objects are too heavyweight 101 | 102 | 103 | ========== WON'T DO ========== 104 | 10) move locks and notifications from a per-slot tvar to per-object data. 105 | Use a single slot or several one in transactional-object ? 106 | FOR THE MOMENT, NO. 107 | it increases code complexity and removes the ability to use raw TVARs from 108 | application code for unclear benefits: no indication that performance 109 | will be better, no significant reduction in memory footprint 110 | (TVARs will need to hold a reference to TOBJ or TSLOT, plus their 111 | index in the object's slots) 112 | 113 | 114 | 4.3) allow orelse/nonblocking to work even without a parent transaction, 115 | i.e. outside (atomic ...) ? 116 | NO. 117 | the overhead of (atomic (orelse ...)) is minimal with respect to bare 118 | (orelse ...), and the former is clearer to understand. 119 | Also, doing this would make orelse implementation slower and even more 120 | complicated than what already is. 121 | -------------------------------------------------------------------------------- /asm/transaction.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 :stmx.asm) 17 | 18 | 19 | (declaim ; (ftype (function () (values (unsigned-byte 32) &optional)) transaction-begin) 20 | ; (ftype (function () (values &optional)) transaction-end) 21 | ; (ftype (function () (values &optional)) transaction-abort) 22 | ; (ftype (function () (values boolean &optional)) transaction-running-p) 23 | ; (ftype (function (fixnum) (values boolean &optional)) transaction-rerun-may-succeed-p) 24 | (inline transaction-begin 25 | transaction-end 26 | transaction-abort 27 | transaction-running-p 28 | transaction-rerun-may-succeed-p)) 29 | 30 | 31 | (defun %transaction-begin () 32 | (%transaction-begin)) 33 | 34 | (defun %transaction-end () 35 | (%transaction-end)) 36 | 37 | ;(defun %transaction-abort (err-code) 38 | ; (%transaction-abort err-code)) 39 | 40 | (defun %transaction-running-p () 41 | (%transaction-running-p)) 42 | 43 | 44 | (defun transaction-begin () 45 | "Start a hardware memory transaction. 46 | Return +transaction-started+ if transaction started successfully, 47 | otherwise return code of the error that caused the transaction to abort. 48 | 49 | Invoking TRANSACTION-BEGIN while there is already a running hardware 50 | memory transaction has implementation-dependent effects." 51 | (%transaction-begin) 52 | #-(and) (sb-c::%primitive %xbegin)) 53 | 54 | 55 | 56 | 57 | (defun transaction-end () 58 | "Commit a hardware memory transaction. 59 | Return normally (with an implementation-dependent value) if commit is successful, 60 | otherwise abort the transaction. 61 | 62 | In case the transaction is aborted, all effects of code between TRANSACTION-BEGIN 63 | and TRANSACTION-END are rolled back (undone): 64 | execution resumes at the instruction immediately after TRANSACTION-BEGIN, 65 | in such a way that TRANSACTION-BEGIN will appear to have returned 66 | a non-zero error code (that describes the abort reason). 67 | 68 | Invoking TRANSACTION-END without a running hardware memory transaction 69 | has undefined consequences." 70 | (%transaction-end) 71 | #-(and) (progn 72 | (sb-c::%primitive %xend) 73 | 0) 74 | ) 75 | 76 | 77 | 78 | (declaim (type fixnum +transaction-user-abort+)) 79 | 80 | (defconstant +transaction-user-abort+ #x1000001 81 | "Value returned by (transaction-begin) if the transaction was manually aborted 82 | by calling (transaction-abort). 83 | It is an implementation-dependent fixnum, different from +transaction-started+ 84 | and from all error codes indicating a spontaneous abort.") 85 | 86 | 87 | (defmacro transaction-abort-macro (&optional (err-code (ash +transaction-user-abort+ -24))) 88 | "Immediately abort a hardware memory transaction with a user-specified 89 | ERR-CODE, which must be a constant between 0 and 255 (default: 1). 90 | Note: the value returned by (transaction-begin) will also contain \"somewhere\" 91 | the bits of ERR-CODE, but will have a different value. 92 | See Intel x86-64 CPU instruction reference manual, section TSX, for details. 93 | 94 | If a transaction is in progress, TRANSACTION-ABORT-MACRO does not return normally: 95 | execution is resumed at the instruction immediately after the outermost 96 | TRANSACTION-BEGIN. 97 | 98 | If called without a running transaction, TRANSACTION-ABORT-MACRO returns normally 99 | with an implementation-dependent value." 100 | (unless (typep err-code '(unsigned-byte 8)) 101 | (error 'type-error 102 | :expected-type '(unsigned-byte 8) :datum err-code)) 103 | `(progn 104 | (sb-c::%primitive %xabort ,err-code) 105 | 0)) 106 | 107 | 108 | 109 | (defun transaction-abort () 110 | "Voluntarily abort a hardware memory transaction 111 | with an error-code equal to +transaction-user-abort+. 112 | 113 | If a transaction is in progress, TRANSACTION-ABORT does not return normally: 114 | execution is resumed at the instruction immediately after the outermost 115 | TRANSACTION-BEGIN. 116 | 117 | If called without an active transaction, TRANSACTION-ABORT returns normally 118 | with an implementation-dependent value." 119 | (transaction-abort-macro)) 120 | 121 | 122 | (defun transaction-running-p () 123 | "Return T if a hardware memory transaction 124 | is currently in progress, otherwise return NIL." 125 | (%transaction-running-p)) 126 | 127 | 128 | 129 | 130 | (defun transaction-rerun-may-succeed-p (err-code) 131 | "If ERR-CODE is the result returned by (TRANSACTION-BEGIN) of an *aborted* transaction, 132 | return T if re-running the same transaction has a possibility to succeed, 133 | i.e. if the abort reason was temporary (as for example a conflict with another thread). 134 | Return NIL if re-running the same transaction has no possibility to succeed." 135 | (declare (type fixnum err-code)) 136 | 137 | ;; see Intel Instruction reference manual for all the possible bits... 138 | ;; bit 0: set if abort caused by XABORT 139 | ;; bit 1: set if the transaction may succeed on a retry. always zero if bit 0 is set 140 | ;; 141 | ;; Note: +transaction-started+ is equal to 3 exactly because a transaction abort 142 | ;; (spontaneous or caused by XABORT) will never return an error code with bits 0 and 1 both set. 143 | (/= 0 (logand err-code 2))) 144 | -------------------------------------------------------------------------------- /doc/introduction.md: -------------------------------------------------------------------------------- 1 | STMX 2 | ====== 3 | 4 | Introduction 5 | ------------ 6 | 7 | STMX is an actively maintained, high-performance concurrency library providing 8 | Software Transactional Memory for Common Lisp. 9 | 10 | Home page and downloads: [http://github.com/cosmos72/stmx](http://github.com/cosmos72/stmx) 11 | 12 | Main features 13 | ------------- 14 | 15 | - Extremely intuitive to use and to write correct, thread-safe concurrent code. 16 | - Brings database-style transactions to Common Lisp by introducing transactional 17 | memory. 18 | - High performance implementation, benchmarked to reach up to 6 millions 19 | transactions per second per CPU core on commodity PC hardware. 20 | - Removes the need for traditional locks, mutexes and conditions - writing 21 | correct concurrent code with them is well known to be hard. 22 | - Transactional code is intrinsically deadlock-free: if two transactions 23 | conflict one of them will be re-executed. 24 | - Automatic commit and rollback: if a transaction completes normally it will 25 | be committed, if it exits with a non-local control transfer (signals an error, 26 | throws, or calls (go ...) to exit an atomic block) it will be rolled back. 27 | - Transactions are composable: they can be executed in a larger transaction, 28 | either in sequence (all-or-nothing) or as alternatives (try them in order 29 | until one succeeds). 30 | - Guarantees a consistent view of memory during transactions: concurrent updates 31 | from other threads are not visible - if the consistency cannot be guaranteed, 32 | the transaction will be automatically rolled back and re-executed from scratch. 33 | - Offers freedom of choice between blocking and non-blocking transactional 34 | functions: given either behaviour, it is trivial to transform it into the 35 | other. 36 | - Features transactional versions of popular data structures: hash tables, 37 | red-black trees, stack, fifo, etc. 38 | - Includes transactional data structure for multicast publish/subscribe 39 | - Creating new transactional data structures is easy. 40 | - Extensive test suite. 41 | - Tested on SBCL, CMUCL, CCL and ABCL. 42 | - Very simple to install with [Quicklisp](http://www.quicklisp.org/). 43 | 44 | A quick-start guide and installation instructions are provided in the file 45 | [README.md](../README.md). 46 | 47 | License: [LLGPL](http://opensource.franz.com/preamble.html) 48 | 49 | What STMX is **NOT** 50 | -------------------- 51 | 52 | In order not to confuse programmers - less experienced ones in particular - 53 | and to avoid rising unrealistic hopes, the author states the following 54 | about STMX: 55 | 56 | - it is **not** a quick hack to automagically transform existing, slow, 57 | single-threaded programs into fast, concurrent ones. 58 | No matter how much transactions can help, writing concurrent code 59 | still requires careful design and implementation - and testing. 60 | And refactoring takes time too. 61 | - it is **not** for optimization-focused programmers trying to squeeze the last 62 | cycle from their Common Lisp programs. STMX records an in-memory transaction 63 | log containing all reads and writes from/to transactional memory, then later 64 | (during commit) validates the transaction log against the latest data present 65 | in transactional memory and finally copies the transaction log onto the 66 | transactional memory while holding locks. STMX is quite optimized, but this 67 | machinery comes at an obvious performance cost with respect to hand-made, 68 | highly optimized locking code (but a good cross-check is to ask yourself 69 | how many people have the skill and patience to write such locking code 70 | without bugs). 71 | - it is **not** supposed to be used for all data structures in a Common Lisp 72 | program. STMX is intended only for the data accessed concurrently by multiple 73 | threads while being destructively modified by at least one thread. 74 | And even in that case, transactional memory is **not always** needed: 75 | for simple modifications, locking code is usually feasible; for complex 76 | structural modifications, STMX can help greatly. 77 | - it is **not** a serialization or persistence framework. Rather, messing with 78 | metaclasses and playing (allowed) tricks with slots contents as STMX does, 79 | quite likely does **not** mix well with serialization or persistence 80 | libraries such as CL-STORE or CL-MARSHAL, because they typically need 81 | full control on the slots of the objects to be serialized and de-serialized. 82 | - it is **not** a million dollar library from some deep-pocket company. At the 83 | moment, it is the work of a single person. 84 | 85 | 86 | Implementation 87 | -------------- 88 | 89 | STMX is based on the concepts described in [Composable Memory 90 | Transactions](http://research.microsoft.com/~simonpj/papers/stm/stm.pdf) 91 | with the addition of a global version clock as described in [Transactional 92 | Locking II](http://home.comcast.net/~pjbishop/Dave/GVTL-TL2-Disc06-060711-Camera.pdf) 93 | 94 | In particular: 95 | - transactional memory reads and writes are stored in a transaction log, 96 | and written values are copied into the actual memory location only during 97 | commit 98 | - each transactional memory location is locked only during commit, not while 99 | accessing it 100 | - conflicts, i.e. multiple transactions trying to write simultaneously 101 | the same memory location, are detected automatically during commit. 102 | In such case, one transaction will commit and all other ones will be 103 | rolled back and re-executed from the beginning 104 | - thanks to the global version clock, it **cannot** happen that a transaction 105 | sees an inconsistent view of transactional memory even if other threads 106 | modify it. 107 | 108 | The worst that can happen is an automatic rollback and re-execution of a 109 | transaction immediately **before** it can see an inconsistent view of 110 | transactional memory. 111 | -------------------------------------------------------------------------------- /example/dining-philosophers.lock.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 :cl-user) 17 | 18 | (defpackage #:stmx.example.dining-philosophers.lock 19 | (:use #:cl) 20 | 21 | (:import-from #:stmx.lang 22 | #:eval-always 23 | #:start-thread #:wait4-thread)) 24 | 25 | 26 | (in-package :stmx.example.dining-philosophers.lock) 27 | 28 | 29 | ;; standard bordeaux-threads lock. for this simple example, 30 | ;; they are up to 3 times faster than STMX transactions 31 | #-(and) 32 | (eval-always 33 | (deftype lock () 't) 34 | 35 | (defmacro make-lock (&optional name) 36 | `(bt:make-lock ,name)) 37 | 38 | (defmacro acquire-lock (lock) 39 | `(bt:acquire-lock ,lock nil)) 40 | 41 | (defmacro release-lock (lock) 42 | `(bt:release-lock ,lock))) 43 | 44 | 45 | ;; fast locks using atomic compare-and-swap if available. 46 | ;; for this simple example, they are up to 10 times faster than STMX transactions 47 | #+(and) 48 | (eval-always 49 | (deftype lock () 'stmx::mutex) 50 | 51 | (defmacro make-lock (&optional name) 52 | (declare (ignore name)) 53 | `(stmx.lang::make-mutex)) 54 | 55 | (defmacro acquire-lock (lock) 56 | `(stmx.lang::try-acquire-mutex ,lock)) 57 | 58 | (defmacro release-lock (lock) 59 | `(stmx.lang::release-mutex ,lock))) 60 | 61 | 62 | (declaim (ftype (function (cons) fixnum) eat-from-plate) 63 | (inline eat-from-plate)) 64 | (defun eat-from-plate (plate) 65 | "Decrease by one TVAR in plate." 66 | (declare (type cons plate)) 67 | (decf (the fixnum (car plate)))) 68 | 69 | 70 | (declaim (ftype (function (lock lock cons) fixnum) philosopher-eats) 71 | (inline philosopher-eats)) 72 | 73 | (defun philosopher-eats (fork1 fork2 plate) 74 | "Try to eat once. return remaining hunger" 75 | (declare (type lock fork1 fork2) 76 | (type cons plate)) 77 | 78 | ;; also keep track of failed lock attempts for demonstration purposes. 79 | (decf (the fixnum (cdr plate))) 80 | 81 | (let ((hunger -1)) ;; unknown 82 | (when (acquire-lock fork1) 83 | (when (acquire-lock fork2) 84 | (setf hunger (eat-from-plate plate)) 85 | (release-lock fork2)) 86 | (release-lock fork1)) 87 | 88 | (when (= -1 hunger) 89 | (bt:thread-yield)) 90 | 91 | hunger)) 92 | 93 | 94 | 95 | 96 | 97 | (defun dining-philosopher (i fork1 fork2 plate) 98 | "Eat until not hungry anymore." 99 | (declare (type lock fork1 fork2) 100 | (type cons plate) 101 | (type fixnum i)) 102 | ;;(with-output-to-string (out) 103 | ;; (let ((*standard-output* out)) 104 | (log:trace "philosopher ~A: fork1=~A fork2=~A plate=~A~%" 105 | i fork1 fork2 (car plate)) 106 | ;;(sb-sprof:with-profiling 107 | ;; (:max-samples 1000 :sample-interval 0.001 :report :graph 108 | ;; :loop nil :show-progress t :mode :alloc) 109 | 110 | (loop until (zerop (philosopher-eats fork1 fork2 plate)))) 111 | 112 | 113 | (defun dining-philosophers (philosophers-count &optional (philosophers-initial-hunger 20000000)) 114 | "Prepare the table, sit the philosophers, let them eat. 115 | Note: the default initial hunger is 10 millions, 116 | i.e. ten times more than the STMX version." 117 | (declare (type fixnum philosophers-count philosophers-initial-hunger)) 118 | 119 | (when (< philosophers-count 1) 120 | (error "philosophers-count is ~A, expecting at least 1" philosophers-count)) 121 | 122 | (let* ((n philosophers-count) 123 | (nforks (max n 2)) 124 | (forks (loop for i from 1 to nforks collect (make-lock (format nil "~A" i)))) 125 | (plates (loop for i from 1 to n collect 126 | (cons philosophers-initial-hunger 127 | philosophers-initial-hunger))) 128 | (philosophers 129 | (loop for i from 1 to n collect 130 | (let ((fork1 (nth (1- i) forks)) 131 | (fork2 (nth (mod i nforks) forks)) 132 | (plate (nth (1- i) plates)) 133 | (j i)) 134 | 135 | ;; make the last philospher left-handed 136 | (when (= i n) 137 | (rotatef fork1 fork2)) 138 | 139 | (lambda () 140 | (dining-philosopher j fork1 fork2 plate)))))) 141 | 142 | (let* ((start (get-internal-real-time)) 143 | (threads (loop for philosopher in philosophers 144 | for i from 1 145 | collect (start-thread philosopher 146 | :name (format nil "philosopher ~A" i))))) 147 | 148 | (loop for thread in threads do 149 | (let ((result (wait4-thread thread))) 150 | (when result 151 | (print result)))) 152 | 153 | (let* ((end (get-internal-real-time)) 154 | (elapsed-secs (/ (- end start) (float internal-time-units-per-second))) 155 | (tx-count (/ (* n philosophers-initial-hunger) elapsed-secs)) 156 | (tx-unit "")) 157 | (when (>= tx-count 100000) 158 | (setf tx-count (/ tx-count 1000000) 159 | tx-unit " millions")) 160 | (log:info "~3$~A iterations per second, elapsed time: ~3$ seconds" 161 | tx-count tx-unit elapsed-secs)) 162 | 163 | (loop for (plate . fails) in plates 164 | for i from 1 do 165 | (log:debug "philosopher ~A: ~A successful attempts, ~A failed" 166 | i (- philosophers-initial-hunger plate) (- fails)))))) 167 | --------------------------------------------------------------------------------