Strip tag bits from closure pointers before trying to deference them.
[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_watch_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 "Storage.h"
90 #include "Schedule.h"
91 #include "SMP.h"
92 #include "STM.h"
93 #include "Trace.h"
94
95 #include <stdlib.h>
96 #include <stdio.h>
97
98 #define TRUE 1
99 #define FALSE 0
100
101 // ACQ_ASSERT is used for assertions which are only required for
102 // THREADED_RTS builds with fine-grained locking.
103
104 #if defined(STM_FG_LOCKS)
105 #define ACQ_ASSERT(_X) ASSERT(_X)
106 #define NACQ_ASSERT(_X) /*Nothing*/
107 #else
108 #define ACQ_ASSERT(_X) /*Nothing*/
109 #define NACQ_ASSERT(_X) ASSERT(_X)
110 #endif
111
112 /*......................................................................*/
113
114 // If SHAKE is defined then validation will sometime spuriously fail. They helps test
115 // unusualy code paths if genuine contention is rare
116
117 #define TRACE(_x...) debugTrace(DEBUG_stm, "STM: " _x)
118
119 #ifdef SHAKE
120 static const int do_shake = TRUE;
121 #else
122 static const int do_shake = FALSE;
123 #endif
124 static int shake_ctr = 0;
125 static int shake_lim = 1;
126
127 static int shake(void) {
128 if (do_shake) {
129 if (((shake_ctr++) % shake_lim) == 0) {
130 shake_ctr = 1;
131 shake_lim ++;
132 return TRUE;
133 }
134 return FALSE;
135 } else {
136 return FALSE;
137 }
138 }
139
140 /*......................................................................*/
141
142 // Helper macros for iterating over entries within a transaction
143 // record
144
145 #define FOR_EACH_ENTRY(_t,_x,CODE) do { \
146 StgTRecHeader *__t = (_t); \
147 StgTRecChunk *__c = __t -> current_chunk; \
148 StgWord __limit = __c -> next_entry_idx; \
149 TRACE("%p : FOR_EACH_ENTRY, current_chunk=%p limit=%ld", __t, __c, __limit); \
150 while (__c != END_STM_CHUNK_LIST) { \
151 StgWord __i; \
152 for (__i = 0; __i < __limit; __i ++) { \
153 TRecEntry *_x = &(__c -> entries[__i]); \
154 do { CODE } while (0); \
155 } \
156 __c = __c -> prev_chunk; \
157 __limit = TREC_CHUNK_NUM_ENTRIES; \
158 } \
159 exit_for_each: \
160 if (FALSE) goto exit_for_each; \
161 } while (0)
162
163 #define BREAK_FOR_EACH goto exit_for_each
164
165 /*......................................................................*/
166
167 // if REUSE_MEMORY is defined then attempt to re-use descriptors, log chunks,
168 // and wait queue entries without GC
169
170 #define REUSE_MEMORY
171
172 /*......................................................................*/
173
174 #define IF_STM_UNIPROC(__X) do { } while (0)
175 #define IF_STM_CG_LOCK(__X) do { } while (0)
176 #define IF_STM_FG_LOCKS(__X) do { } while (0)
177
178 #if defined(STM_UNIPROC)
179 #undef IF_STM_UNIPROC
180 #define IF_STM_UNIPROC(__X) do { __X } while (0)
181 static const StgBool config_use_read_phase = FALSE;
182
183 static void lock_stm(StgTRecHeader *trec STG_UNUSED) {
184 TRACE("%p : lock_stm()", trec);
185 }
186
187 static void unlock_stm(StgTRecHeader *trec STG_UNUSED) {
188 TRACE("%p : unlock_stm()", trec);
189 }
190
191 static StgClosure *lock_tvar(StgTRecHeader *trec STG_UNUSED,
192 StgTVar *s STG_UNUSED) {
193 StgClosure *result;
194 TRACE("%p : lock_tvar(%p)", trec, s);
195 result = s -> current_value;
196 return result;
197 }
198
199 static void unlock_tvar(StgTRecHeader *trec STG_UNUSED,
200 StgTVar *s STG_UNUSED,
201 StgClosure *c,
202 StgBool force_update) {
203 TRACE("%p : unlock_tvar(%p)", trec, s);
204 if (force_update) {
205 s -> current_value = c;
206 }
207 }
208
209 static StgBool cond_lock_tvar(StgTRecHeader *trec STG_UNUSED,
210 StgTVar *s STG_UNUSED,
211 StgClosure *expected) {
212 StgClosure *result;
213 TRACE("%p : cond_lock_tvar(%p, %p)", trec, s, expected);
214 result = s -> current_value;
215 TRACE("%p : %s", trec, (result == expected) ? "success" : "failure");
216 return (result == expected);
217 }
218
219 static StgBool lock_inv(StgAtomicInvariant *inv STG_UNUSED) {
220 // Nothing -- uniproc
221 return TRUE;
222 }
223
224 static void unlock_inv(StgAtomicInvariant *inv STG_UNUSED) {
225 // Nothing -- uniproc
226 }
227 #endif
228
229 #if defined(STM_CG_LOCK) /*........................................*/
230
231 #undef IF_STM_CG_LOCK
232 #define IF_STM_CG_LOCK(__X) do { __X } while (0)
233 static const StgBool config_use_read_phase = FALSE;
234 static volatile StgTRecHeader *smp_locked = NULL;
235
236 static void lock_stm(StgTRecHeader *trec) {
237 while (cas(&smp_locked, NULL, trec) != NULL) { }
238 TRACE("%p : lock_stm()", trec);
239 }
240
241 static void unlock_stm(StgTRecHeader *trec STG_UNUSED) {
242 TRACE("%p : unlock_stm()", trec);
243 ASSERT (smp_locked == trec);
244 smp_locked = 0;
245 }
246
247 static StgClosure *lock_tvar(StgTRecHeader *trec STG_UNUSED,
248 StgTVar *s STG_UNUSED) {
249 StgClosure *result;
250 TRACE("%p : lock_tvar(%p)", trec, s);
251 ASSERT (smp_locked == trec);
252 result = s -> current_value;
253 return result;
254 }
255
256 static void *unlock_tvar(StgTRecHeader *trec STG_UNUSED,
257 StgTVar *s STG_UNUSED,
258 StgClosure *c,
259 StgBool force_update) {
260 TRACE("%p : unlock_tvar(%p, %p)", trec, s, c);
261 ASSERT (smp_locked == trec);
262 if (force_update) {
263 s -> current_value = c;
264 }
265 }
266
267 static StgBool cond_lock_tvar(StgTRecHeader *trec STG_UNUSED,
268 StgTVar *s STG_UNUSED,
269 StgClosure *expected) {
270 StgClosure *result;
271 TRACE("%p : cond_lock_tvar(%p, %p)", trec, s, expected);
272 ASSERT (smp_locked == trec);
273 result = s -> current_value;
274 TRACE("%p : %d", result ? "success" : "failure");
275 return (result == expected);
276 }
277
278 static StgBool lock_inv(StgAtomicInvariant *inv STG_UNUSED) {
279 // Nothing -- protected by STM lock
280 return TRUE;
281 }
282
283 static void unlock_inv(StgAtomicInvariant *inv STG_UNUSED) {
284 // Nothing -- protected by STM lock
285 }
286 #endif
287
288 #if defined(STM_FG_LOCKS) /*...................................*/
289
290 #undef IF_STM_FG_LOCKS
291 #define IF_STM_FG_LOCKS(__X) do { __X } while (0)
292 static const StgBool config_use_read_phase = TRUE;
293
294 static void lock_stm(StgTRecHeader *trec STG_UNUSED) {
295 TRACE("%p : lock_stm()", trec);
296 }
297
298 static void unlock_stm(StgTRecHeader *trec STG_UNUSED) {
299 TRACE("%p : unlock_stm()", trec);
300 }
301
302 static StgClosure *lock_tvar(StgTRecHeader *trec,
303 StgTVar *s STG_UNUSED) {
304 StgClosure *result;
305 TRACE("%p : lock_tvar(%p)", trec, s);
306 do {
307 do {
308 result = s -> current_value;
309 } while (GET_INFO(UNTAG_CLOSURE(result)) == &stg_TREC_HEADER_info);
310 } while (cas((void *)&(s -> current_value),
311 (StgWord)result, (StgWord)trec) != (StgWord)result);
312 return result;
313 }
314
315 static void unlock_tvar(StgTRecHeader *trec STG_UNUSED,
316 StgTVar *s,
317 StgClosure *c,
318 StgBool force_update STG_UNUSED) {
319 TRACE("%p : unlock_tvar(%p, %p)", trec, s, c);
320 ASSERT(s -> current_value == (StgClosure *)trec);
321 s -> current_value = c;
322 }
323
324 static StgBool cond_lock_tvar(StgTRecHeader *trec,
325 StgTVar *s,
326 StgClosure *expected) {
327 StgClosure *result;
328 StgWord w;
329 TRACE("%p : cond_lock_tvar(%p, %p)", trec, s, expected);
330 w = cas((void *)&(s -> current_value), (StgWord)expected, (StgWord)trec);
331 result = (StgClosure *)w;
332 TRACE("%p : %s", trec, result ? "success" : "failure");
333 return (result == expected);
334 }
335
336 static StgBool lock_inv(StgAtomicInvariant *inv) {
337 return (cas(&(inv -> lock), 0, 1) == 0);
338 }
339
340 static void unlock_inv(StgAtomicInvariant *inv) {
341 ASSERT(inv -> lock == 1);
342 inv -> lock = 0;
343 }
344 #endif
345
346 /*......................................................................*/
347
348 static StgBool watcher_is_tso(StgTVarWatchQueue *q) {
349 StgClosure *c = q -> closure;
350 StgInfoTable *info = get_itbl(c);
351 return (info -> type) == TSO;
352 }
353
354 static StgBool watcher_is_invariant(StgTVarWatchQueue *q) {
355 StgClosure *c = q -> closure;
356 StgInfoTable *info = get_itbl(c);
357 return (info -> type) == ATOMIC_INVARIANT;
358 }
359
360 /*......................................................................*/
361
362 // Helper functions for thread blocking and unblocking
363
364 static void park_tso(StgTSO *tso) {
365 ASSERT(tso -> why_blocked == NotBlocked);
366 tso -> why_blocked = BlockedOnSTM;
367 tso -> block_info.closure = (StgClosure *) END_TSO_QUEUE;
368 TRACE("park_tso on tso=%p", tso);
369 }
370
371 static void unpark_tso(Capability *cap, StgTSO *tso) {
372 // We will continue unparking threads while they remain on one of the wait
373 // queues: it's up to the thread itself to remove it from the wait queues
374 // if it decides to do so when it is scheduled.
375
376 // Unblocking a TSO from BlockedOnSTM is done under the TSO lock,
377 // to avoid multiple CPUs unblocking the same TSO, and also to
378 // synchronise with throwTo().
379 lockTSO(tso);
380 if (tso -> why_blocked == BlockedOnSTM) {
381 TRACE("unpark_tso on tso=%p", tso);
382 unblockOne(cap,tso);
383 } else {
384 TRACE("spurious unpark_tso on tso=%p", tso);
385 }
386 unlockTSO(tso);
387 }
388
389 static void unpark_waiters_on(Capability *cap, StgTVar *s) {
390 StgTVarWatchQueue *q;
391 StgTVarWatchQueue *trail;
392 TRACE("unpark_waiters_on tvar=%p", s);
393 // unblock TSOs in reverse order, to be a bit fairer (#2319)
394 for (q = s -> first_watch_queue_entry, trail = q;
395 q != END_STM_WATCH_QUEUE;
396 q = q -> next_queue_entry) {
397 trail = q;
398 }
399 q = trail;
400 for (;
401 q != END_STM_WATCH_QUEUE;
402 q = q -> prev_queue_entry) {
403 if (watcher_is_tso(q)) {
404 unpark_tso(cap, (StgTSO *)(q -> closure));
405 }
406 }
407 }
408
409 /*......................................................................*/
410
411 // Helper functions for downstream allocation and initialization
412
413 static StgInvariantCheckQueue *new_stg_invariant_check_queue(Capability *cap,
414 StgAtomicInvariant *invariant) {
415 StgInvariantCheckQueue *result;
416 result = (StgInvariantCheckQueue *)allocateLocal(cap, sizeofW(StgInvariantCheckQueue));
417 SET_HDR (result, &stg_INVARIANT_CHECK_QUEUE_info, CCS_SYSTEM);
418 result -> invariant = invariant;
419 result -> my_execution = NO_TREC;
420 return result;
421 }
422
423 static StgTVarWatchQueue *new_stg_tvar_watch_queue(Capability *cap,
424 StgClosure *closure) {
425 StgTVarWatchQueue *result;
426 result = (StgTVarWatchQueue *)allocateLocal(cap, sizeofW(StgTVarWatchQueue));
427 SET_HDR (result, &stg_TVAR_WATCH_QUEUE_info, CCS_SYSTEM);
428 result -> closure = closure;
429 return result;
430 }
431
432 static StgTRecChunk *new_stg_trec_chunk(Capability *cap) {
433 StgTRecChunk *result;
434 result = (StgTRecChunk *)allocateLocal(cap, sizeofW(StgTRecChunk));
435 SET_HDR (result, &stg_TREC_CHUNK_info, CCS_SYSTEM);
436 result -> prev_chunk = END_STM_CHUNK_LIST;
437 result -> next_entry_idx = 0;
438 return result;
439 }
440
441 static StgTRecHeader *new_stg_trec_header(Capability *cap,
442 StgTRecHeader *enclosing_trec) {
443 StgTRecHeader *result;
444 result = (StgTRecHeader *) allocateLocal(cap, sizeofW(StgTRecHeader));
445 SET_HDR (result, &stg_TREC_HEADER_info, CCS_SYSTEM);
446
447 result -> enclosing_trec = enclosing_trec;
448 result -> current_chunk = new_stg_trec_chunk(cap);
449 result -> invariants_to_check = END_INVARIANT_CHECK_QUEUE;
450
451 if (enclosing_trec == NO_TREC) {
452 result -> state = TREC_ACTIVE;
453 } else {
454 ASSERT(enclosing_trec -> state == TREC_ACTIVE ||
455 enclosing_trec -> state == TREC_CONDEMNED);
456 result -> state = enclosing_trec -> state;
457 }
458
459 return result;
460 }
461
462 /*......................................................................*/
463
464 // Allocation / deallocation functions that retain per-capability lists
465 // of closures that can be re-used
466
467 static StgInvariantCheckQueue *alloc_stg_invariant_check_queue(Capability *cap,
468 StgAtomicInvariant *invariant) {
469 StgInvariantCheckQueue *result = NULL;
470 if (cap -> free_invariant_check_queues == END_INVARIANT_CHECK_QUEUE) {
471 result = new_stg_invariant_check_queue(cap, invariant);
472 } else {
473 result = cap -> free_invariant_check_queues;
474 result -> invariant = invariant;
475 result -> my_execution = NO_TREC;
476 cap -> free_invariant_check_queues = result -> next_queue_entry;
477 }
478 return result;
479 }
480
481 static StgTVarWatchQueue *alloc_stg_tvar_watch_queue(Capability *cap,
482 StgClosure *closure) {
483 StgTVarWatchQueue *result = NULL;
484 if (cap -> free_tvar_watch_queues == END_STM_WATCH_QUEUE) {
485 result = new_stg_tvar_watch_queue(cap, closure);
486 } else {
487 result = cap -> free_tvar_watch_queues;
488 result -> closure = closure;
489 cap -> free_tvar_watch_queues = result -> next_queue_entry;
490 }
491 return result;
492 }
493
494 static void free_stg_tvar_watch_queue(Capability *cap,
495 StgTVarWatchQueue *wq) {
496 #if defined(REUSE_MEMORY)
497 wq -> next_queue_entry = cap -> free_tvar_watch_queues;
498 cap -> free_tvar_watch_queues = wq;
499 #endif
500 }
501
502 static StgTRecChunk *alloc_stg_trec_chunk(Capability *cap) {
503 StgTRecChunk *result = NULL;
504 if (cap -> free_trec_chunks == END_STM_CHUNK_LIST) {
505 result = new_stg_trec_chunk(cap);
506 } else {
507 result = cap -> free_trec_chunks;
508 cap -> free_trec_chunks = result -> prev_chunk;
509 result -> prev_chunk = END_STM_CHUNK_LIST;
510 result -> next_entry_idx = 0;
511 }
512 return result;
513 }
514
515 static void free_stg_trec_chunk(Capability *cap,
516 StgTRecChunk *c) {
517 #if defined(REUSE_MEMORY)
518 c -> prev_chunk = cap -> free_trec_chunks;
519 cap -> free_trec_chunks = c;
520 #endif
521 }
522
523 static StgTRecHeader *alloc_stg_trec_header(Capability *cap,
524 StgTRecHeader *enclosing_trec) {
525 StgTRecHeader *result = NULL;
526 if (cap -> free_trec_headers == NO_TREC) {
527 result = new_stg_trec_header(cap, enclosing_trec);
528 } else {
529 result = cap -> free_trec_headers;
530 cap -> free_trec_headers = result -> enclosing_trec;
531 result -> enclosing_trec = enclosing_trec;
532 result -> current_chunk -> next_entry_idx = 0;
533 result -> invariants_to_check = END_INVARIANT_CHECK_QUEUE;
534 if (enclosing_trec == NO_TREC) {
535 result -> state = TREC_ACTIVE;
536 } else {
537 ASSERT(enclosing_trec -> state == TREC_ACTIVE ||
538 enclosing_trec -> state == TREC_CONDEMNED);
539 result -> state = enclosing_trec -> state;
540 }
541 }
542 return result;
543 }
544
545 static void free_stg_trec_header(Capability *cap,
546 StgTRecHeader *trec) {
547 #if defined(REUSE_MEMORY)
548 StgTRecChunk *chunk = trec -> current_chunk -> prev_chunk;
549 while (chunk != END_STM_CHUNK_LIST) {
550 StgTRecChunk *prev_chunk = chunk -> prev_chunk;
551 free_stg_trec_chunk(cap, chunk);
552 chunk = prev_chunk;
553 }
554 trec -> current_chunk -> prev_chunk = END_STM_CHUNK_LIST;
555 trec -> enclosing_trec = cap -> free_trec_headers;
556 cap -> free_trec_headers = trec;
557 #endif
558 }
559
560 /*......................................................................*/
561
562 // Helper functions for managing waiting lists
563
564 static void build_watch_queue_entries_for_trec(Capability *cap,
565 StgTSO *tso,
566 StgTRecHeader *trec) {
567 ASSERT(trec != NO_TREC);
568 ASSERT(trec -> enclosing_trec == NO_TREC);
569 ASSERT(trec -> state == TREC_ACTIVE);
570
571 TRACE("%p : build_watch_queue_entries_for_trec()", trec);
572
573 FOR_EACH_ENTRY(trec, e, {
574 StgTVar *s;
575 StgTVarWatchQueue *q;
576 StgTVarWatchQueue *fq;
577 s = e -> tvar;
578 TRACE("%p : adding tso=%p to watch queue for tvar=%p", trec, tso, s);
579 ACQ_ASSERT(s -> current_value == (StgClosure *)trec);
580 NACQ_ASSERT(s -> current_value == e -> expected_value);
581 fq = s -> first_watch_queue_entry;
582 q = alloc_stg_tvar_watch_queue(cap, (StgClosure*) tso);
583 q -> next_queue_entry = fq;
584 q -> prev_queue_entry = END_STM_WATCH_QUEUE;
585 if (fq != END_STM_WATCH_QUEUE) {
586 fq -> prev_queue_entry = q;
587 }
588 s -> first_watch_queue_entry = q;
589 e -> new_value = (StgClosure *) q;
590 });
591 }
592
593 static void remove_watch_queue_entries_for_trec(Capability *cap,
594 StgTRecHeader *trec) {
595 ASSERT(trec != NO_TREC);
596 ASSERT(trec -> enclosing_trec == NO_TREC);
597 ASSERT(trec -> state == TREC_WAITING ||
598 trec -> state == TREC_CONDEMNED);
599
600 TRACE("%p : remove_watch_queue_entries_for_trec()", trec);
601
602 FOR_EACH_ENTRY(trec, e, {
603 StgTVar *s;
604 StgTVarWatchQueue *pq;
605 StgTVarWatchQueue *nq;
606 StgTVarWatchQueue *q;
607 StgClosure *saw;
608 s = e -> tvar;
609 saw = lock_tvar(trec, s);
610 q = (StgTVarWatchQueue *) (e -> new_value);
611 TRACE("%p : removing tso=%p from watch queue for tvar=%p",
612 trec,
613 q -> closure,
614 s);
615 ACQ_ASSERT(s -> current_value == (StgClosure *)trec);
616 nq = q -> next_queue_entry;
617 pq = q -> prev_queue_entry;
618 if (nq != END_STM_WATCH_QUEUE) {
619 nq -> prev_queue_entry = pq;
620 }
621 if (pq != END_STM_WATCH_QUEUE) {
622 pq -> next_queue_entry = nq;
623 } else {
624 ASSERT (s -> first_watch_queue_entry == q);
625 s -> first_watch_queue_entry = nq;
626 }
627 free_stg_tvar_watch_queue(cap, q);
628 unlock_tvar(trec, s, saw, FALSE);
629 });
630 }
631
632 /*......................................................................*/
633
634 static TRecEntry *get_new_entry(Capability *cap,
635 StgTRecHeader *t) {
636 TRecEntry *result;
637 StgTRecChunk *c;
638 int i;
639
640 c = t -> current_chunk;
641 i = c -> next_entry_idx;
642 ASSERT(c != END_STM_CHUNK_LIST);
643
644 if (i < TREC_CHUNK_NUM_ENTRIES) {
645 // Continue to use current chunk
646 result = &(c -> entries[i]);
647 c -> next_entry_idx ++;
648 } else {
649 // Current chunk is full: allocate a fresh one
650 StgTRecChunk *nc;
651 nc = alloc_stg_trec_chunk(cap);
652 nc -> prev_chunk = c;
653 nc -> next_entry_idx = 1;
654 t -> current_chunk = nc;
655 result = &(nc -> entries[0]);
656 }
657
658 return result;
659 }
660
661 /*......................................................................*/
662
663 static void merge_update_into(Capability *cap,
664 StgTRecHeader *t,
665 StgTVar *tvar,
666 StgClosure *expected_value,
667 StgClosure *new_value) {
668 int found;
669
670 // Look for an entry in this trec
671 found = FALSE;
672 FOR_EACH_ENTRY(t, e, {
673 StgTVar *s;
674 s = e -> tvar;
675 if (s == tvar) {
676 found = TRUE;
677 if (e -> expected_value != expected_value) {
678 // Must abort if the two entries start from different values
679 TRACE("%p : update entries inconsistent at %p (%p vs %p)",
680 t, tvar, e -> expected_value, expected_value);
681 t -> state = TREC_CONDEMNED;
682 }
683 e -> new_value = new_value;
684 BREAK_FOR_EACH;
685 }
686 });
687
688 if (!found) {
689 // No entry so far in this trec
690 TRecEntry *ne;
691 ne = get_new_entry(cap, t);
692 ne -> tvar = tvar;
693 ne -> expected_value = expected_value;
694 ne -> new_value = new_value;
695 }
696 }
697
698 /*......................................................................*/
699
700 static void merge_read_into(Capability *cap,
701 StgTRecHeader *t,
702 StgTVar *tvar,
703 StgClosure *expected_value) {
704 int found;
705
706 // Look for an entry in this trec
707 found = FALSE;
708 FOR_EACH_ENTRY(t, e, {
709 StgTVar *s;
710 s = e -> tvar;
711 if (s == tvar) {
712 found = TRUE;
713 if (e -> expected_value != expected_value) {
714 // Must abort if the two entries start from different values
715 TRACE("%p : read entries inconsistent at %p (%p vs %p)",
716 t, tvar, e -> expected_value, expected_value);
717 t -> state = TREC_CONDEMNED;
718 }
719 BREAK_FOR_EACH;
720 }
721 });
722
723 if (!found) {
724 // No entry so far in this trec
725 TRecEntry *ne;
726 ne = get_new_entry(cap, t);
727 ne -> tvar = tvar;
728 ne -> expected_value = expected_value;
729 ne -> new_value = expected_value;
730 }
731 }
732
733 /*......................................................................*/
734
735 static StgBool entry_is_update(TRecEntry *e) {
736 StgBool result;
737 result = (e -> expected_value != e -> new_value);
738 return result;
739 }
740
741 #if defined(STM_FG_LOCKS)
742 static StgBool entry_is_read_only(TRecEntry *e) {
743 StgBool result;
744 result = (e -> expected_value == e -> new_value);
745 return result;
746 }
747
748 static StgBool tvar_is_locked(StgTVar *s, StgTRecHeader *h) {
749 StgClosure *c;
750 StgBool result;
751 c = s -> current_value;
752 result = (c == (StgClosure *) h);
753 return result;
754 }
755 #endif
756
757 // revert_ownership : release a lock on a TVar, storing back
758 // the value that it held when the lock was acquired. "revert_all"
759 // is set in stmWait and stmReWait when we acquired locks on all of
760 // the TVars involved. "revert_all" is not set in commit operations
761 // where we don't lock TVars that have been read from but not updated.
762
763 static void revert_ownership(StgTRecHeader *trec STG_UNUSED,
764 StgBool revert_all STG_UNUSED) {
765 #if defined(STM_FG_LOCKS)
766 FOR_EACH_ENTRY(trec, e, {
767 if (revert_all || entry_is_update(e)) {
768 StgTVar *s;
769 s = e -> tvar;
770 if (tvar_is_locked(s, trec)) {
771 unlock_tvar(trec, s, e -> expected_value, TRUE);
772 }
773 }
774 });
775 #endif
776 }
777
778 /*......................................................................*/
779
780 // validate_and_acquire_ownership : this performs the twin functions
781 // of checking that the TVars referred to by entries in trec hold the
782 // expected values and:
783 //
784 // - locking the TVar (on updated TVars during commit, or all TVars
785 // during wait)
786 //
787 // - recording the identity of the TRec who wrote the value seen in the
788 // TVar (on non-updated TVars during commit). These values are
789 // stashed in the TRec entries and are then checked in check_read_only
790 // to ensure that an atomic snapshot of all of these locations has been
791 // seen.
792
793 static StgBool validate_and_acquire_ownership (StgTRecHeader *trec,
794 int acquire_all,
795 int retain_ownership) {
796 StgBool result;
797
798 if (shake()) {
799 TRACE("%p : shake, pretending trec is invalid when it may not be", trec);
800 return FALSE;
801 }
802
803 ASSERT ((trec -> state == TREC_ACTIVE) ||
804 (trec -> state == TREC_WAITING) ||
805 (trec -> state == TREC_CONDEMNED));
806 result = !((trec -> state) == TREC_CONDEMNED);
807 if (result) {
808 FOR_EACH_ENTRY(trec, e, {
809 StgTVar *s;
810 s = e -> tvar;
811 if (acquire_all || entry_is_update(e)) {
812 TRACE("%p : trying to acquire %p", trec, s);
813 if (!cond_lock_tvar(trec, s, e -> expected_value)) {
814 TRACE("%p : failed to acquire %p", trec, s);
815 result = FALSE;
816 BREAK_FOR_EACH;
817 }
818 } else {
819 ASSERT(config_use_read_phase);
820 IF_STM_FG_LOCKS({
821 TRACE("%p : will need to check %p", trec, s);
822 if (s -> current_value != e -> expected_value) {
823 TRACE("%p : doesn't match", trec);
824 result = FALSE;
825 BREAK_FOR_EACH;
826 }
827 e -> num_updates = s -> num_updates;
828 if (s -> current_value != e -> expected_value) {
829 TRACE("%p : doesn't match (race)", trec);
830 result = FALSE;
831 BREAK_FOR_EACH;
832 } else {
833 TRACE("%p : need to check version %ld", trec, e -> num_updates);
834 }
835 });
836 }
837 });
838 }
839
840 if ((!result) || (!retain_ownership)) {
841 revert_ownership(trec, acquire_all);
842 }
843
844 return result;
845 }
846
847 // check_read_only : check that we've seen an atomic snapshot of the
848 // non-updated TVars accessed by a trec. This checks that the last TRec to
849 // commit an update to the TVar is unchanged since the value was stashed in
850 // validate_and_acquire_ownership. If no udpate is seen to any TVar than
851 // all of them contained their expected values at the start of the call to
852 // check_read_only.
853 //
854 // The paper "Concurrent programming without locks" (under submission), or
855 // Keir Fraser's PhD dissertation "Practical lock-free programming" discuss
856 // this kind of algorithm.
857
858 static StgBool check_read_only(StgTRecHeader *trec STG_UNUSED) {
859 StgBool result = TRUE;
860
861 ASSERT (config_use_read_phase);
862 IF_STM_FG_LOCKS({
863 FOR_EACH_ENTRY(trec, e, {
864 StgTVar *s;
865 s = e -> tvar;
866 if (entry_is_read_only(e)) {
867 TRACE("%p : check_read_only for TVar %p, saw %ld", trec, s, e -> num_updates);
868 if (s -> num_updates != e -> num_updates) {
869 // ||s -> current_value != e -> expected_value) {
870 TRACE("%p : mismatch", trec);
871 result = FALSE;
872 BREAK_FOR_EACH;
873 }
874 }
875 });
876 });
877
878 return result;
879 }
880
881
882 /************************************************************************/
883
884 void stmPreGCHook() {
885 nat i;
886
887 lock_stm(NO_TREC);
888 TRACE("stmPreGCHook");
889 for (i = 0; i < n_capabilities; i ++) {
890 Capability *cap = &capabilities[i];
891 cap -> free_tvar_watch_queues = END_STM_WATCH_QUEUE;
892 cap -> free_trec_chunks = END_STM_CHUNK_LIST;
893 cap -> free_trec_headers = NO_TREC;
894 }
895 unlock_stm(NO_TREC);
896 }
897
898 /************************************************************************/
899
900 // check_read_only relies on version numbers held in TVars' "num_updates"
901 // fields not wrapping around while a transaction is committed. The version
902 // number is incremented each time an update is committed to the TVar
903 // This is unlikely to wrap around when 32-bit integers are used for the counts,
904 // but to ensure correctness we maintain a shared count on the maximum
905 // number of commit operations that may occur and check that this has
906 // not increased by more than 2^32 during a commit.
907
908 #define TOKEN_BATCH_SIZE 1024
909
910 static volatile StgInt64 max_commits = 0;
911
912 #if defined(THREADED_RTS)
913 static volatile StgBool token_locked = FALSE;
914
915 static void getTokenBatch(Capability *cap) {
916 while (cas((void *)&token_locked, FALSE, TRUE) == TRUE) { /* nothing */ }
917 max_commits += TOKEN_BATCH_SIZE;
918 TRACE("%p : cap got token batch, max_commits=%" FMT_Int64, cap, max_commits);
919 cap -> transaction_tokens = TOKEN_BATCH_SIZE;
920 token_locked = FALSE;
921 }
922
923 static void getToken(Capability *cap) {
924 if (cap -> transaction_tokens == 0) {
925 getTokenBatch(cap);
926 }
927 cap -> transaction_tokens --;
928 }
929 #else
930 static void getToken(Capability *cap STG_UNUSED) {
931 // Nothing
932 }
933 #endif
934
935 /*......................................................................*/
936
937 StgTRecHeader *stmStartTransaction(Capability *cap,
938 StgTRecHeader *outer) {
939 StgTRecHeader *t;
940 TRACE("%p : stmStartTransaction with %d tokens",
941 outer,
942 cap -> transaction_tokens);
943
944 getToken(cap);
945
946 t = alloc_stg_trec_header(cap, outer);
947 TRACE("%p : stmStartTransaction()=%p", outer, t);
948 return t;
949 }
950
951 /*......................................................................*/
952
953 void stmAbortTransaction(Capability *cap,
954 StgTRecHeader *trec) {
955 StgTRecHeader *et;
956 TRACE("%p : stmAbortTransaction", trec);
957 ASSERT (trec != NO_TREC);
958 ASSERT ((trec -> state == TREC_ACTIVE) ||
959 (trec -> state == TREC_WAITING) ||
960 (trec -> state == TREC_CONDEMNED));
961
962 lock_stm(trec);
963
964 et = trec -> enclosing_trec;
965 if (et == NO_TREC) {
966 // We're a top-level transaction: remove any watch queue entries that
967 // we may have.
968 TRACE("%p : aborting top-level transaction", trec);
969
970 if (trec -> state == TREC_WAITING) {
971 ASSERT (trec -> enclosing_trec == NO_TREC);
972 TRACE("%p : stmAbortTransaction aborting waiting transaction", trec);
973 remove_watch_queue_entries_for_trec(cap, trec);
974 }
975
976 } else {
977 // We're a nested transaction: merge our read set into our parent's
978 TRACE("%p : retaining read-set into parent %p", trec, et);
979
980 FOR_EACH_ENTRY(trec, e, {
981 StgTVar *s = e -> tvar;
982 merge_read_into(cap, et, s, e -> expected_value);
983 });
984 }
985
986 trec -> state = TREC_ABORTED;
987 unlock_stm(trec);
988
989 TRACE("%p : stmAbortTransaction done", trec);
990 }
991
992 /*......................................................................*/
993
994 void stmFreeAbortedTRec(Capability *cap,
995 StgTRecHeader *trec) {
996 TRACE("%p : stmFreeAbortedTRec", trec);
997 ASSERT (trec != NO_TREC);
998 ASSERT ((trec -> state == TREC_CONDEMNED) ||
999 (trec -> state == TREC_ABORTED));
1000
1001 free_stg_trec_header(cap, trec);
1002
1003 TRACE("%p : stmFreeAbortedTRec done", trec);
1004 }
1005
1006 /*......................................................................*/
1007
1008 void stmCondemnTransaction(Capability *cap,
1009 StgTRecHeader *trec) {
1010 TRACE("%p : stmCondemnTransaction", trec);
1011 ASSERT (trec != NO_TREC);
1012 ASSERT ((trec -> state == TREC_ACTIVE) ||
1013 (trec -> state == TREC_WAITING) ||
1014 (trec -> state == TREC_CONDEMNED));
1015
1016 lock_stm(trec);
1017 if (trec -> state == TREC_WAITING) {
1018 ASSERT (trec -> enclosing_trec == NO_TREC);
1019 TRACE("%p : stmCondemnTransaction condemning waiting transaction", trec);
1020 remove_watch_queue_entries_for_trec(cap, trec);
1021 }
1022 trec -> state = TREC_CONDEMNED;
1023 unlock_stm(trec);
1024
1025 TRACE("%p : stmCondemnTransaction done", trec);
1026 }
1027
1028 /*......................................................................*/
1029
1030 StgTRecHeader *stmGetEnclosingTRec(StgTRecHeader *trec) {
1031 StgTRecHeader *outer;
1032 TRACE("%p : stmGetEnclosingTRec", trec);
1033 outer = trec -> enclosing_trec;
1034 TRACE("%p : stmGetEnclosingTRec()=%p", trec, outer);
1035 return outer;
1036 }
1037
1038 /*......................................................................*/
1039
1040 StgBool stmValidateNestOfTransactions(StgTRecHeader *trec) {
1041 StgTRecHeader *t;
1042 StgBool result;
1043
1044 TRACE("%p : stmValidateNestOfTransactions", trec);
1045 ASSERT(trec != NO_TREC);
1046 ASSERT((trec -> state == TREC_ACTIVE) ||
1047 (trec -> state == TREC_WAITING) ||
1048 (trec -> state == TREC_CONDEMNED));
1049
1050 lock_stm(trec);
1051
1052 t = trec;
1053 result = TRUE;
1054 while (t != NO_TREC) {
1055 result &= validate_and_acquire_ownership(t, TRUE, FALSE);
1056 t = t -> enclosing_trec;
1057 }
1058
1059 if (!result && trec -> state != TREC_WAITING) {
1060 trec -> state = TREC_CONDEMNED;
1061 }
1062
1063 unlock_stm(trec);
1064
1065 TRACE("%p : stmValidateNestOfTransactions()=%d", trec, result);
1066 return result;
1067 }
1068
1069 /*......................................................................*/
1070
1071 static TRecEntry *get_entry_for(StgTRecHeader *trec, StgTVar *tvar, StgTRecHeader **in) {
1072 TRecEntry *result = NULL;
1073
1074 TRACE("%p : get_entry_for TVar %p", trec, tvar);
1075 ASSERT(trec != NO_TREC);
1076
1077 do {
1078 FOR_EACH_ENTRY(trec, e, {
1079 if (e -> tvar == tvar) {
1080 result = e;
1081 if (in != NULL) {
1082 *in = trec;
1083 }
1084 BREAK_FOR_EACH;
1085 }
1086 });
1087 trec = trec -> enclosing_trec;
1088 } while (result == NULL && trec != NO_TREC);
1089
1090 return result;
1091 }
1092
1093 /*......................................................................*/
1094
1095 /*
1096 * Add/remove links between an invariant TVars. The caller must have
1097 * locked the TVars involved and the invariant.
1098 */
1099
1100 static void disconnect_invariant(Capability *cap,
1101 StgAtomicInvariant *inv) {
1102 StgTRecHeader *last_execution = inv -> last_execution;
1103
1104 TRACE("unhooking last execution inv=%p trec=%p", inv, last_execution);
1105
1106 FOR_EACH_ENTRY(last_execution, e, {
1107 StgTVar *s = e -> tvar;
1108 StgTVarWatchQueue *q = s -> first_watch_queue_entry;
1109 StgBool found = FALSE;
1110 TRACE(" looking for trec on tvar=%p", s);
1111 for (q = s -> first_watch_queue_entry;
1112 q != END_STM_WATCH_QUEUE;
1113 q = q -> next_queue_entry) {
1114 if (q -> closure == (StgClosure*)inv) {
1115 StgTVarWatchQueue *pq;
1116 StgTVarWatchQueue *nq;
1117 nq = q -> next_queue_entry;
1118 pq = q -> prev_queue_entry;
1119 if (nq != END_STM_WATCH_QUEUE) {
1120 nq -> prev_queue_entry = pq;
1121 }
1122 if (pq != END_STM_WATCH_QUEUE) {
1123 pq -> next_queue_entry = nq;
1124 } else {
1125 ASSERT (s -> first_watch_queue_entry == q);
1126 s -> first_watch_queue_entry = nq;
1127 }
1128 TRACE(" found it in watch queue entry %p", q);
1129 free_stg_tvar_watch_queue(cap, q);
1130 found = TRUE;
1131 break;
1132 }
1133 }
1134 ASSERT(found);
1135 });
1136 inv -> last_execution = NO_TREC;
1137 }
1138
1139 static void connect_invariant_to_trec(Capability *cap,
1140 StgAtomicInvariant *inv,
1141 StgTRecHeader *my_execution) {
1142 TRACE("connecting execution inv=%p trec=%p", inv, my_execution);
1143
1144 ASSERT(inv -> last_execution == NO_TREC);
1145
1146 FOR_EACH_ENTRY(my_execution, e, {
1147 StgTVar *s = e -> tvar;
1148 StgTVarWatchQueue *q = alloc_stg_tvar_watch_queue(cap, (StgClosure*)inv);
1149 StgTVarWatchQueue *fq = s -> first_watch_queue_entry;
1150
1151 // We leave "last_execution" holding the values that will be
1152 // in the heap after the transaction we're in the process
1153 // of committing has finished.
1154 TRecEntry *entry = get_entry_for(my_execution -> enclosing_trec, s, NULL);
1155 if (entry != NULL) {
1156 e -> expected_value = entry -> new_value;
1157 e -> new_value = entry -> new_value;
1158 }
1159
1160 TRACE(" linking trec on tvar=%p value=%p q=%p", s, e -> expected_value, q);
1161 q -> next_queue_entry = fq;
1162 q -> prev_queue_entry = END_STM_WATCH_QUEUE;
1163 if (fq != END_STM_WATCH_QUEUE) {
1164 fq -> prev_queue_entry = q;
1165 }
1166 s -> first_watch_queue_entry = q;
1167 });
1168
1169 inv -> last_execution = my_execution;
1170 }
1171
1172 /*
1173 * Add a new invariant to the trec's list of invariants to check on commit
1174 */
1175 void stmAddInvariantToCheck(Capability *cap,
1176 StgTRecHeader *trec,
1177 StgClosure *code) {
1178 StgAtomicInvariant *invariant;
1179 StgInvariantCheckQueue *q;
1180 TRACE("%p : stmAddInvariantToCheck closure=%p", trec, code);
1181 ASSERT(trec != NO_TREC);
1182 ASSERT(trec -> state == TREC_ACTIVE ||
1183 trec -> state == TREC_CONDEMNED);
1184
1185
1186 // 1. Allocate an StgAtomicInvariant, set last_execution to NO_TREC
1187 // to signal that this is a new invariant in the current atomic block
1188
1189 invariant = (StgAtomicInvariant *) allocateLocal(cap, sizeofW(StgAtomicInvariant));
1190 TRACE("%p : stmAddInvariantToCheck allocated invariant=%p", trec, invariant);
1191 SET_HDR (invariant, &stg_ATOMIC_INVARIANT_info, CCS_SYSTEM);
1192 invariant -> code = code;
1193 invariant -> last_execution = NO_TREC;
1194
1195 // 2. Allocate an StgInvariantCheckQueue entry, link it to the current trec
1196
1197 q = alloc_stg_invariant_check_queue(cap, invariant);
1198 TRACE("%p : stmAddInvariantToCheck allocated q=%p", trec, q);
1199 q -> invariant = invariant;
1200 q -> my_execution = NO_TREC;
1201 q -> next_queue_entry = trec -> invariants_to_check;
1202 trec -> invariants_to_check = q;
1203
1204 TRACE("%p : stmAddInvariantToCheck done", trec);
1205 }
1206
1207 /*
1208 * Fill in the trec's list of invariants that might be violated by the
1209 * current transaction.
1210 */
1211
1212 StgInvariantCheckQueue *stmGetInvariantsToCheck(Capability *cap, StgTRecHeader *trec) {
1213 StgTRecChunk *c;
1214 TRACE("%p : stmGetInvariantsToCheck, head was %p",
1215 trec,
1216 trec -> invariants_to_check);
1217
1218 ASSERT(trec != NO_TREC);
1219 ASSERT ((trec -> state == TREC_ACTIVE) ||
1220 (trec -> state == TREC_WAITING) ||
1221 (trec -> state == TREC_CONDEMNED));
1222 ASSERT(trec -> enclosing_trec == NO_TREC);
1223
1224 lock_stm(trec);
1225 c = trec -> current_chunk;
1226 while (c != END_STM_CHUNK_LIST) {
1227 unsigned int i;
1228 for (i = 0; i < c -> next_entry_idx; i ++) {
1229 TRecEntry *e = &(c -> entries[i]);
1230 if (entry_is_update(e)) {
1231 StgTVar *s = e -> tvar;
1232 StgClosure *old = lock_tvar(trec, s);
1233
1234 // Pick up any invariants on the TVar being updated
1235 // by entry "e"
1236
1237 StgTVarWatchQueue *q;
1238 TRACE("%p : checking for invariants on %p", trec, s);
1239 for (q = s -> first_watch_queue_entry;
1240 q != END_STM_WATCH_QUEUE;
1241 q = q -> next_queue_entry) {
1242 if (watcher_is_invariant(q)) {
1243 StgBool found = FALSE;
1244 StgInvariantCheckQueue *q2;
1245 TRACE("%p : Touching invariant %p", trec, q -> closure);
1246 for (q2 = trec -> invariants_to_check;
1247 q2 != END_INVARIANT_CHECK_QUEUE;
1248 q2 = q2 -> next_queue_entry) {
1249 if (q2 -> invariant == (StgAtomicInvariant*)(q -> closure)) {
1250 TRACE("%p : Already found %p", trec, q -> closure);
1251 found = TRUE;
1252 break;
1253 }
1254 }
1255
1256 if (!found) {
1257 StgInvariantCheckQueue *q3;
1258 TRACE("%p : Not already found %p", trec, q -> closure);
1259 q3 = alloc_stg_invariant_check_queue(cap,
1260 (StgAtomicInvariant*) q -> closure);
1261 q3 -> next_queue_entry = trec -> invariants_to_check;
1262 trec -> invariants_to_check = q3;
1263 }
1264 }
1265 }
1266
1267 unlock_tvar(trec, s, old, FALSE);
1268 }
1269 }
1270 c = c -> prev_chunk;
1271 }
1272
1273 unlock_stm(trec);
1274
1275 TRACE("%p : stmGetInvariantsToCheck, head now %p",
1276 trec,
1277 trec -> invariants_to_check);
1278
1279 return (trec -> invariants_to_check);
1280 }
1281
1282 /*......................................................................*/
1283
1284 StgBool stmCommitTransaction(Capability *cap, StgTRecHeader *trec) {
1285 int result;
1286 StgInt64 max_commits_at_start = max_commits;
1287 StgBool touched_invariants;
1288 StgBool use_read_phase;
1289
1290 TRACE("%p : stmCommitTransaction()", trec);
1291 ASSERT (trec != NO_TREC);
1292
1293 lock_stm(trec);
1294
1295 ASSERT (trec -> enclosing_trec == NO_TREC);
1296 ASSERT ((trec -> state == TREC_ACTIVE) ||
1297 (trec -> state == TREC_CONDEMNED));
1298
1299 // touched_invariants is true if we've written to a TVar with invariants
1300 // attached to it, or if we're trying to add a new invariant to the system.
1301
1302 touched_invariants = (trec -> invariants_to_check != END_INVARIANT_CHECK_QUEUE);
1303
1304 // If we have touched invariants then (i) lock the invariant, and (ii) add
1305 // the invariant's read set to our own. Step (i) is needed to serialize
1306 // concurrent transactions that attempt to make conflicting updates
1307 // to the invariant's trec (suppose it read from t1 and t2, and that one
1308 // concurrent transcation writes only to t1, and a second writes only to
1309 // t2). Step (ii) is needed so that both transactions will lock t1 and t2
1310 // to gain access to their wait lists (and hence be able to unhook the
1311 // invariant from both tvars).
1312
1313 if (touched_invariants) {
1314 StgInvariantCheckQueue *q = trec -> invariants_to_check;
1315 TRACE("%p : locking invariants", trec);
1316 while (q != END_INVARIANT_CHECK_QUEUE) {
1317 StgTRecHeader *inv_old_trec;
1318 StgAtomicInvariant *inv;
1319 TRACE("%p : locking invariant %p", trec, q -> invariant);
1320 inv = q -> invariant;
1321 if (!lock_inv(inv)) {
1322 TRACE("%p : failed to lock %p", trec, inv);
1323 trec -> state = TREC_CONDEMNED;
1324 break;
1325 }
1326
1327 inv_old_trec = inv -> last_execution;
1328 if (inv_old_trec != NO_TREC) {
1329 StgTRecChunk *c = inv_old_trec -> current_chunk;
1330 while (c != END_STM_CHUNK_LIST) {
1331 unsigned int i;
1332 for (i = 0; i < c -> next_entry_idx; i ++) {
1333 TRecEntry *e = &(c -> entries[i]);
1334 TRACE("%p : ensuring we lock TVars for %p", trec, e -> tvar);
1335 merge_read_into (cap, trec, e -> tvar, e -> expected_value);
1336 }
1337 c = c -> prev_chunk;
1338 }
1339 }
1340 q = q -> next_queue_entry;
1341 }
1342 TRACE("%p : finished locking invariants", trec);
1343 }
1344
1345 // Use a read-phase (i.e. don't lock TVars we've read but not updated) if
1346 // (i) the configuration lets us use a read phase, and (ii) we've not
1347 // touched or introduced any invariants.
1348 //
1349 // In principle we could extend the implementation to support a read-phase
1350 // and invariants, but it complicates the logic: the links between
1351 // invariants and TVars are managed by the TVar watch queues which are
1352 // protected by the TVar's locks.
1353
1354 use_read_phase = ((config_use_read_phase) && (!touched_invariants));
1355
1356 result = validate_and_acquire_ownership(trec, (!use_read_phase), TRUE);
1357 if (result) {
1358 // We now know that all the updated locations hold their expected values.
1359 ASSERT (trec -> state == TREC_ACTIVE);
1360
1361 if (use_read_phase) {
1362 StgInt64 max_commits_at_end;
1363 StgInt64 max_concurrent_commits;
1364 TRACE("%p : doing read check", trec);
1365 result = check_read_only(trec);
1366 TRACE("%p : read-check %s", trec, result ? "succeeded" : "failed");
1367
1368 max_commits_at_end = max_commits;
1369 max_concurrent_commits = ((max_commits_at_end - max_commits_at_start) +
1370 (n_capabilities * TOKEN_BATCH_SIZE));
1371 if (((max_concurrent_commits >> 32) > 0) || shake()) {
1372 result = FALSE;
1373 }
1374 }
1375
1376 if (result) {
1377 // We now know that all of the read-only locations held their exepcted values
1378 // at the end of the call to validate_and_acquire_ownership. This forms the
1379 // linearization point of the commit.
1380
1381 // 1. If we have touched or introduced any invariants then unhook them
1382 // from the TVars they depended on last time they were executed
1383 // and hook them on the TVars that they now depend on.
1384 if (touched_invariants) {
1385 StgInvariantCheckQueue *q = trec -> invariants_to_check;
1386 while (q != END_INVARIANT_CHECK_QUEUE) {
1387 StgAtomicInvariant *inv = q -> invariant;
1388 if (inv -> last_execution != NO_TREC) {
1389 disconnect_invariant(cap, inv);
1390 }
1391
1392 TRACE("%p : hooking up new execution trec=%p", trec, q -> my_execution);
1393 connect_invariant_to_trec(cap, inv, q -> my_execution);
1394
1395 TRACE("%p : unlocking invariant %p", trec, inv);
1396 unlock_inv(inv);
1397
1398 q = q -> next_queue_entry;
1399 }
1400 }
1401
1402 // 2. Make the updates required by the transaction
1403 FOR_EACH_ENTRY(trec, e, {
1404 StgTVar *s;
1405 s = e -> tvar;
1406 if ((!use_read_phase) || (e -> new_value != e -> expected_value)) {
1407 // Either the entry is an update or we're not using a read phase:
1408 // write the value back to the TVar, unlocking it if necessary.
1409
1410 ACQ_ASSERT(tvar_is_locked(s, trec));
1411 TRACE("%p : writing %p to %p, waking waiters", trec, e -> new_value, s);
1412 unpark_waiters_on(cap,s);
1413 IF_STM_FG_LOCKS({
1414 s -> num_updates ++;
1415 });
1416 unlock_tvar(trec, s, e -> new_value, TRUE);
1417 }
1418 ACQ_ASSERT(!tvar_is_locked(s, trec));
1419 });
1420 } else {
1421 revert_ownership(trec, FALSE);
1422 }
1423 }
1424
1425 unlock_stm(trec);
1426
1427 free_stg_trec_header(cap, trec);
1428
1429 TRACE("%p : stmCommitTransaction()=%d", trec, result);
1430
1431 return result;
1432 }
1433
1434 /*......................................................................*/
1435
1436 StgBool stmCommitNestedTransaction(Capability *cap, StgTRecHeader *trec) {
1437 StgTRecHeader *et;
1438 int result;
1439 ASSERT (trec != NO_TREC && trec -> enclosing_trec != NO_TREC);
1440 TRACE("%p : stmCommitNestedTransaction() into %p", trec, trec -> enclosing_trec);
1441 ASSERT ((trec -> state == TREC_ACTIVE) || (trec -> state == TREC_CONDEMNED));
1442
1443 lock_stm(trec);
1444
1445 et = trec -> enclosing_trec;
1446 result = validate_and_acquire_ownership(trec, (!config_use_read_phase), TRUE);
1447 if (result) {
1448 // We now know that all the updated locations hold their expected values.
1449
1450 if (config_use_read_phase) {
1451 TRACE("%p : doing read check", trec);
1452 result = check_read_only(trec);
1453 }
1454 if (result) {
1455 // We now know that all of the read-only locations held their exepcted values
1456 // at the end of the call to validate_and_acquire_ownership. This forms the
1457 // linearization point of the commit.
1458
1459 TRACE("%p : read-check succeeded", trec);
1460 FOR_EACH_ENTRY(trec, e, {
1461 // Merge each entry into the enclosing transaction record, release all
1462 // locks.
1463
1464 StgTVar *s;
1465 s = e -> tvar;
1466 if (entry_is_update(e)) {
1467 unlock_tvar(trec, s, e -> expected_value, FALSE);
1468 }
1469 merge_update_into(cap, et, s, e -> expected_value, e -> new_value);
1470 ACQ_ASSERT(s -> current_value != (StgClosure *)trec);
1471 });
1472 } else {
1473 revert_ownership(trec, FALSE);
1474 }
1475 }
1476
1477 unlock_stm(trec);
1478
1479 free_stg_trec_header(cap, trec);
1480
1481 TRACE("%p : stmCommitNestedTransaction()=%d", trec, result);
1482
1483 return result;
1484 }
1485
1486 /*......................................................................*/
1487
1488 StgBool stmWait(Capability *cap, StgTSO *tso, StgTRecHeader *trec) {
1489 int result;
1490 TRACE("%p : stmWait(%p)", trec, tso);
1491 ASSERT (trec != NO_TREC);
1492 ASSERT (trec -> enclosing_trec == NO_TREC);
1493 ASSERT ((trec -> state == TREC_ACTIVE) ||
1494 (trec -> state == TREC_CONDEMNED));
1495
1496 lock_stm(trec);
1497 result = validate_and_acquire_ownership(trec, TRUE, TRUE);
1498 if (result) {
1499 // The transaction is valid so far so we can actually start waiting.
1500 // (Otherwise the transaction was not valid and the thread will have to
1501 // retry it).
1502
1503 // Put ourselves to sleep. We retain locks on all the TVars involved
1504 // until we are sound asleep : (a) on the wait queues, (b) BlockedOnSTM
1505 // in the TSO, (c) TREC_WAITING in the Trec.
1506 build_watch_queue_entries_for_trec(cap, tso, trec);
1507 park_tso(tso);
1508 trec -> state = TREC_WAITING;
1509
1510 // We haven't released ownership of the transaction yet. The TSO
1511 // has been put on the wait queue for the TVars it is waiting for,
1512 // but we haven't yet tidied up the TSO's stack and made it safe
1513 // to wake up the TSO. Therefore, we must wait until the TSO is
1514 // safe to wake up before we release ownership - when all is well,
1515 // the runtime will call stmWaitUnlock() below, with the same
1516 // TRec.
1517
1518 } else {
1519 unlock_stm(trec);
1520 free_stg_trec_header(cap, trec);
1521 }
1522
1523 TRACE("%p : stmWait(%p)=%d", trec, tso, result);
1524 return result;
1525 }
1526
1527
1528 void
1529 stmWaitUnlock(Capability *cap STG_UNUSED, StgTRecHeader *trec) {
1530 revert_ownership(trec, TRUE);
1531 unlock_stm(trec);
1532 }
1533
1534 /*......................................................................*/
1535
1536 StgBool stmReWait(Capability *cap, StgTSO *tso) {
1537 int result;
1538 StgTRecHeader *trec = tso->trec;
1539
1540 TRACE("%p : stmReWait", trec);
1541 ASSERT (trec != NO_TREC);
1542 ASSERT (trec -> enclosing_trec == NO_TREC);
1543 ASSERT ((trec -> state == TREC_WAITING) ||
1544 (trec -> state == TREC_CONDEMNED));
1545
1546 lock_stm(trec);
1547 result = validate_and_acquire_ownership(trec, TRUE, TRUE);
1548 TRACE("%p : validation %s", trec, result ? "succeeded" : "failed");
1549 if (result) {
1550 // The transaction remains valid -- do nothing because it is already on
1551 // the wait queues
1552 ASSERT (trec -> state == TREC_WAITING);
1553 park_tso(tso);
1554 revert_ownership(trec, TRUE);
1555 } else {
1556 // The transcation has become invalid. We can now remove it from the wait
1557 // queues.
1558 if (trec -> state != TREC_CONDEMNED) {
1559 remove_watch_queue_entries_for_trec (cap, trec);
1560 }
1561 free_stg_trec_header(cap, trec);
1562 }
1563 unlock_stm(trec);
1564
1565 TRACE("%p : stmReWait()=%d", trec, result);
1566 return result;
1567 }
1568
1569 /*......................................................................*/
1570
1571 static StgClosure *read_current_value(StgTRecHeader *trec STG_UNUSED, StgTVar *tvar) {
1572 StgClosure *result;
1573 result = tvar -> current_value;
1574
1575 #if defined(STM_FG_LOCKS)
1576 while (GET_INFO(UNTAG_CLOSURE(result)) == &stg_TREC_HEADER_info) {
1577 TRACE("%p : read_current_value(%p) saw %p", trec, tvar, result);
1578 result = tvar -> current_value;
1579 }
1580 #endif
1581
1582 TRACE("%p : read_current_value(%p)=%p", trec, tvar, result);
1583 return result;
1584 }
1585
1586 /*......................................................................*/
1587
1588 StgClosure *stmReadTVar(Capability *cap,
1589 StgTRecHeader *trec,
1590 StgTVar *tvar) {
1591 StgTRecHeader *entry_in = NULL;
1592 StgClosure *result = NULL;
1593 TRecEntry *entry = NULL;
1594 TRACE("%p : stmReadTVar(%p)", trec, tvar);
1595 ASSERT (trec != NO_TREC);
1596 ASSERT (trec -> state == TREC_ACTIVE ||
1597 trec -> state == TREC_CONDEMNED);
1598
1599 entry = get_entry_for(trec, tvar, &entry_in);
1600
1601 if (entry != NULL) {
1602 if (entry_in == trec) {
1603 // Entry found in our trec
1604 result = entry -> new_value;
1605 } else {
1606 // Entry found in another trec
1607 TRecEntry *new_entry = get_new_entry(cap, trec);
1608 new_entry -> tvar = tvar;
1609 new_entry -> expected_value = entry -> expected_value;
1610 new_entry -> new_value = entry -> new_value;
1611 result = new_entry -> new_value;
1612 }
1613 } else {
1614 // No entry found
1615 StgClosure *current_value = read_current_value(trec, tvar);
1616 TRecEntry *new_entry = get_new_entry(cap, trec);
1617 new_entry -> tvar = tvar;
1618 new_entry -> expected_value = current_value;
1619 new_entry -> new_value = current_value;
1620 result = current_value;
1621 }
1622
1623 TRACE("%p : stmReadTVar(%p)=%p", trec, tvar, result);
1624 return result;
1625 }
1626
1627 /*......................................................................*/
1628
1629 void stmWriteTVar(Capability *cap,
1630 StgTRecHeader *trec,
1631 StgTVar *tvar,
1632 StgClosure *new_value) {
1633
1634 StgTRecHeader *entry_in = NULL;
1635 TRecEntry *entry = NULL;
1636 TRACE("%p : stmWriteTVar(%p, %p)", trec, tvar, new_value);
1637 ASSERT (trec != NO_TREC);
1638 ASSERT (trec -> state == TREC_ACTIVE ||
1639 trec -> state == TREC_CONDEMNED);
1640
1641 entry = get_entry_for(trec, tvar, &entry_in);
1642
1643 if (entry != NULL) {
1644 if (entry_in == trec) {
1645 // Entry found in our trec
1646 entry -> new_value = new_value;
1647 } else {
1648 // Entry found in another trec
1649 TRecEntry *new_entry = get_new_entry(cap, trec);
1650 new_entry -> tvar = tvar;
1651 new_entry -> expected_value = entry -> expected_value;
1652 new_entry -> new_value = new_value;
1653 }
1654 } else {
1655 // No entry found
1656 StgClosure *current_value = read_current_value(trec, tvar);
1657 TRecEntry *new_entry = get_new_entry(cap, trec);
1658 new_entry -> tvar = tvar;
1659 new_entry -> expected_value = current_value;
1660 new_entry -> new_value = new_value;
1661 }
1662
1663 TRACE("%p : stmWriteTVar done", trec);
1664 }
1665
1666 /*......................................................................*/
1667
1668 StgTVar *stmNewTVar(Capability *cap,
1669 StgClosure *new_value) {
1670 StgTVar *result;
1671 result = (StgTVar *)allocateLocal(cap, sizeofW(StgTVar));
1672 SET_HDR (result, &stg_TVAR_info, CCS_SYSTEM);
1673 result -> current_value = new_value;
1674 result -> first_watch_queue_entry = END_STM_WATCH_QUEUE;
1675 #if defined(THREADED_RTS)
1676 result -> num_updates = 0;
1677 #endif
1678 return result;
1679 }
1680
1681 /*......................................................................*/