Head

GCC Code Coverage Report

Directory:	../src/		Exec	Total	Coverage
File:	/home/joels/Current/lispbm/src/extensions/mutex_extensions.c	Lines:	56	65	86.2 %
Date:	2025-01-19 11:10:47	Branches:	18	34	52.9 %


/*
    Copyright 2025 Joel Svensson        svenssonjoel@yahoo.se

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*/

#include "extensions/mutex_extensions.h"

#include "extensions.h"
#include "eval_cps.h"

// This file provides a mutual exclusion feature based on the block_from_extension
// mechanism present in LBM.
//
// Three operations are provided:
// - mutex-create
// - mutex-lock
// - mutex-unlock
//
// It is strongly adviced to use these as a low-level interface and then to wrap
// them up in a (with-mutex-do mutex expr) that implements the locking and unlocking
// so that no mutex is left dangling.
//
// with-mutex-do can be implemented as
//
// (define with-mutex-do (lambda (mutex quoted-expr)
//   (progn (mutex-lock mutex)
//          (eval quoted-expr)
//          (mutex-unlock mutex)
//
//
// The mutex object is a dotted pair (ls . last) which contains
// two references into a single list, implementing a O(1)-insert-last O(1)-remove-first
// queue. At the surface though, it is a regular lisp dotted pair that
// can be destroyed with standard lisp functionality, no protection!
// When a good replacement for "Custom types" is invented this will be improved.

bool is_mutex(lbm_value v) {
  // true if it is somewhat likely that v is a mutex.
  bool res = (lbm_is_cons(v) &&
              (!lbm_is_symbol_nil(lbm_car(v)) ||  lbm_is_symbol_nil(lbm_cdr(v)))); // car == nil -> cdr == nil
  // potentially add a clause
  //      car == (cons a b) -> cdr == (cons c nil)
  return res;
}

bool is_mutex_unlocked(lbm_value v) {
  return (lbm_is_symbol_nil(lbm_car(v)));
}

void enqueue_cid(lbm_value mutex, lbm_value cid_pair) {
  if (lbm_is_symbol_nil(lbm_car(mutex))) {
    lbm_set_car(mutex, cid_pair);
    lbm_set_cdr(mutex, cid_pair);
  } else {
    lbm_value last = lbm_cdr(mutex);
    lbm_set_cdr(last, cid_pair);
    lbm_set_cdr(mutex, cid_pair);
  }
}

bool dequeue_cid(lbm_value mutex, lbm_value cid) {
  bool res = false;
  if (lbm_is_cons(lbm_car(mutex))) {
    lbm_value locked_cid = lbm_car(lbm_car(mutex));
    if (locked_cid == cid) { // no decoding
      res = true;
      lbm_value head = lbm_car(mutex);
      lbm_value last = lbm_cdr(mutex);
      if (head == last) { // one element
        lbm_set_car(mutex, ENC_SYM_NIL);
        lbm_set_cdr(mutex, ENC_SYM_NIL);
      } else {
        lbm_set_car(mutex, lbm_cdr(head));
      }
    }
  }
  return res;
}

lbm_value head_of_queue(lbm_value mutex) {
  lbm_value res = ENC_SYM_NIL;
  if (lbm_is_cons(lbm_car(mutex))) {
    res = lbm_car(lbm_car(mutex));
  }
  return res;
}

static lbm_value ext_mutex_create(lbm_value *args, lbm_uint argn) {
  (void) args;
  (void) argn;
  return lbm_cons(ENC_SYM_NIL, ENC_SYM_NIL);
}

static lbm_value ext_mutex_lock(lbm_value *args, lbm_uint argn) {
  lbm_value res = ENC_SYM_TERROR;
  if (argn == 1 && is_mutex(args[0])) {
    lbm_cid cid = lbm_get_current_cid();
    lbm_value cid_pair = lbm_cons(lbm_enc_i(cid), ENC_SYM_NIL);
    res = cid_pair; // Return the error from cons if failed.
    if (lbm_is_cons(cid_pair)) {
      res = ENC_SYM_TRUE;
      if (is_mutex_unlocked(args[0])) {
        enqueue_cid(args[0], cid_pair);
      } else {
        enqueue_cid(args[0], cid_pair);
        lbm_block_ctx_from_extension();
      }
    }
  }
  return res;
}

