| 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 | #ifdef LBM_OPT_MUTEX_EXTENSIONS_SIZE | ||
| 24 | #pragma GCC optimize ("-Os") | ||
| 25 | #endif | ||
| 26 | #ifdef LBM_OPT_MUTEX_EXTENSIONS_SIZE_AGGRESSIVE | ||
| 27 | #pragma GCC optimize ("-Oz") | ||
| 28 | #endif | ||
| 29 | |||
| 30 | |||
| 31 | // This file provides a mutual exclusion feature based on the block_from_extension | ||
| 32 | // mechanism present in LBM. | ||
| 33 | // | ||
| 34 | // Three operations are provided: | ||
| 35 | // - mutex-create | ||
| 36 | // - mutex-lock | ||
| 37 | // - mutex-unlock | ||
| 38 | // | ||
| 39 | // It is strongly adviced to use these as a low-level interface and then to wrap | ||
| 40 | // them up in a (with-mutex-do mutex expr) that implements the locking and unlocking | ||
| 41 | // so that no mutex is left dangling. | ||
| 42 | // | ||
| 43 | // with-mutex-do can be implemented as | ||
| 44 | // | ||
| 45 | // (define with-mutex-do (lambda (mutex quoted-expr) | ||
| 46 | // (progn (mutex-lock mutex) | ||
| 47 | // (eval quoted-expr) | ||
| 48 | // (mutex-unlock mutex) | ||
| 49 | // | ||
| 50 | // | ||
| 51 | // The mutex object is a dotted pair (ls . last) which contains | ||
| 52 | // two references into a single list, implementing a O(1)-insert-last O(1)-remove-first | ||
| 53 | // queue. At the surface though, it is a regular lisp dotted pair that | ||
| 54 | // can be destroyed with standard lisp functionality, no protection! | ||
| 55 | // When a good replacement for "Custom types" is invented this will be improved. | ||
| 56 | |||
| 57 | 598 | bool is_mutex(lbm_value v) { | |
| 58 | // true if it is somewhat likely that v is a mutex. | ||
| 59 |
2/2✓ Branch 0 taken 591 times.
✓ Branch 1 taken 7 times.
|
1189 | bool res = (lbm_is_cons(v) && |
| 60 |
4/4✓ Branch 0 taken 297 times.
✓ Branch 1 taken 294 times.
✓ Branch 2 taken 296 times.
✓ Branch 3 taken 1 times.
|
591 | (!lbm_is_symbol_nil(lbm_car(v)) || lbm_is_symbol_nil(lbm_cdr(v)))); // car == nil -> cdr == nil |
| 61 | // potentially add a clause | ||
| 62 | // car == (cons a b) -> cdr == (cons c nil) | ||
| 63 | 598 | return res; | |
| 64 | } | ||
| 65 | |||
| 66 | 589 | bool is_mutex_unlocked(lbm_value v) { | |
| 67 | 589 | return (lbm_is_symbol_nil(lbm_car(v))); | |
| 68 | } | ||
| 69 | |||
| 70 | 292 | void enqueue_cid(lbm_value mutex, lbm_value cid_pair) { | |
| 71 |
2/2✓ Branch 0 taken 291 times.
✓ Branch 1 taken 1 times.
|
292 | if (lbm_is_symbol_nil(lbm_car(mutex))) { |
| 72 | 291 | lbm_set_car(mutex, cid_pair); | |
| 73 | 291 | lbm_set_cdr(mutex, cid_pair); | |
| 74 | } else { | ||
| 75 | 1 | lbm_value last = lbm_cdr(mutex); | |
| 76 | 1 | lbm_set_cdr(last, cid_pair); | |
| 77 | 1 | lbm_set_cdr(mutex, cid_pair); | |
| 78 | } | ||
| 79 | 292 | } | |
| 80 | |||
| 81 | 293 | bool dequeue_cid(lbm_value mutex, lbm_value cid) { | |
| 82 | 293 | bool res = false; | |
| 83 |
2/2✓ Branch 0 taken 292 times.
✓ Branch 1 taken 1 times.
|
293 | if (lbm_is_cons(lbm_car(mutex))) { |
| 84 | 292 | lbm_value locked_cid = lbm_car(lbm_car(mutex)); | |
| 85 |
2/2✓ Branch 0 taken 291 times.
✓ Branch 1 taken 1 times.
|
292 | if (locked_cid == cid) { // no decoding |
| 86 | 291 | res = true; | |
| 87 | 291 | lbm_value head = lbm_car(mutex); | |
| 88 | 291 | lbm_value last = lbm_cdr(mutex); | |
| 89 |
2/2✓ Branch 0 taken 290 times.
✓ Branch 1 taken 1 times.
|
291 | if (head == last) { // one element |
| 90 | 290 | lbm_set_car(mutex, ENC_SYM_NIL); | |
| 91 | 290 | lbm_set_cdr(mutex, ENC_SYM_NIL); | |
| 92 | } else { | ||
| 93 | 1 | lbm_set_car(mutex, lbm_cdr(head)); | |
| 94 | } | ||
| 95 | } | ||
| 96 | } | ||
| 97 | 293 | return res; | |
| 98 | } | ||
| 99 | |||
| 100 | 291 | lbm_value head_of_queue(lbm_value mutex) { | |
| 101 | 291 | lbm_value res = ENC_SYM_NIL; | |
| 102 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 290 times.
|
291 | if (lbm_is_cons(lbm_car(mutex))) { |
| 103 | 1 | res = lbm_car(lbm_car(mutex)); | |
| 104 | } | ||
| 105 | 291 | return res; | |
| 106 | } | ||
| 107 | |||
| 108 | 83 | static lbm_value ext_mutex_create(lbm_value *args, lbm_uint argn) { | |
| 109 | (void) args; | ||
| 110 | (void) argn; | ||
| 111 | 83 | return lbm_cons(ENC_SYM_NIL, ENC_SYM_NIL); | |
| 112 | } | ||
| 113 | |||
| 114 | 299 | static lbm_value ext_mutex_lock(lbm_value *args, lbm_uint argn) { | |
| 115 | 299 | lbm_value res = ENC_SYM_TERROR; | |
| 116 |
4/4✓ Branch 0 taken 297 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 293 times.
✓ Branch 3 taken 4 times.
|
299 | if (argn == 1 && is_mutex(args[0])) { |
| 117 | 293 | lbm_cid cid = lbm_get_current_cid(); | |
| 118 | 293 | lbm_value cid_pair = lbm_cons(lbm_enc_i(cid), ENC_SYM_NIL); | |
| 119 | 293 | res = cid_pair; // Return the error from cons if failed. | |
| 120 |
2/2✓ Branch 0 taken 292 times.
✓ Branch 1 taken 1 times.
|
293 | if (lbm_is_cons(cid_pair)) { |
| 121 | 292 | res = ENC_SYM_TRUE; | |
| 122 |
2/2✓ Branch 0 taken 291 times.
✓ Branch 1 taken 1 times.
|
292 | if (is_mutex_unlocked(args[0])) { |
| 123 | 291 | enqueue_cid(args[0], cid_pair); | |
| 124 | } else { | ||
| 125 | 1 | enqueue_cid(args[0], cid_pair); | |
| 126 | 1 | lbm_block_ctx_from_extension(); | |
| 127 | } | ||
| 128 | } | ||
| 129 | } | ||
| 130 | 299 | return res; | |
| 131 | } | ||
| 132 | |||
| 133 | 303 | static lbm_value ext_mutex_unlock(lbm_value *args, lbm_uint argn) { | |
| 134 | 303 | lbm_value res = ENC_SYM_TERROR; | |
| 135 |
4/4✓ Branch 0 taken 301 times.
✓ Branch 1 taken 2 times.
✓ Branch 2 taken 297 times.
✓ Branch 3 taken 4 times.
|
303 | if (argn == 1 && is_mutex(args[0])) { |
| 136 | 297 | res = ENC_SYM_EERROR; // no mutex is locked! | |
| 137 |
2/2✓ Branch 0 taken 293 times.
✓ Branch 1 taken 4 times.
|
297 | if (!is_mutex_unlocked(args[0])) { |
| 138 | 293 | lbm_cid cid = lbm_get_current_cid(); // this cid should be top of queue! | |
| 139 | // otherwise error | ||
| 140 |
2/2✓ Branch 0 taken 291 times.
✓ Branch 1 taken 2 times.
|
293 | if (dequeue_cid(args[0], lbm_enc_i(cid))) { |
| 141 | 291 | lbm_value h = head_of_queue(args[0]); | |
| 142 | 291 | res = ENC_SYM_TRUE; | |
| 143 |
2/2✓ Branch 0 taken 1 times.
✓ Branch 1 taken 290 times.
|
291 | if (!lbm_is_symbol_nil(h)) { |
| 144 | 1 | lbm_cid unblock = lbm_dec_i(h); | |
| 145 | 1 | lbm_unblock_ctx_unboxed(unblock, ENC_SYM_TRUE); | |
| 146 | } | ||
| 147 | } | ||
| 148 | } | ||
| 149 | } | ||
| 150 | 303 | return res; | |
| 151 | } | ||
| 152 | |||
| 153 | |||
| 154 | 22317 | void lbm_mutex_extensions_init(void) { | |
| 155 | 22317 | lbm_add_extension("mutex-create", ext_mutex_create); | |
| 156 | 22317 | lbm_add_extension("mutex-lock", ext_mutex_lock); | |
| 157 | 22317 | lbm_add_extension("mutex-unlock", ext_mutex_unlock); | |
| 158 | 22317 | } | |
| 159 |