;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: SYSTEM -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

;;;;
;;;;  MP.LSP  -- Multiprocessing capabilities.

;;;;  Copyright (c) 2003, Juan Jose Garcia-Ripoll
;;;;
;;;;    See file 'LICENSE' for the copyright details.

#-threads
(defpackage "MP"
  (:use "CL" "SI")
  (:export "WITH-LOCK"))

(in-package "MP")

;;;
;;; Interrupt disabling and enabling
;;;
(defmacro without-interrupts (&body body)
  #!+sb-doc
  "Executes BODY with all deferrable interrupts disabled. Deferrable
interrupts arriving during execution of the BODY take effect after BODY has
been executed.

Deferrable interrupts include most blockable POSIX signals, and
MP:INTERRUPT-PROCESS. Does not interfere with garbage collection, and
unlike in many traditional Lisps using userspace threads, in ECL
WITHOUT-INTERRUPTS does not inhibit scheduling of other threads.

Binds ALLOW-WITH-INTERRUPTS, WITH-LOCAL-INTERRUPTS and WITH-RESTORED-INTERRUPTS
as a local macros.

WITH-RESTORED-INTERRUPTS executes the body with interrupts enabled if and only
if the WITHOUT-INTERRUPTS was in an environment in which interrupts were allowed.

ALLOW-WITH-INTERRUPTS allows the WITH-INTERRUPTS to take effect during the
dynamic scope of its body, unless there is an outer WITHOUT-INTERRUPTS without
a corresponding ALLOW-WITH-INTERRUPTS.

WITH-LOCAL-INTERRUPTS executes its body with interrupts enabled provided that
there is an ALLOW-WITH-INTERRUPTS for every WITHOUT-INTERRUPTS surrounding
the current one. WITH-LOCAL-INTERRUPTS is equivalent to:

  (allow-with-interrupts (with-interrupts ...))

Care must be taken not to let either ALLOW-WITH-INTERRUPTS or
WITH-LOCAL-INTERRUPTS appear in a function that escapes from inside the
WITHOUT-INTERRUPTS in:

  (without-interrupts
    ;; The body of the lambda would be executed with WITH-INTERRUPTS allowed
    ;; regardless of the interrupt policy in effect when it is called.
    (lambda () (allow-with-interrupts ...)))

  (without-interrupts
    ;; The body of the lambda would be executed with interrupts enabled
    ;; regardless of the interrupt policy in effect when it is called.
    (lambda () (with-local-interrupts ...)))
"
  (ext:with-unique-names (outer-allow-with-interrupts outer-interrupts-enabled)
    `(multiple-value-prog1
         (macrolet ((allow-with-interrupts (&body allow-forms)
                      `(let ((si:*allow-with-interrupts* ,',outer-allow-with-interrupts))
                         ,@allow-forms))
                    (with-restored-interrupts (&body with-forms)
                      `(let ((si:*interrupts-enabled* ,',outer-interrupts-enabled))
                         ,@with-forms))
                    (with-local-interrupts (&body with-forms)
                      `(let* ((si:*allow-with-interrupts* ,',outer-allow-with-interrupts)
                              (si:*interrupts-enabled* ,',outer-allow-with-interrupts))
                         (when ,',outer-allow-with-interrupts
                           (si::check-pending-interrupts))
                         (locally ,@with-forms))))
           (let* ((,outer-interrupts-enabled si:*interrupts-enabled*)
                  (si:*interrupts-enabled* nil)
                  (,outer-allow-with-interrupts si:*allow-with-interrupts*)
                  (si:*allow-with-interrupts* nil))
             (declare (ignorable ,outer-allow-with-interrupts
                                 ,outer-interrupts-enabled))
             ,@body))
       (when si:*interrupts-enabled*
         (si::check-pending-interrupts)))))

(defmacro with-interrupts (&body body)
  "Executes BODY with deferrable interrupts conditionally enabled. If there
are pending interrupts they take effect prior to executing BODY.

As interrupts are normally allowed WITH-INTERRUPTS only makes sense if there
is an outer WITHOUT-INTERRUPTS with a corresponding ALLOW-WITH-INTERRUPTS:
interrupts are not enabled if any outer WITHOUT-INTERRUPTS is not accompanied
by ALLOW-WITH-INTERRUPTS."
  (ext:with-unique-names (allowp enablep)
    ;; We could manage without ENABLEP here, but that would require
    ;; taking extra care not to ever have *ALLOW-WITH-INTERRUPTS* NIL
    ;; and *INTERRUPTS-ENABLED* T -- instead of risking future breakage
    ;; we take the tiny hit here.
    `(let* ((,allowp si:*allow-with-interrupts*)
            (,enablep si:*interrupts-enabled*)
            (si:*interrupts-enabled* (or ,enablep ,allowp)))
       (when (and ,allowp (not ,enablep))
         (si::check-pending-interrupts))
       (locally ,@body))))


;;;
;;; Convenience macros for locks
;;;
(defmacro with-lock ((lock-form &key (wait-form t)) &body body)
  #-threads
  `(progn ,@body)
  ;; We do our best to make sure that the lock is released if we are
  ;; interrupted and jump up the call stack, however there is an
  ;; unavoidable race condition if the interrupt happens after the
  ;; mutex is locked but before we store the return value of
  ;; mp:get-lock.
  #+threads
  (ext:with-unique-names (lock wait)
    `(let ((,lock ,lock-form)
           (,wait ,wait-form))
       (when (mp:get-lock ,lock ,wait)
         (without-interrupts
           (unwind-protect
                (with-restored-interrupts
                    (locally ,@body))
             (mp:giveup-lock ,lock)))))))

#+ecl-read-write-lock
(defmacro with-rwlock ((lock op) &body body)
  "Acquire rwlock for the dynamic scope of BODY for operation OP,
which is executed with the lock held by current thread, and
WITH-RWLOCK returns the values of body.

Valid values of argument OP are :READ or :WRITE
\(for reader and writer access accordingly)."
  (assert (member op '(:read :write) :test #'eq))
  (let ((s-lock (gensym)))
    `(let ((,s-lock ,lock))
       (,(if (eq :read op)
             'mp:get-rwlock-read
             'mp:get-rwlock-write)
         ,s-lock t)
       (mp:without-interrupts
           (unwind-protect
                (mp:with-restored-interrupts
                    ,@body)
             (,(if (eq :read op)
                   'mp:giveup-rwlock-read
                   'mp:giveup-rwlock-write)
               ,s-lock))))))

;;;
;;; Atomic operations
;;;
#+threads
(defmacro define-cas-expander (accessor lambda-list &body body)
  "Define a COMPARE-AND-SWAP expander similar to DEFINE-SETF-EXPANDER.
Syntax: (define-cas-expander accessor lambda-list {decl | doc}*
          {form}*)
Defines the COMPARE-AND-SWAP-expander for generalized-variables (ACCESSOR ...).
When a form (compare-and-swap (ACCESSOR arg1 ... argn) old new) is evaluated, the FORMs
given in the DEFINE-CAS-EXPANDER are evaluated in order with the parameters in
LAMBDA-LIST bound to ARG1 ... ARGn.  The last FORM must return six
values
        (var1 ... vark)
        (form1 ... formk)
        old-var
        new-var
        compare-and-swap-form
        volatile-access-form
in order (Note that old-var and new-var are single variables, unlike
in DEFINE-SETF-EXPANDER). The whole COMPARE-AND-SWAP form is then
expanded into
        (let* ((var1 from1) ... (vark formk)
               (old-var old-form)
               (new-var new-form))
          compare-and-swap-form).
Note that it is up to the user of this macro to ensure atomicity for
the resulting COMPARE-AND-SWAP expansions."
  (let ((env (member '&environment lambda-list :test #'eq)))
    (if env
        (setq lambda-list (cons (second env)
                         (nconc (ldiff lambda-list env) (cddr env))))
        (progn
          (setq env (gensym))
          (setq lambda-list (cons env lambda-list))
          (push `(declare (ignore ,env)) body))))
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (let ((package (symbol-package ',accessor)))
       (when (and package
                  (ext:package-locked-p package)
                  (null si:*ignore-package-locks*))
         (si:signal-simple-error 'package-error
                                 "Ignore lock and proceed."
                                 "Attempt to define CAS accessor ~S in locked package."
                                 '(,accessor)
                                 :package package)))
     (si:put-sysprop ',accessor 'CAS-EXPANDER
                     ,(multiple-value-bind (decls body)
                          (si::find-declarations body)
                        `#'(lambda ,lambda-list
                             ,@decls
                             (block ,accessor ,@body))))
     ',accessor))

#+threads
(defmacro defcas (accessor cas-fun &optional documentation)
  "Define a COMPARE-AND-SWAP expansion similar to the short form of DEFSETF.
Syntax: (defsetf accessor cas-fun)
Defines an expansion
        (compare-and-swap (ACCESSOR arg1 ... argn) old new)
        => (CAS-FUN arg1 ... argn old new)
Note that it is up to the user of this macro to ensure atomicity for
the resulting COMPARE-AND-SWAP expansions."
  (declare (ignore documentation))
  `(define-cas-expander ,accessor (&rest args)
     (let ((old (gensym)) (new (gensym)))
       (values nil nil old new
               `(,',cas-fun ,@args ,old ,new)
               `(,',accessor ,@args)))))

;; XXX - Hacky way to determine at macroexpand time whether place is a
;; special variable (works for both bytecodes and native compiler). To
;; be replaced by a better way once the cltl2 environment access is
;; implemented (see issue #63). -- mg 2019-10-31
(defun special-variable-p (place)
  (declare (si::c-local))
  (and (symbolp place)
       (or (and (fboundp 'c::special-variable-p)
                (c::special-variable-p place))
           (si:specialp place))))

#+threads
(defun remcas (symbol)
  "Remove a COMPARE-AND-SWAP expansion. It is a CAS operation equivalent of
    (FMAKUNBOUND (SETF SYMBOL))"
  (let ((package (symbol-package symbol)))
    (when (and package
               (ext:package-locked-p package)
               (null si:*ignore-package-locks*))
      (si:signal-simple-error 'package-error
                              "Ignore lock and proceed."
                              "Attempt to define CAS accessor ~S in locked package."
                              (list symbol)
                              :package package)))
  (si:rem-sysprop symbol 'cas-expander))

#+threads
(defun get-cas-expansion (place &optional environment &aux f)
  "Returns the COMPARE-AND-SWAP expansion forms and variables as defined
in DEFINE-CAS-EXPANDER for PLACE as six values."
  (when (special-variable-p place)
    (setf place `(symbol-value ',place)))
  (cond ((and (listp place)
              (setq f (si:get-sysprop (first place) 'CAS-EXPANDER)))
         (apply f environment (rest place)))
        ;; We try macro expansion with MACROEXPAND-1 as in SETF
        ((and (setq f (macroexpand-1 place environment)) (not (equal f place)))
         (get-cas-expansion f environment))
        ;; Functions like (cas foo) analogous to (setf foo) are
        ;; currently not supported, hence we throw an error here
        (t (error "Cannot get the compare-and-swap expansion of ~S." place))))

(defmacro compare-and-swap (&environment env place old new)
  "Atomically stores NEW in PLACE if OLD is eq to the current value of
PLACE. Returns the previous value of PLACE: if the returned value is
eq to OLD, the swap was carried out.

Currently, the following places are supported:

car, cdr, first, rest, svref, symbol-plist, symbol-value, slot-value,
clos:standard-instance-access, clos:funcallable-standard-instance-access,
a struct accessor or any other place for which a compare-and-swap
expansion was defined by defcas or define-cas-expander.

For slot-value, slot-unbound is called if the slot is unbound unless
OLD is eq to si:unbound, in which case OLD is returned and NEW is
assigned to the slot. Additionally, the object should have no
applicable methods defined for slot-value-using-class or (setf
slot-value-using-class)."
  #+threads
  (multiple-value-bind (vars vals old-var new-var cas-form)
      (get-cas-expansion place env)
    `(let* (,@(mapcar #'list vars vals)
            (,old-var ,old)
            (,new-var ,new))
       ,cas-form))
  #-threads
  (let ((old-value (gensym)))
    `(let ((,old-value ,place))
       (when (eq ,old ,old-value)
         (setf ,place ,new))
       ,old-value)))

#+threads
(progn
  (defcas car mp:compare-and-swap-car)
  (defcas first mp:compare-and-swap-car)
  (defcas cdr mp:compare-and-swap-cdr)
  (defcas rest mp:compare-and-swap-cdr)
  (defcas symbol-value mp:compare-and-swap-symbol-value)
  (defcas symbol-plist mp:compare-and-swap-symbol-plist)
  (defcas svref mp:compare-and-swap-svref)
  (defcas slot-value mp::compare-and-swap-slot-value)
  (defcas clos:standard-instance-access mp::compare-and-swap-standard-instance)
  (defcas clos:funcallable-standard-instance-access mp::compare-and-swap-standard-instance))

(defmacro atomic-update (place update-fn &rest arguments)
  "Atomically updates the CAS-able PLACE to the value returned by calling UPDATE-FN with ARGUMENTS and the old value of PLACE. UPDATE-FN must be a function accepting (1+ (length ARGUMENTS)) arguments. Returns the new value which was stored in PLACE.

PLACE may be read and UPDATE-FN may be called more than once if multiple threads are trying to write to PLACE at the same time."
  #+threads
  (let ((new (gensym))
        (old (gensym)))
    `(let ((,old ,place))
       (loop for ,new = (funcall ,update-fn ,@arguments ,old)
          until (eq ,old (setf ,old (compare-and-swap ,place ,old ,new)))
          finally (return ,new))))
  #-threads
  `(setf ,place (funcall ,update-fn ,@arguments ,place)))

(defmacro atomic-push (obj place)
  "Like PUSH, but atomic. PLACE must be CAS-able and may be read
multiple times before the update succeeds."
  #+threads
  (let ((new (gensym))
        (old (gensym)))
    `(let* ((,old ,place)
            (,new (cons ,obj ,old)))
       (loop until (eq ,old (setf ,old (compare-and-swap ,place ,old ,new)))
          do (setf (cdr ,new) ,old)
          finally (return ,new))))
  #-threads
  `(push ,obj ,place))

(defmacro atomic-pop (place)
  "Like POP, but atomic. PLACE must be CAS-able and may be read
multiple times before the update succeeds."
  #+threads
  (let ((new (gensym))
        (old (gensym)))
    `(let* ((,old ,place))
       (loop for ,new = (cdr ,old)
          until (eq ,old (setf ,old (compare-and-swap ,place ,old ,new)))
          finally (return (car (ext:truly-the list ,old))))))
  #-threads
  `(pop ,place))

(defmacro atomic-incf (place &optional (increment 1))
  "Atomically increments the fixnum stored in PLACE by the given
INCREMENT and returns the value of PLACE before the increment.
Incrementing is done using modular arithmetic, so that atomic-incf of
a place whose value is most-positive-fixnum by 1 results in
most-negative-fixnum stored in place.

Currently the following places are supported:
car, cdr, first, rest, svref, symbol-value, slot-value,
clos:standard-instance-access, clos:funcallable-standard-instance-access.

For slot-value, the object should have no applicable methods defined
for slot-value-using-class or (setf slot-value-using-class).

The consequences are undefined if the value of PLACE is not of type
fixnum."
  #+threads
  (progn
    (setf place (macroexpand place))
    (when (special-variable-p place)
      (setf place `(symbol-value ',place)))
    (let ((fun (when (listp place)
                   (case (first place)
                     ((car first) 'mp:atomic-incf-car)
                     ((cdr rest) 'mp:atomic-incf-cdr)
                     (symbol-value 'mp:atomic-incf-symbol-value)
                     (svref 'mp:atomic-incf-svref)
                     (slot-value 'mp::atomic-incf-slot-value)
                     ((clos:standard-instance-access clos:funcallable-standard-instance-access) 'mp::atomic-incf-standard-instance)))))
      (unless fun
        (error "No ATOMIC-INCF expansion defined for place ~S." place))
      `(,fun ,@(rest place) ,increment)))
  #-threads
  (let ((value (gensym))
        (incr (gensym)))
    `(let ((,value ,place)
           (,incr ,increment))
       (declare (fixnum ,value ,incr))
       (setf ,place (+ (mod (+ ,value ,incr most-negative-fixnum)
                            (* -2 most-negative-fixnum))
                       most-negative-fixnum))
       ,value)))

(defmacro atomic-decf (place &optional (decrement 1))
  "Atomically decrements the fixnum stored in PLACE by the given
DECREMENT and returns the value of PLACE before the decrement.
Decrementing is done using modular arithmetic, so that atomic-decf of
a place whose value is most-negative-fixnum by 1 results in
most-positive-fixnum stored in place.

Currently the following places are supported:
car, cdr, first, rest, svref, symbol-value, slot-value,
clos:standard-instance-access, clos:funcallable-standard-instance-access.

For slot-value, the object should have no applicable methods defined
for slot-value-using-class or (setf slot-value-using-class).

The consequences are undefined if the value of PLACE is not of type
fixnum."
  `(atomic-incf ,place (- ,decrement)))
