fix a warning
[ghc.git] / rts / STM.c
1 /* -----------------------------------------------------------------------------
2 * (c) The GHC Team 1998-2005
3 *
4 * STM implementation.
5 *
6 * Overview
7 * --------
8 *
9 * See the PPoPP 2005 paper "Composable memory transactions". In summary,
10 * each transcation has a TRec (transaction record) holding entries for each of the
11 * TVars (transactional variables) that it has accessed. Each entry records
12 * (a) the TVar, (b) the expected value seen in the TVar, (c) the new value that
13 * the transaction wants to write to the TVar, (d) during commit, the identity of
14 * the TRec that wrote the expected value.
15 *
16 * Separate TRecs are used for each level in a nest of transactions. This allows
17 * a nested transaction to be aborted without condemning its enclosing transactions.
18 * This is needed in the implementation of catchRetry. Note that the "expected value"
19 * in a nested transaction's TRec is the value expected to be *held in memory* if
20 * the transaction commits -- not the "new value" stored in one of the enclosing
21 * transactions. This means that validation can be done without searching through
22 * a nest of TRecs.
23 *
24 * Concurrency control
25 * -------------------
26 *
27 * Three different concurrency control schemes can be built according to the settings
28 * in STM.h:
29 *
30 * STM_UNIPROC assumes that the caller serialises invocations on the STM interface.
31 * In the Haskell RTS this means it is suitable only for non-THREADED_RTS builds.
32 *
33 * STM_CG_LOCK uses coarse-grained locking -- a single 'stm lock' is acquired during
34 * an invocation on the STM interface. Note that this does not mean that
35 * transactions are simply serialized -- the lock is only held *within* the
36 * implementation of stmCommitTransaction, stmWait etc.
37 *
38 * STM_FG_LOCKS uses fine-grained locking -- locking is done on a per-TVar basis
39 * and, when committing a transaction, no locks are acquired for TVars that have
40 * been read but not updated.
41 *
42 * Concurrency control is implemented in the functions:
43 *
44 * lock_stm
45 * unlock_stm
46 * lock_tvar / cond_lock_tvar
47 * unlock_tvar
48 *
49 * The choice between STM_UNIPROC / STM_CG_LOCK / STM_FG_LOCKS affects the
50 * implementation of these functions.
51 *
52 * lock_stm & unlock_stm are straightforward : they acquire a simple spin-lock
53 * using STM_CG_LOCK, and otherwise they are no-ops.
54 *
55 * lock_tvar / cond_lock_tvar and unlock_tvar are more complex because they
56 * have other effects (present in STM_UNIPROC and STM_CG_LOCK builds) as well
57 * as the actual business of maniupultaing a lock (present only in STM_FG_LOCKS
58 * builds). This is because locking a TVar is implemented by writing the lock
59 * holder's TRec into the TVar's current_value field:
60 *
61 * lock_tvar - lock a specified TVar (STM_FG_LOCKS only), returning the value
62 * it contained.
63 *
64 * cond_lock_tvar - lock a specified TVar (STM_FG_LOCKS only) if it
65 * contains a specified value. Return TRUE if this succeeds,
66 * FALSE otherwise.
67 *
68 * unlock_tvar - release the lock on a specified TVar (STM_FG_LOCKS only),
69 * storing a specified value in place of the lock entry.
70 *
71 * Using these operations, the typcial pattern of a commit/validate/wait operation
72 * is to (a) lock the STM, (b) lock all the TVars being updated, (c) check that
73 * the TVars that were only read from still contain their expected values,
74 * (d) release the locks on the TVars, writing updates to them in the case of a
75 * commit, (e) unlock the STM.
76 *
77 * Queues of waiting threads hang off the first_wait_queue_entry field of each
78 * TVar. This may only be manipulated when holding that TVar's lock. In
79 * particular, when a thread is putting itself to sleep, it mustn't release
80 * the TVar's lock until it has added itself to the wait queue and marked its
81 * TSO as BlockedOnSTM -- this makes sure that other threads will know to wake it.
82 *
83 * ---------------------------------------------------------------------------*/
84
85 #include "PosixSource.h"
86 #include "Rts.h"
87 #include "RtsFlags.h"
88 #include "RtsUtils.h"
89 #include "Schedule.h"
90 #include "SMP.h"
91 #include "STM.h"
92 #include "Storage.h"
93
94 #include <stdlib.h>
95 #include <stdio.h>
96
97 #define TRUE 1
98 #define FALSE 0
99
100 // ACQ_ASSERT is used for assertions which are only required for
101 // THREADED_RTS builds with fine-grained locking.
102
103 #if defined(STM_FG_LOCKS)
104 #define ACQ_ASSERT(_X) ASSERT(_X)
105 #define NACQ_ASSERT(_X) /*Nothing*/
106 #else
107 #define ACQ_ASSERT(_X) /*Nothing*/
108 #define NACQ_ASSERT(_X) ASSERT(_X)
109 #endif
110
111 /*......................................................................*/
112
113 // If SHAKE is defined then validation will sometime spuriously fail. They helps test
114 // unusualy code paths if genuine contention is rare
115
116 #if defined(DEBUG)
117 #define SHAKE
118 #if defined(THREADED_RTS)
119 #define TRACE(_x...) IF_DEBUG(stm, debugBelch("STM (task %p): ", (void *)(unsigned long)(unsigned int)osThreadId()); debugBelch ( _x ))
120 #else
121 #define TRACE(_x...) IF_DEBUG(stm, debugBelch ( _x ))
122 #endif
123 #else
124 #define TRACE(_x...) /*Nothing*/
125 #endif
126
127 #ifdef SHAKE
128 static const int do_shake = TRUE;
129 #else
130 static const int do_shake = FALSE;
131 #endif
132 static int shake_ctr = 0;
133 static int shake_lim = 1;
134
135 static int shake(void) {
136 if (do_shake) {
137 if (((shake_ctr++) % shake_lim) == 0) {
138 shake_ctr = 1;
139 shake_lim ++;
140 return TRUE;
141 }
142 return FALSE;
143 } else {
144 return FALSE;
145 }
146 }
147
148 /*......................................................................*/
149
150 // Helper macros for iterating over entries within a transaction
151 // record
152
153 #define FOR_EACH_ENTRY(_t,_x,CODE) do { \
154 StgTRecHeader *__t = (_t); \
155 StgTRecChunk *__c = __t -> current_chunk; \
156 StgWord __limit = __c -> next_entry_idx; \
157 TRACE("%p : FOR_EACH_ENTRY, current_chunk=%p limit=%ld\n", __t, __c, __limit); \
158 while (__c != END_STM_CHUNK_LIST) { \
159 StgWord __i; \
160 for (__i = 0; __i < __limit; __i ++) { \
161 TRecEntry *_x = &(__c -> entries[__i]); \
162 do { CODE } while (0); \
163 } \
164 __c = __c -> prev_chunk; \
165 __limit = TREC_CHUNK_NUM_ENTRIES; \
166 } \
167 exit_for_each: \
168 if (FALSE) goto exit_for_each; \
169 } while (0)
170
171 #define BREAK_FOR_EACH goto exit_for_each
172
173 /*......................................................................*/
174
175 // if REUSE_MEMORY is defined then attempt to re-use descriptors, log chunks,
176 // and wait queue entries without GC
177
178 #define REUSE_MEMORY
179
180 /*......................................................................*/
181
182 #define IF_STM_UNIPROC(__X) do { } while (0)
183 #define IF_STM_CG_LOCK(__X) do { } while (0)
184 #define IF_STM_FG_LOCKS(__X) do { } while (0)
185
186 #if defined(STM_UNIPROC)
187 #undef IF_STM_UNIPROC
188 #define IF_STM_UNIPROC(__X) do { __X } while (0)
189 static const StgBool use_read_phase = FALSE;
190
191 static void lock_stm(StgTRecHeader *trec STG_UNUSED) {
192 TRACE("%p : lock_stm()\n", trec);
193 }
194
195 static void unlock_stm(StgTRecHeader *trec STG_UNUSED) {
196 TRACE("%p : unlock_stm()\n", trec);
197 }
198
199 static StgClosure *lock_tvar(StgTRecHeader *trec STG_UNUSED,
200 StgTVar *s STG_UNUSED) {
201 StgClosure *result;
202 TRACE("%p : lock_tvar(%p)\n", trec, s);
203 result = s -> current_value;
204 return result;
205 }
206
207 static void unlock_tvar(StgTRecHeader *trec STG_UNUSED,
208 StgTVar *s STG_UNUSED,
209 StgClosure *c,
210 StgBool force_update) {
211 TRACE("%p : unlock_tvar(%p)\n", trec, s);
212 if (force_update) {
213 s -> current_value = c;
214 }
215 }
216
217 static StgBool cond_lock_tvar(StgTRecHeader *trec STG_UNUSED,
218 StgTVar *s STG_UNUSED,
219 StgClosure *expected) {
220 StgClosure *result;
221 TRACE("%p : cond_lock_tvar(%p, %p)\n", trec, s, expected);
222 result = s -> current_value;
223 TRACE("%p : %s\n", trec, (result == expected) ? "success" : "failure");
224 return (result == expected);
225 }
226 #endif
227
228 #if defined(STM_CG_LOCK) /*........................................*/
229
230 #undef IF_STM_CG_LOCK
231 #define IF_STM_CG_LOCK(__X) do { __X } while (0)
232 static const StgBool use_read_phase = FALSE;
233 static volatile StgTRecHeader *smp_locked = NULL;
234
235 static void lock_stm(StgTRecHeader *trec) {
236 while (cas(&smp_locked, NULL, trec) != NULL) { }
237 TRACE("%p : lock_stm()\n", trec);
238 }
239
240 static void unlock_stm(StgTRecHeader *trec STG_UNUSED) {
241 TRACE("%p : unlock_stm()\n", trec);
242 ASSERT (smp_locked == trec);
243 smp_locked = 0;
244 }
245
246 static StgClosure *lock_tvar(StgTRecHeader *trec STG_UNUSED,
247 StgTVar *s STG_UNUSED) {
248 StgClosure *result;
249 TRACE("%p : lock_tvar(%p)\n", trec, s);
250 ASSERT (smp_locked == trec);
251 result = s -> current_value;
252 return result;
253 }
254
255 static void *unlock_tvar(StgTRecHeader *trec STG_UNUSED,
256 StgTVar *s STG_UNUSED,
257 StgClosure *c,
258 StgBool force_update) {
259 TRACE("%p : unlock_tvar(%p, %p)\n", trec, s, c);
260 ASSERT (smp_locked == trec);
261 if (force_update) {
262 s -> current_value = c;
263 }
264 }
265
266 static StgBool cond_lock_tvar(StgTRecHeader *trec STG_UNUSED,
267 StgTVar *s STG_UNUSED,
268 StgClosure *expected) {
269 StgClosure *result;
270 TRACE("%p : cond_lock_tvar(%p, %p)\n", trec, s, expected);
271 ASSERT (smp_locked == trec);
272 result = s -> current_value;
273 TRACE("%p : %d\n", result ? "success" : "failure");
274 return (result == expected);
275 }
276 #endif
277
278 #if defined(STM_FG_LOCKS) /*...................................*/
279
280 #undef IF_STM_FG_LOCKS
281 #define IF_STM_FG_LOCKS(__X) do { __X } while (0)
282 static const StgBool use_read_phase = TRUE;
283
284 static void lock_stm(StgTRecHeader *trec STG_UNUSED) {
285 TRACE("%p : lock_stm()\n", trec);
286 }
287
288 static void unlock_stm(StgTRecHeader *trec STG_UNUSED) {
289 TRACE("%p : unlock_stm()\n", trec);
290 }
291
292 static StgClosure *lock_tvar(StgTRecHeader *trec,
293 StgTVar *s STG_UNUSED) {
294 StgClosure *result;
295 TRACE("%p : lock_tvar(%p)\n", trec, s);
296 do {
297 do {
298 result = s -> current_value;
299 } while (GET_INFO(result) == &stg_TREC_HEADER_info);
300 } while (cas((void *)&(s -> current_value),
301 (StgWord)result, (StgWord)trec) != (StgWord)result);
302 return result;
303 }
304
305 static void unlock_tvar(StgTRecHeader *trec STG_UNUSED,
306 StgTVar *s,
307 StgClosure *c,
308 StgBool force_update STG_UNUSED) {
309 TRACE("%p : unlock_tvar(%p, %p)\n", trec, s, c);
310 ASSERT(s -> current_value == trec);
311 s -> current_value = c;
312 }
313
314 static StgBool cond_lock_tvar(StgTRecHeader *trec,
315 StgTVar *s,
316 StgClosure *expected) {
317 StgClosure *result;
318 StgWord w;
319 TRACE("%p : cond_lock_tvar(%p, %p)\n", trec, s, expected);
320 w = cas((void *)&(s -> current_value), (StgWord)expected, (StgWord)trec);
321 result = (StgClosure *)w;
322 TRACE("%p : %s\n", trec, result ? "success" : "failure");
323 return (result == expected);
324 }
325 #endif
326
327 /*......................................................................*/
328
329 // Helper functions for thread blocking and unblocking
330
331 static void park_tso(StgTSO *tso) {
332 ASSERT(tso -> why_blocked == NotBlocked);
333 tso -> why_blocked = BlockedOnSTM;
334 tso -> block_info.closure = (StgClosure *) END_TSO_QUEUE;
335 TRACE("park_tso on tso=%p\n", tso);
336 }
337
338 static void unpark_tso(Capability *cap, StgTSO *tso) {
339 // We will continue unparking threads while they remain on one of the wait
340 // queues: it's up to the thread itself to remove it from the wait queues
341 // if it decides to do so when it is scheduled.
342 if (tso -> why_blocked == BlockedOnSTM) {
343 TRACE("unpark_tso on tso=%p\n", tso);
344 unblockOne(cap,tso);
345 } else {
346 TRACE("spurious unpark_tso on tso=%p\n", tso);
347 }
348 }
349
350 static void unpark_waiters_on(Capability *cap, StgTVar *s) {
351 StgTVarWaitQueue *q;
352 TRACE("unpark_waiters_on tvar=%p\n", s);
353 for (q = s -> first_wait_queue_entry;
354 q != END_STM_WAIT_QUEUE;
355 q = q -> next_queue_entry) {
356 unpark_tso(cap, q -> waiting_tso);
357 }
358 }
359
360 /*......................................................................*/
361
362 // Helper functions for downstream allocation and initialization
363
364 static StgTVarWaitQueue *new_stg_tvar_wait_queue(Capability *cap,
365 StgTSO *waiting_tso) {
366 StgTVarWaitQueue *result;
367 result = (StgTVarWaitQueue *)allocateLocal(cap, sizeofW(StgTVarWaitQueue));
368 SET_HDR (result, &stg_TVAR_WAIT_QUEUE_info, CCS_SYSTEM);
369 result -> waiting_tso = waiting_tso;
370 return result;
371 }
372
373 static StgTRecChunk *new_stg_trec_chunk(Capability *cap) {
374 StgTRecChunk *result;
375 result = (StgTRecChunk *)allocateLocal(cap, sizeofW(StgTRecChunk));
376 SET_HDR (result, &stg_TREC_CHUNK_info, CCS_SYSTEM);
377 result -> prev_chunk = END_STM_CHUNK_LIST;
378 result -> next_entry_idx = 0;
379 return result;
380 }
381
382 static StgTRecHeader *new_stg_trec_header(Capability *cap,
383 StgTRecHeader *enclosing_trec) {
384 StgTRecHeader *result;
385 result = (StgTRecHeader *) allocateLocal(cap, sizeofW(StgTRecHeader));
386 SET_HDR (result, &stg_TREC_HEADER_info, CCS_SYSTEM);
387
388 result -> enclosing_trec = enclosing_trec;
389 result -> current_chunk = new_stg_trec_chunk(cap);
390
391 if (enclosing_trec == NO_TREC) {
392 result -> state = TREC_ACTIVE;
393 } else {
394 ASSERT(enclosing_trec -> state == TREC_ACTIVE ||
395 enclosing_trec -> state == TREC_CONDEMNED);
396 result -> state = enclosing_trec -> state;
397 }
398
399 return result;
400 }
401
402 /*......................................................................*/
403
404 // Allocation / deallocation functions that retain per-capability lists
405 // of closures that can be re-used
406
407 static StgTVarWaitQueue *alloc_stg_tvar_wait_queue(Capability *cap,
408 StgTSO *waiting_tso) {
409 StgTVarWaitQueue *result = NULL;
410 if (cap -> free_tvar_wait_queues == END_STM_WAIT_QUEUE) {
411 result = new_stg_tvar_wait_queue(cap, waiting_tso);
412 } else {
413 result = cap -> free_tvar_wait_queues;
414 result -> waiting_tso = waiting_tso;
415 cap -> free_tvar_wait_queues = result -> next_queue_entry;
416 }
417 return result;
418 }
419
420 static void free_stg_tvar_wait_queue(Capability *cap,
421 StgTVarWaitQueue *wq) {
422 #if defined(REUSE_MEMORY)
423 wq -> next_queue_entry = cap -> free_tvar_wait_queues;
424 cap -> free_tvar_wait_queues = wq;
425 #endif
426 }
427
428 static StgTRecChunk *alloc_stg_trec_chunk(Capability *cap) {
429 StgTRecChunk *result = NULL;
430 if (cap -> free_trec_chunks == END_STM_CHUNK_LIST) {
431 result = new_stg_trec_chunk(cap);
432 } else {
433 result = cap -> free_trec_chunks;
434 cap -> free_trec_chunks = result -> prev_chunk;
435 result -> prev_chunk = END_STM_CHUNK_LIST;
436 result -> next_entry_idx = 0;
437 }
438 return result;
439 }
440
441 static void free_stg_trec_chunk(Capability *cap,
442 StgTRecChunk *c) {
443 #if defined(REUSE_MEMORY)
444 c -> prev_chunk = cap -> free_trec_chunks;
445 cap -> free_trec_chunks = c;
446 #endif
447 }
448
449 static StgTRecHeader *alloc_stg_trec_header(Capability *cap,
450 StgTRecHeader *enclosing_trec) {
451 StgTRecHeader *result = NULL;
452 if (cap -> free_trec_headers == NO_TREC) {
453 result = new_stg_trec_header(cap, enclosing_trec);
454 } else {
455 result = cap -> free_trec_headers;
456 cap -> free_trec_headers = result -> enclosing_trec;
457 result -> enclosing_trec = enclosing_trec;
458 result -> current_chunk -> next_entry_idx = 0;
459 if (enclosing_trec == NO_TREC) {
460 result -> state = TREC_ACTIVE;
461 } else {
462 ASSERT(enclosing_trec -> state == TREC_ACTIVE ||
463 enclosing_trec -> state == TREC_CONDEMNED);
464 result -> state = enclosing_trec -> state;
465 }
466 }
467 return result;
468 }
469
470 static void free_stg_trec_header(Capability *cap,
471 StgTRecHeader *trec) {
472 #if defined(REUSE_MEMORY)
473 StgTRecChunk *chunk = trec -> current_chunk -> prev_chunk;
474 while (chunk != END_STM_CHUNK_LIST) {
475 StgTRecChunk *prev_chunk = chunk -> prev_chunk;
476 free_stg_trec_chunk(cap, chunk);
477 chunk = prev_chunk;
478 }
479 trec -> current_chunk -> prev_chunk = END_STM_CHUNK_LIST;
480 trec -> enclosing_trec = cap -> free_trec_headers;
481 cap -> free_trec_headers = trec;
482 #endif
483 }
484
485 /*......................................................................*/
486
487 // Helper functions for managing waiting lists
488
489 static void build_wait_queue_entries_for_trec(Capability *cap,
490 StgTSO *tso,
491 StgTRecHeader *trec) {
492 ASSERT(trec != NO_TREC);
493 ASSERT(trec -> enclosing_trec == NO_TREC);
494 ASSERT(trec -> state == TREC_ACTIVE);
495
496 TRACE("%p : build_wait_queue_entries_for_trec()\n", trec);
497
498 FOR_EACH_ENTRY(trec, e, {
499 StgTVar *s;
500 StgTVarWaitQueue *q;
501 StgTVarWaitQueue *fq;
502 s = e -> tvar;
503 TRACE("%p : adding tso=%p to wait queue for tvar=%p\n", trec, tso, s);
504 ACQ_ASSERT(s -> current_value == trec);
505 NACQ_ASSERT(s -> current_value == e -> expected_value);
506 fq = s -> first_wait_queue_entry;
507 q = alloc_stg_tvar_wait_queue(cap, tso);
508 q -> next_queue_entry = fq;
509 q -> prev_queue_entry = END_STM_WAIT_QUEUE;
510 if (fq != END_STM_WAIT_QUEUE) {
511 fq -> prev_queue_entry = q;
512 }
513 s -> first_wait_queue_entry = q;
514 e -> new_value = (StgClosure *) q;
515 });
516 }
517
518 static void remove_wait_queue_entries_for_trec(Capability *cap,
519 StgTRecHeader *trec) {
520 ASSERT(trec != NO_TREC);
521 ASSERT(trec -> enclosing_trec == NO_TREC);
522 ASSERT(trec -> state == TREC_WAITING ||
523 trec -> state == TREC_CONDEMNED);
524
525 TRACE("%p : remove_wait_queue_entries_for_trec()\n", trec);
526
527 FOR_EACH_ENTRY(trec, e, {
528 StgTVar *s;
529 StgTVarWaitQueue *pq;
530 StgTVarWaitQueue *nq;
531 StgTVarWaitQueue *q;
532 s = e -> tvar;
533 StgClosure *saw = lock_tvar(trec, s);
534 q = (StgTVarWaitQueue *) (e -> new_value);
535 TRACE("%p : removing tso=%p from wait queue for tvar=%p\n", trec, q -> waiting_tso, s);
536 ACQ_ASSERT(s -> current_value == trec);
537 nq = q -> next_queue_entry;
538 pq = q -> prev_queue_entry;
539 if (nq != END_STM_WAIT_QUEUE) {
540 nq -> prev_queue_entry = pq;
541 }
542 if (pq != END_STM_WAIT_QUEUE) {
543 pq -> next_queue_entry = nq;
544 } else {
545 ASSERT (s -> first_wait_queue_entry == q);
546 s -> first_wait_queue_entry = nq;
547 }
548 free_stg_tvar_wait_queue(cap, q);
549 unlock_tvar(trec, s, saw, FALSE);
550 });
551 }
552
553 /*......................................................................*/
554
555 static TRecEntry *get_new_entry(Capability *cap,
556 StgTRecHeader *t) {
557 TRecEntry *result;
558 StgTRecChunk *c;
559 int i;
560
561 c = t -> current_chunk;
562 i = c -> next_entry_idx;
563 ASSERT(c != END_STM_CHUNK_LIST);
564
565 if (i < TREC_CHUNK_NUM_ENTRIES) {
566 // Continue to use current chunk
567 result = &(c -> entries[i]);
568 c -> next_entry_idx ++;
569 } else {
570 // Current chunk is full: allocate a fresh one
571 StgTRecChunk *nc;
572 nc = alloc_stg_trec_chunk(cap);
573 nc -> prev_chunk = c;
574 nc -> next_entry_idx = 1;
575 t -> current_chunk = nc;
576 result = &(nc -> entries[0]);
577 }
578
579 return result;
580 }
581
582 /*......................................................................*/
583
584 static void merge_update_into(Capability *cap,
585 StgTRecHeader *t,
586 StgTVar *tvar,
587 StgClosure *expected_value,
588 StgClosure *new_value) {
589 int found;
590
591 // Look for an entry in this trec
592 found = FALSE;
593 FOR_EACH_ENTRY(t, e, {
594 StgTVar *s;
595 s = e -> tvar;
596 if (s == tvar) {
597 found = TRUE;
598 if (e -> expected_value != expected_value) {
599 // Must abort if the two entries start from different values
600 TRACE("%p : entries inconsistent at %p (%p vs %p)\n",
601 t, tvar, e -> expected_value, expected_value);
602 t -> state = TREC_CONDEMNED;
603 }
604 e -> new_value = new_value;
605 BREAK_FOR_EACH;
606 }
607 });
608
609 if (!found) {
610 // No entry so far in this trec
611 TRecEntry *ne;
612 ne = get_new_entry(cap, t);
613 ne -> tvar = tvar;
614 ne -> expected_value = expected_value;
615 ne -> new_value = new_value;
616 }
617 }
618
619 /*......................................................................*/
620
621 static StgBool entry_is_update(TRecEntry *e) {
622 StgBool result;
623 result = (e -> expected_value != e -> new_value);
624 return result;
625 }
626
627 #if defined(STM_FG_LOCKS)
628 static StgBool entry_is_read_only(TRecEntry *e) {
629 StgBool result;
630 result = (e -> expected_value == e -> new_value);
631 return result;
632 }
633
634 static StgBool tvar_is_locked(StgTVar *s, StgTRecHeader *h) {
635 StgClosure *c;
636 StgBool result;
637 c = s -> current_value;
638 result = (c == (StgClosure *) h);
639 return result;
640 }
641 #endif
642
643 // revert_ownership : release a lock on a TVar, storing back
644 // the value that it held when the lock was acquired. "revert_all"
645 // is set in stmWait and stmReWait when we acquired locks on all of
646 // the TVars involved. "revert_all" is not set in commit operations
647 // where we don't lock TVars that have been read from but not updated.
648
649 static void revert_ownership(StgTRecHeader *trec STG_UNUSED,
650 StgBool revert_all STG_UNUSED) {
651 #if defined(STM_FG_LOCKS)
652 FOR_EACH_ENTRY(trec, e, {
653 if (revert_all || entry_is_update(e)) {
654 StgTVar *s;
655 s = e -> tvar;
656 if (tvar_is_locked(s, trec)) {
657 unlock_tvar(trec, s, e -> expected_value, TRUE);
658 }
659 }
660 });
661 #endif
662 }
663
664 /*......................................................................*/
665
666 // validate_and_acquire_ownership : this performs the twin functions
667 // of checking that the TVars referred to by entries in trec hold the
668 // expected values and:
669 //
670 // - locking the TVar (on updated TVars during commit, or all TVars
671 // during wait)
672 //
673 // - recording the identity of the TRec who wrote the value seen in the
674 // TVar (on non-updated TVars during commit). These values are
675 // stashed in the TRec entries and are then checked in check_read_only
676 // to ensure that an atomic snapshot of all of these locations has been
677 // seen.
678
679 static StgBool validate_and_acquire_ownership (StgTRecHeader *trec,
680 int acquire_all,
681 int retain_ownership) {
682 StgBool result;
683
684 if (shake()) {
685 TRACE("%p : shake, pretending trec is invalid when it may not be\n", trec);
686 return FALSE;
687 }
688
689 ASSERT ((trec -> state == TREC_ACTIVE) ||
690 (trec -> state == TREC_WAITING) ||
691 (trec -> state == TREC_CONDEMNED));
692 result = !((trec -> state) == TREC_CONDEMNED);
693 if (result) {
694 FOR_EACH_ENTRY(trec, e, {
695 StgTVar *s;
696 s = e -> tvar;
697 if (acquire_all || entry_is_update(e)) {
698 TRACE("%p : trying to acquire %p\n", trec, s);
699 if (!cond_lock_tvar(trec, s, e -> expected_value)) {
700 TRACE("%p : failed to acquire %p\n", trec, s);
701 result = FALSE;
702 BREAK_FOR_EACH;
703 }
704 } else {
705 ASSERT(use_read_phase);
706 IF_STM_FG_LOCKS({
707 TRACE("%p : will need to check %p\n", trec, s);
708 if (s -> current_value != e -> expected_value) {
709 TRACE("%p : doesn't match\n", trec);
710 result = FALSE;
711 BREAK_FOR_EACH;
712 }
713 e -> num_updates = s -> num_updates;
714 if (s -> current_value != e -> expected_value) {
715 TRACE("%p : doesn't match (race)\n", trec);
716 result = FALSE;
717 BREAK_FOR_EACH;
718 } else {
719 TRACE("%p : need to check version %d\n", trec, e -> num_updates);
720 }
721 });
722 }
723 });
724 }
725
726 if ((!result) || (!retain_ownership)) {
727 revert_ownership(trec, acquire_all);
728 }
729
730 return result;
731 }
732
733 // check_read_only : check that we've seen an atomic snapshot of the
734 // non-updated TVars accessed by a trec. This checks that the last TRec to
735 // commit an update to the TVar is unchanged since the value was stashed in
736 // validate_and_acquire_ownership. If no udpate is seen to any TVar than
737 // all of them contained their expected values at the start of the call to
738 // check_read_only.
739 //
740 // The paper "Concurrent programming without locks" (under submission), or
741 // Keir Fraser's PhD dissertation "Practical lock-free programming" discuss
742 // this kind of algorithm.
743
744 static StgBool check_read_only(StgTRecHeader *trec STG_UNUSED) {
745 StgBool result = TRUE;
746
747 ASSERT (use_read_phase);
748 IF_STM_FG_LOCKS({
749 FOR_EACH_ENTRY(trec, e, {
750 StgTVar *s;
751 s = e -> tvar;
752 if (entry_is_read_only(e)) {
753 TRACE("%p : check_read_only for TVar %p, saw %d\n", trec, s, e -> num_updates);
754 if (s -> num_updates != e -> num_updates) {
755 // ||s -> current_value != e -> expected_value) {
756 TRACE("%p : mismatch\n", trec);
757 result = FALSE;
758 BREAK_FOR_EACH;
759 }
760 }
761 });
762 });
763
764 return result;
765 }
766
767
768 /************************************************************************/
769
770 void stmPreGCHook() {
771 nat i;
772
773 lock_stm(NO_TREC);
774 TRACE("stmPreGCHook\n");
775 for (i = 0; i < n_capabilities; i ++) {
776 Capability *cap = &capabilities[i];
777 cap -> free_tvar_wait_queues = END_STM_WAIT_QUEUE;
778 cap -> free_trec_chunks = END_STM_CHUNK_LIST;
779 cap -> free_trec_headers = NO_TREC;
780 }
781 unlock_stm(NO_TREC);
782 }
783
784 /************************************************************************/
785
786 // check_read_only relies on version numbers held in TVars' "num_updates"
787 // fields not wrapping around while a transaction is committed. The version
788 // number is incremented each time an update is committed to the TVar
789 // This is unlikely to wrap around when 32-bit integers are used for the counts,
790 // but to ensure correctness we maintain a shared count on the maximum
791 // number of commit operations that may occur and check that this has
792 // not increased by more than 2^32 during a commit.
793
794 #define TOKEN_BATCH_SIZE 1024
795
796 static volatile StgInt64 max_commits = 0;
797
798 #if defined(THREADED_RTS)
799 static volatile StgBool token_locked = FALSE;
800
801 static void getTokenBatch(Capability *cap) {
802 while (cas((void *)&token_locked, FALSE, TRUE) == TRUE) { /* nothing */ }
803 max_commits += TOKEN_BATCH_SIZE;
804 cap -> transaction_tokens = TOKEN_BATCH_SIZE;
805 token_locked = FALSE;
806 }
807
808 static void getToken(Capability *cap) {
809 if (cap -> transaction_tokens == 0) {
810 getTokenBatch(cap);
811 }
812 cap -> transaction_tokens --;
813 }
814 #else
815 static void getToken(Capability *cap STG_UNUSED) {
816 // Nothing
817 }
818 #endif
819
820 /*......................................................................*/
821
822 StgTRecHeader *stmStartTransaction(Capability *cap,
823 StgTRecHeader *outer) {
824 StgTRecHeader *t;
825 TRACE("%p : stmStartTransaction with %d tokens\n",
826 outer,
827 cap -> transaction_tokens);
828
829 getToken(cap);
830
831 t = alloc_stg_trec_header(cap, outer);
832 TRACE("%p : stmStartTransaction()=%p\n", outer, t);
833 return t;
834 }
835
836 /*......................................................................*/
837
838 void stmAbortTransaction(Capability *cap,
839 StgTRecHeader *trec) {
840 TRACE("%p : stmAbortTransaction\n", trec);
841 ASSERT (trec != NO_TREC);
842 ASSERT ((trec -> state == TREC_ACTIVE) ||
843 (trec -> state == TREC_WAITING) ||
844 (trec -> state == TREC_CONDEMNED));
845
846 lock_stm(trec);
847 if (trec -> state == TREC_WAITING) {
848 ASSERT (trec -> enclosing_trec == NO_TREC);
849 TRACE("%p : stmAbortTransaction aborting waiting transaction\n", trec);
850 remove_wait_queue_entries_for_trec(cap, trec);
851 }
852 trec -> state = TREC_ABORTED;
853 unlock_stm(trec);
854
855 free_stg_trec_header(cap, trec);
856
857 TRACE("%p : stmAbortTransaction done\n", trec);
858 }
859
860 /*......................................................................*/
861
862 void stmCondemnTransaction(Capability *cap,
863 StgTRecHeader *trec) {
864 TRACE("%p : stmCondemnTransaction\n", trec);
865 ASSERT (trec != NO_TREC);
866 ASSERT ((trec -> state == TREC_ACTIVE) ||
867 (trec -> state == TREC_WAITING) ||
868 (trec -> state == TREC_CONDEMNED));
869
870 lock_stm(trec);
871 if (trec -> state == TREC_WAITING) {
872 ASSERT (trec -> enclosing_trec == NO_TREC);
873 TRACE("%p : stmCondemnTransaction condemning waiting transaction\n", trec);
874 remove_wait_queue_entries_for_trec(cap, trec);
875 }
876 trec -> state = TREC_CONDEMNED;
877 unlock_stm(trec);
878
879 TRACE("%p : stmCondemnTransaction done\n", trec);
880 }
881
882 /*......................................................................*/
883
884 StgTRecHeader *stmGetEnclosingTRec(StgTRecHeader *trec) {
885 StgTRecHeader *outer;
886 TRACE("%p : stmGetEnclosingTRec\n", trec);
887 outer = trec -> enclosing_trec;
888 TRACE("%p : stmGetEnclosingTRec()=%p\n", trec, outer);
889 return outer;
890 }
891
892 /*......................................................................*/
893
894 StgBool stmValidateNestOfTransactions(StgTRecHeader *trec) {
895 StgTRecHeader *t;
896 StgBool result;
897
898 TRACE("%p : stmValidateNestOfTransactions\n", trec);
899 ASSERT(trec != NO_TREC);
900 ASSERT((trec -> state == TREC_ACTIVE) ||
901 (trec -> state == TREC_WAITING) ||
902 (trec -> state == TREC_CONDEMNED));
903
904 lock_stm(trec);
905
906 t = trec;
907 result = TRUE;
908 while (t != NO_TREC) {
909 result &= validate_and_acquire_ownership(t, TRUE, FALSE);
910 t = t -> enclosing_trec;
911 }
912
913 if (!result && trec -> state != TREC_WAITING) {
914 trec -> state = TREC_CONDEMNED;
915 }
916
917 unlock_stm(trec);
918
919 TRACE("%p : stmValidateNestOfTransactions()=%d\n", trec, result);
920 return result;
921 }
922
923 /*......................................................................*/
924
925 StgBool stmCommitTransaction(Capability *cap, StgTRecHeader *trec) {
926 int result;
927 StgInt64 max_commits_at_start = max_commits;
928
929 TRACE("%p : stmCommitTransaction()\n", trec);
930 ASSERT (trec != NO_TREC);
931
932 lock_stm(trec);
933
934 ASSERT (trec -> enclosing_trec == NO_TREC);
935 ASSERT ((trec -> state == TREC_ACTIVE) ||
936 (trec -> state == TREC_CONDEMNED));
937
938 result = validate_and_acquire_ownership(trec, (!use_read_phase), TRUE);
939 if (result) {
940 // We now know that all the updated locations hold their expected values.
941 ASSERT (trec -> state == TREC_ACTIVE);
942
943 if (use_read_phase) {
944 TRACE("%p : doing read check\n", trec);
945 result = check_read_only(trec);
946 TRACE("%p : read-check %s\n", trec, result ? "succeeded" : "failed");
947
948 StgInt64 max_commits_at_end = max_commits;
949 StgInt64 max_concurrent_commits;
950 max_concurrent_commits = ((max_commits_at_end - max_commits_at_start) +
951 (n_capabilities * TOKEN_BATCH_SIZE));
952 if (((max_concurrent_commits >> 32) > 0) || shake()) {
953 result = FALSE;
954 }
955 }
956
957 if (result) {
958 // We now know that all of the read-only locations held their exepcted values
959 // at the end of the call to validate_and_acquire_ownership. This forms the
960 // linearization point of the commit.
961
962 FOR_EACH_ENTRY(trec, e, {
963 StgTVar *s;
964 s = e -> tvar;
965 if (e -> new_value != e -> expected_value) {
966 // Entry is an update: write the value back to the TVar, unlocking it if
967 // necessary.
968
969 ACQ_ASSERT(tvar_is_locked(s, trec));
970 TRACE("%p : writing %p to %p, waking waiters\n", trec, e -> new_value, s);
971 unpark_waiters_on(cap,s);
972 IF_STM_FG_LOCKS({
973 s -> num_updates ++;
974 });
975 unlock_tvar(trec, s, e -> new_value, TRUE);
976 }
977 ACQ_ASSERT(!tvar_is_locked(s, trec));
978 });
979 } else {
980 revert_ownership(trec, FALSE);
981 }
982 }
983
984 unlock_stm(trec);
985
986 free_stg_trec_header(cap, trec);
987
988 TRACE("%p : stmCommitTransaction()=%d\n", trec, result);
989
990 return result;
991 }
992
993 /*......................................................................*/
994
995 StgBool stmCommitNestedTransaction(Capability *cap, StgTRecHeader *trec) {
996 StgTRecHeader *et;
997 int result;
998 ASSERT (trec != NO_TREC && trec -> enclosing_trec != NO_TREC);
999 TRACE("%p : stmCommitNestedTransaction() into %p\n", trec, trec -> enclosing_trec);
1000 ASSERT ((trec -> state == TREC_ACTIVE) || (trec -> state == TREC_CONDEMNED));
1001
1002 lock_stm(trec);
1003
1004 et = trec -> enclosing_trec;
1005 result = validate_and_acquire_ownership(trec, (!use_read_phase), TRUE);
1006 if (result) {
1007 // We now know that all the updated locations hold their expected values.
1008
1009 if (use_read_phase) {
1010 TRACE("%p : doing read check\n", trec);
1011 result = check_read_only(trec);
1012 }
1013 if (result) {
1014 // We now know that all of the read-only locations held their exepcted values
1015 // at the end of the call to validate_and_acquire_ownership. This forms the
1016 // linearization point of the commit.
1017
1018 if (result) {
1019 TRACE("%p : read-check succeeded\n", trec);
1020 FOR_EACH_ENTRY(trec, e, {
1021 // Merge each entry into the enclosing transaction record, release all
1022 // locks.
1023
1024 StgTVar *s;
1025 s = e -> tvar;
1026 if (entry_is_update(e)) {
1027 unlock_tvar(trec, s, e -> expected_value, FALSE);
1028 }
1029 merge_update_into(cap, et, s, e -> expected_value, e -> new_value);
1030 ACQ_ASSERT(s -> current_value != trec);
1031 });
1032 } else {
1033 revert_ownership(trec, FALSE);
1034 }
1035 }
1036 }
1037
1038 unlock_stm(trec);
1039
1040 free_stg_trec_header(cap, trec);
1041
1042 TRACE("%p : stmCommitNestedTransaction()=%d\n", trec, result);
1043
1044 return result;
1045 }
1046
1047 /*......................................................................*/
1048
1049 StgBool stmWait(Capability *cap, StgTSO *tso, StgTRecHeader *trec) {
1050 int result;
1051 TRACE("%p : stmWait(%p)\n", trec, tso);
1052 ASSERT (trec != NO_TREC);
1053 ASSERT (trec -> enclosing_trec == NO_TREC);
1054 ASSERT ((trec -> state == TREC_ACTIVE) ||
1055 (trec -> state == TREC_CONDEMNED));
1056
1057 lock_stm(trec);
1058 result = validate_and_acquire_ownership(trec, TRUE, TRUE);
1059 if (result) {
1060 // The transaction is valid so far so we can actually start waiting.
1061 // (Otherwise the transaction was not valid and the thread will have to
1062 // retry it).
1063
1064 // Put ourselves to sleep. We retain locks on all the TVars involved
1065 // until we are sound asleep : (a) on the wait queues, (b) BlockedOnSTM
1066 // in the TSO, (c) TREC_WAITING in the Trec.
1067 build_wait_queue_entries_for_trec(cap, tso, trec);
1068 park_tso(tso);
1069 trec -> state = TREC_WAITING;
1070
1071 // We haven't released ownership of the transaction yet. The TSO
1072 // has been put on the wait queue for the TVars it is waiting for,
1073 // but we haven't yet tidied up the TSO's stack and made it safe
1074 // to wake up the TSO. Therefore, we must wait until the TSO is
1075 // safe to wake up before we release ownership - when all is well,
1076 // the runtime will call stmWaitUnlock() below, with the same
1077 // TRec.
1078
1079 } else {
1080 unlock_stm(trec);
1081 free_stg_trec_header(cap, trec);
1082 }
1083
1084 TRACE("%p : stmWait(%p)=%d\n", trec, tso, result);
1085 return result;
1086 }
1087
1088
1089 void
1090 stmWaitUnlock(Capability *cap STG_UNUSED, StgTRecHeader *trec) {
1091 revert_ownership(trec, TRUE);
1092 unlock_stm(trec);
1093 }
1094
1095 /*......................................................................*/
1096
1097 StgBool stmReWait(Capability *cap, StgTSO *tso) {
1098 int result;
1099 StgTRecHeader *trec = tso->trec;
1100
1101 TRACE("%p : stmReWait\n", trec);
1102 ASSERT (trec != NO_TREC);
1103 ASSERT (trec -> enclosing_trec == NO_TREC);
1104 ASSERT ((trec -> state == TREC_WAITING) ||
1105 (trec -> state == TREC_CONDEMNED));
1106
1107 lock_stm(trec);
1108 result = validate_and_acquire_ownership(trec, TRUE, TRUE);
1109 TRACE("%p : validation %s\n", trec, result ? "succeeded" : "failed");
1110 if (result) {
1111 // The transaction remains valid -- do nothing because it is already on
1112 // the wait queues
1113 ASSERT (trec -> state == TREC_WAITING);
1114 park_tso(tso);
1115 revert_ownership(trec, TRUE);
1116 } else {
1117 // The transcation has become invalid. We can now remove it from the wait
1118 // queues.
1119 if (trec -> state != TREC_CONDEMNED) {
1120 remove_wait_queue_entries_for_trec (cap, trec);
1121 }
1122 free_stg_trec_header(cap, trec);
1123 }
1124 unlock_stm(trec);
1125
1126 TRACE("%p : stmReWait()=%d\n", trec, result);
1127 return result;
1128 }
1129
1130 /*......................................................................*/
1131
1132 static TRecEntry *get_entry_for(StgTRecHeader *trec, StgTVar *tvar, StgTRecHeader **in) {
1133 TRecEntry *result = NULL;
1134
1135 TRACE("%p : get_entry_for TVar %p\n", trec, tvar);
1136 ASSERT(trec != NO_TREC);
1137
1138 do {
1139 FOR_EACH_ENTRY(trec, e, {
1140 if (e -> tvar == tvar) {
1141 result = e;
1142 if (in != NULL) {
1143 *in = trec;
1144 }
1145 BREAK_FOR_EACH;
1146 }
1147 });
1148 trec = trec -> enclosing_trec;
1149 } while (result == NULL && trec != NO_TREC);
1150
1151 return result;
1152 }
1153
1154 static StgClosure *read_current_value(StgTRecHeader *trec STG_UNUSED, StgTVar *tvar) {
1155 StgClosure *result;
1156 result = tvar -> current_value;
1157
1158 #if defined(STM_FG_LOCKS)
1159 while (GET_INFO(result) == &stg_TREC_HEADER_info) {
1160 TRACE("%p : read_current_value(%p) saw %p\n", trec, tvar, result);
1161 result = tvar -> current_value;
1162 }
1163 #endif
1164
1165 TRACE("%p : read_current_value(%p)=%p\n", trec, tvar, result);
1166 return result;
1167 }
1168
1169 /*......................................................................*/
1170
1171 StgClosure *stmReadTVar(Capability *cap,
1172 StgTRecHeader *trec,
1173 StgTVar *tvar) {
1174 StgTRecHeader *entry_in;
1175 StgClosure *result = NULL;
1176 TRecEntry *entry = NULL;
1177 TRACE("%p : stmReadTVar(%p)\n", trec, tvar);
1178 ASSERT (trec != NO_TREC);
1179 ASSERT (trec -> state == TREC_ACTIVE ||
1180 trec -> state == TREC_CONDEMNED);
1181
1182 entry = get_entry_for(trec, tvar, &entry_in);
1183
1184 if (entry != NULL) {
1185 if (entry_in == trec) {
1186 // Entry found in our trec
1187 result = entry -> new_value;
1188 } else {
1189 // Entry found in another trec
1190 TRecEntry *new_entry = get_new_entry(cap, trec);
1191 new_entry -> tvar = tvar;
1192 new_entry -> expected_value = entry -> expected_value;
1193 new_entry -> new_value = entry -> new_value;
1194 result = new_entry -> new_value;
1195 }
1196 } else {
1197 // No entry found
1198 StgClosure *current_value = read_current_value(trec, tvar);
1199 TRecEntry *new_entry = get_new_entry(cap, trec);
1200 new_entry -> tvar = tvar;
1201 new_entry -> expected_value = current_value;
1202 new_entry -> new_value = current_value;
1203 result = current_value;
1204 }
1205
1206 TRACE("%p : stmReadTVar(%p)=%p\n", trec, tvar, result);
1207 return result;
1208 }
1209
1210 /*......................................................................*/
1211
1212 void stmWriteTVar(Capability *cap,
1213 StgTRecHeader *trec,
1214 StgTVar *tvar,
1215 StgClosure *new_value) {
1216
1217 StgTRecHeader *entry_in;
1218 TRecEntry *entry = NULL;
1219 TRACE("%p : stmWriteTVar(%p, %p)\n", trec, tvar, new_value);
1220 ASSERT (trec != NO_TREC);
1221 ASSERT (trec -> state == TREC_ACTIVE ||
1222 trec -> state == TREC_CONDEMNED);
1223
1224 entry = get_entry_for(trec, tvar, &entry_in);
1225
1226 if (entry != NULL) {
1227 if (entry_in == trec) {
1228 // Entry found in our trec
1229 entry -> new_value = new_value;
1230 } else {
1231 // Entry found in another trec
1232 TRecEntry *new_entry = get_new_entry(cap, trec);
1233 new_entry -> tvar = tvar;
1234 new_entry -> expected_value = entry -> expected_value;
1235 new_entry -> new_value = new_value;
1236 }
1237 } else {
1238 // No entry found
1239 StgClosure *current_value = read_current_value(trec, tvar);
1240 TRecEntry *new_entry = get_new_entry(cap, trec);
1241 new_entry -> tvar = tvar;
1242 new_entry -> expected_value = current_value;
1243 new_entry -> new_value = new_value;
1244 }
1245
1246 TRACE("%p : stmWriteTVar done\n", trec);
1247 }
1248
1249 /*......................................................................*/
1250
1251 StgTVar *stmNewTVar(Capability *cap,
1252 StgClosure *new_value) {
1253 StgTVar *result;
1254 result = (StgTVar *)allocateLocal(cap, sizeofW(StgTVar));
1255 SET_HDR (result, &stg_TVAR_info, CCS_SYSTEM);
1256 result -> current_value = new_value;
1257 result -> first_wait_queue_entry = END_STM_WAIT_QUEUE;
1258 #if defined(THREADED_RTS)
1259 result -> num_updates = 0;
1260 #endif
1261 return result;
1262 }
1263
1264 /*......................................................................*/