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 /*......................................................................*/