static lbm_value ext_mutex_unlock(lbm_value *args, lbm_uint argn) {
  lbm_value res = ENC_SYM_TERROR;
  if (argn == 1 && is_mutex(args[0])) {
    res = ENC_SYM_EERROR; // no mutex is locked!
    if (!is_mutex_unlocked(args[0])) {
      lbm_cid cid = lbm_get_current_cid(); // this cid should be top of queue!
                                           // otherwise error
      if (dequeue_cid(args[0], lbm_enc_i(cid))) {
        lbm_value h = head_of_queue(args[0]);
        res = ENC_SYM_TRUE;
        if (!lbm_is_symbol_nil(h)) {
          lbm_cid unblock = lbm_dec_i(h);
          lbm_unblock_ctx_unboxed(unblock, ENC_SYM_TRUE);
        }
      }
    }
  }
  return res;
}


void lbm_mutex_extensions_init(void) {
  lbm_add_extension("mutex-create", ext_mutex_create);
  lbm_add_extension("mutex-lock", ext_mutex_lock);
  lbm_add_extension("mutex-unlock", ext_mutex_unlock);
}


Generated by: GCOVR (Version 4.2)

Line	Branch	Exec	Source
1			/*
2			Copyright 2025 Joel Svensson svenssonjoel@yahoo.se
3
4			This program is free software: you can redistribute it and/or modify
5			it under the terms of the GNU General Public License as published by
6			the Free Software Foundation, either version 3 of the License, or
7			(at your option) any later version.
8
9			This program is distributed in the hope that it will be useful,
10			but WITHOUT ANY WARRANTY; without even the implied warranty of
11			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12			GNU General Public License for more details.
13
14			You should have received a copy of the GNU General Public License
15			along with this program. If not, see <http://www.gnu.org/licenses/>.
16			*/
17
18			#include "extensions/mutex_extensions.h"
19
20			#include "extensions.h"
21			#include "eval_cps.h"
22
23			// This file provides a mutual exclusion feature based on the block_from_extension
24			// mechanism present in LBM.
25			//
26			// Three operations are provided:
27			// - mutex-create
28			// - mutex-lock
29			// - mutex-unlock
30			//
31			// It is strongly adviced to use these as a low-level interface and then to wrap
32			// them up in a (with-mutex-do mutex expr) that implements the locking and unlocking
33			// so that no mutex is left dangling.
34			//
35			// with-mutex-do can be implemented as
36			//
37			// (define with-mutex-do (lambda (mutex quoted-expr)
38			// (progn (mutex-lock mutex)
39			// (eval quoted-expr)
40			// (mutex-unlock mutex)
41			//
42			//
43			// The mutex object is a dotted pair (ls . last) which contains
44			// two references into a single list, implementing a O(1)-insert-last O(1)-remove-first
45			// queue. At the surface though, it is a regular lisp dotted pair that
46			// can be destroyed with standard lisp functionality, no protection!
47			// When a good replacement for "Custom types" is invented this will be improved.
48
49		56	bool is_mutex(lbm_value v) {
50			// true if it is somewhat likely that v is a mutex.
51	✓✗	112	bool res = (lbm_is_cons(v) &&
52	✓✓✓✗	56	(!lbm_is_symbol_nil(lbm_car(v)) \|\| lbm_is_symbol_nil(lbm_cdr(v)))); // car == nil -> cdr == nil
53			// potentially add a clause
54			// car == (cons a b) -> cdr == (cons c nil)
55		56	return res;
56			}
57
58		56	bool is_mutex_unlocked(lbm_value v) {
59		56	return (lbm_is_symbol_nil(lbm_car(v)));
60			}
61
62		28	void enqueue_cid(lbm_value mutex, lbm_value cid_pair) {
63	✓✗	28	if (lbm_is_symbol_nil(lbm_car(mutex))) {
64		28	lbm_set_car(mutex, cid_pair);
65		28	lbm_set_cdr(mutex, cid_pair);
66			} else {
67			lbm_value last = lbm_cdr(mutex);
68			lbm_set_cdr(last, cid_pair);
69			lbm_set_cdr(mutex, cid_pair);
70			}
71		28	}
72
73		28	bool dequeue_cid(lbm_value mutex, lbm_value cid) {
74		28	bool res = false;
75	✓✗	28	if (lbm_is_cons(lbm_car(mutex))) {
76		28	lbm_value locked_cid = lbm_car(lbm_car(mutex));
77	✓✗	28	if (locked_cid == cid) { // no decoding
78		28	res = true;
79		28	lbm_value head = lbm_car(mutex);
80		28	lbm_value last = lbm_cdr(mutex);
81	✓✗	28	if (head == last) { // one element
82		28	lbm_set_car(mutex, ENC_SYM_NIL);
83		28	lbm_set_cdr(mutex, ENC_SYM_NIL);
84			} else {
85			lbm_set_car(mutex, lbm_cdr(head));
86			}
87			}
88			}
89		28	return res;
90			}
91
92		28	lbm_value head_of_queue(lbm_value mutex) {
93		28	lbm_value res = ENC_SYM_NIL;
94	✗✓	28	if (lbm_is_cons(lbm_car(mutex))) {
95			res = lbm_car(lbm_car(mutex));
96			}
97		28	return res;
98			}
99
100		28	static lbm_value ext_mutex_create(lbm_value *args, lbm_uint argn) {
101			(void) args;
102			(void) argn;
103		28	return lbm_cons(ENC_SYM_NIL, ENC_SYM_NIL);
104			}
105
106		28	static lbm_value ext_mutex_lock(lbm_value *args, lbm_uint argn) {
107		28	lbm_value res = ENC_SYM_TERROR;
108	✓✗✓✗	28	if (argn == 1 && is_mutex(args[0])) {
109		28	lbm_cid cid = lbm_get_current_cid();
110		28	lbm_value cid_pair = lbm_cons(lbm_enc_i(cid), ENC_SYM_NIL);
111		28	res = cid_pair; // Return the error from cons if failed.
112	✓✗	28	if (lbm_is_cons(cid_pair)) {
113		28	res = ENC_SYM_TRUE;
114	✓✗	28	if (is_mutex_unlocked(args[0])) {
115		28	enqueue_cid(args[0], cid_pair);
116			} else {
117			enqueue_cid(args[0], cid_pair);
118			lbm_block_ctx_from_extension();
119			}
120			}
121			}
122		28	return res;
123			}
124
125		28	static lbm_value ext_mutex_unlock(lbm_value *args, lbm_uint argn) {
126		28	lbm_value res = ENC_SYM_TERROR;
127	✓✗✓✗	28	if (argn == 1 && is_mutex(args[0])) {
128		28	res = ENC_SYM_EERROR; // no mutex is locked!
129	✓✗	28	if (!is_mutex_unlocked(args[0])) {
130		28	lbm_cid cid = lbm_get_current_cid(); // this cid should be top of queue!
131			// otherwise error
132	✓✗	28	if (dequeue_cid(args[0], lbm_enc_i(cid))) {
133		28	lbm_value h = head_of_queue(args[0]);
134		28	res = ENC_SYM_TRUE;
135	✗✓	28	if (!lbm_is_symbol_nil(h)) {
136			lbm_cid unblock = lbm_dec_i(h);
137			lbm_unblock_ctx_unboxed(unblock, ENC_SYM_TRUE);
138			}
139			}
140			}
141			}
142		28	return res;
143			}
144
145
146		21588	void lbm_mutex_extensions_init(void) {
147		21588	lbm_add_extension("mutex-create", ext_mutex_create);
148		21588	lbm_add_extension("mutex-lock", ext_mutex_lock);
149		21588	lbm_add_extension("mutex-unlock", ext_mutex_unlock);
150		21588	}