PrimOps.cmm 53.4 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29
/* -----------------------------------------------------------------------------
 *
 * (c) The GHC Team, 1998-2004
 *
 * Out-of-line primitive operations
 *
 * This file contains the implementations of all the primitive
 * operations ("primops") which are not expanded inline.  See
 * ghc/compiler/prelude/primops.txt.pp for a list of all the primops;
 * this file contains code for most of those with the attribute
 * out_of_line=True.
 *
 * Entry convention: the entry convention for a primop is that all the
 * args are in Stg registers (R1, R2, etc.).  This is to make writing
 * the primops easier.  (see compiler/codeGen/CgCallConv.hs).
 *
 * Return convention: results from a primop are generally returned
 * using the ordinary unboxed tuple return convention.  The C-- parser
 * implements the RET_xxxx() macros to perform unboxed-tuple returns
 * based on the prevailing return convention.
 *
 * This file is written in a subset of C--, extended with various
 * features specific to GHC.  It is compiled by GHC directly.  For the
 * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
 *
 * ---------------------------------------------------------------------------*/

#include "Cmm.h"

30
#ifdef __PIC__
31 32
import pthread_mutex_lock;
import pthread_mutex_unlock;
33
#endif
34
import base_ControlziExceptionziBase_nestedAtomically_closure;
35 36
import EnterCriticalSection;
import LeaveCriticalSection;
37
import ghczmprim_GHCziBool_False_closure;
38

39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
/*-----------------------------------------------------------------------------
  Array Primitives

  Basically just new*Array - the others are all inline macros.

  The size arg is always passed in R1, and the result returned in R1.

  The slow entry point is for returning from a heap check, the saved
  size argument must be re-loaded from the stack.
  -------------------------------------------------------------------------- */

/* for objects that are *less* than the size of a word, make sure we
 * round up to the nearest word for the size of the array.
 */

54
stg_newByteArrayzh
55 56
{
    W_ words, payload_words, n, p;
57
    MAYBE_GC(NO_PTRS,stg_newByteArrayzh);
58 59 60
    n = R1;
    payload_words = ROUNDUP_BYTES_TO_WDS(n);
    words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
61
    ("ptr" p) = foreign "C" allocate(MyCapability() "ptr",words) [];
62 63 64 65 66 67
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
    StgArrWords_words(p) = payload_words;
    RET_P(p);
}

Simon Marlow's avatar
Simon Marlow committed
68 69 70
#define BA_ALIGN 16
#define BA_MASK  (BA_ALIGN-1)

71
stg_newPinnedByteArrayzh
72
{
73
    W_ words, bytes, payload_words, p;
74

75
    MAYBE_GC(NO_PTRS,stg_newPinnedByteArrayzh);
76 77 78 79 80 81 82 83 84 85 86
    bytes = R1;
    /* payload_words is what we will tell the profiler we had to allocate */
    payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
    /* When we actually allocate memory, we need to allow space for the
       header: */
    bytes = bytes + SIZEOF_StgArrWords;
    /* And we want to align to BA_ALIGN bytes, so we need to allow space
       to shift up to BA_ALIGN - 1 bytes: */
    bytes = bytes + BA_ALIGN - 1;
    /* Now we convert to a number of words: */
    words = ROUNDUP_BYTES_TO_WDS(bytes);
Simon Marlow's avatar
Simon Marlow committed
87

88
    ("ptr" p) = foreign "C" allocatePinned(MyCapability() "ptr", words) [];
Simon Marlow's avatar
Simon Marlow committed
89 90
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);

91 92
    /* Now we need to move p forward so that the payload is aligned
       to BA_ALIGN bytes: */
Simon Marlow's avatar
Simon Marlow committed
93 94 95 96 97 98 99
    p = p + ((-p - SIZEOF_StgArrWords) & BA_MASK);

    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
    StgArrWords_words(p) = payload_words;
    RET_P(p);
}

100
stg_newAlignedPinnedByteArrayzh
Simon Marlow's avatar
Simon Marlow committed
101
{
102
    W_ words, bytes, payload_words, p, alignment;
Simon Marlow's avatar
Simon Marlow committed
103

104
    MAYBE_GC(NO_PTRS,stg_newAlignedPinnedByteArrayzh);
105 106
    bytes = R1;
    alignment = R2;
Simon Marlow's avatar
Simon Marlow committed
107

108 109
    /* payload_words is what we will tell the profiler we had to allocate */
    payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
Simon Marlow's avatar
Simon Marlow committed
110

111 112 113 114 115 116 117 118
    /* When we actually allocate memory, we need to allow space for the
       header: */
    bytes = bytes + SIZEOF_StgArrWords;
    /* And we want to align to <alignment> bytes, so we need to allow space
       to shift up to <alignment - 1> bytes: */
    bytes = bytes + alignment - 1;
    /* Now we convert to a number of words: */
    words = ROUNDUP_BYTES_TO_WDS(bytes);
119

120
    ("ptr" p) = foreign "C" allocatePinned(MyCapability() "ptr", words) [];
121 122
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);

123 124 125 126
    /* Now we need to move p forward so that the payload is aligned
       to <alignment> bytes. Note that we are assuming that
       <alignment> is a power of 2, which is technically not guaranteed */
    p = p + ((-p - SIZEOF_StgArrWords) & (alignment - 1));
127 128 129 130 131 132

    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
    StgArrWords_words(p) = payload_words;
    RET_P(p);
}

133
stg_newArrayzh
134
{
135
    W_ words, n, init, arr, p, size;
136 137 138
    /* Args: R1 = words, R2 = initialisation value */

    n = R1;
139
    MAYBE_GC(R2_PTR,stg_newArrayzh);
140

141 142 143 144 145
    // the mark area contains one byte for each 2^MUT_ARR_PTRS_CARD_BITS words
    // in the array, making sure we round up, and then rounding up to a whole
    // number of words.
    size = n + mutArrPtrsCardWords(n);
    words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size;
146
    ("ptr" arr) = foreign "C" allocate(MyCapability() "ptr",words) [R2];
147 148
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);

149
    SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, W_[CCCS]);
150
    StgMutArrPtrs_ptrs(arr) = n;
151
    StgMutArrPtrs_size(arr) = size;
152 153 154 155 156 157 158 159 160 161

    // Initialise all elements of the the array with the value in R2
    init = R2;
    p = arr + SIZEOF_StgMutArrPtrs;
  for:
    if (p < arr + WDS(words)) {
	W_[p] = init;
	p = p + WDS(1);
	goto for;
    }
162 163 164 165 166 167 168
    // Initialise the mark bits with 0
  for2:
    if (p < arr + WDS(size)) {
	W_[p] = 0;
	p = p + WDS(1);
	goto for2;
    }
169 170 171 172

    RET_P(arr);
}

173
stg_unsafeThawArrayzh
174 175 176 177 178 179
{
  // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST
  //
  // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN 
  // normally doesn't.  However, when we freeze a MUT_ARR_PTRS, we leave
  // it on the mutable list for the GC to remove (removing something from
180
  // the mutable list is not easy).
181
  // 
182
  // So that we can tell whether a MUT_ARR_PTRS_FROZEN is on the mutable list,
183 184 185
  // when we freeze it we set the info ptr to be MUT_ARR_PTRS_FROZEN0
  // to indicate that it is still on the mutable list.
  //
186 187
  // So, when we thaw a MUT_ARR_PTRS_FROZEN, we must cope with two cases:
  // either it is on a mut_list, or it isn't.  We adopt the convention that
188
  // the closure type is MUT_ARR_PTRS_FROZEN0 if it is on the mutable list,
189 190 191
  // and MUT_ARR_PTRS_FROZEN otherwise.  In fact it wouldn't matter if
  // we put it on the mutable list more than once, but it would get scavenged
  // multiple times during GC, which would be unnecessarily slow.
192
  //
193
  if (StgHeader_info(R1) != stg_MUT_ARR_PTRS_FROZEN0_info) {
194
	SET_INFO(R1,stg_MUT_ARR_PTRS_DIRTY_info);
195
	recordMutable(R1, R1);
196 197 198
	// must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
	RET_P(R1);
  } else {
199
	SET_INFO(R1,stg_MUT_ARR_PTRS_DIRTY_info);
200
	RET_P(R1);
201 202 203 204 205 206 207
  }
}

/* -----------------------------------------------------------------------------
   MutVar primitives
   -------------------------------------------------------------------------- */

208
stg_newMutVarzh
209 210 211 212
{
    W_ mv;
    /* Args: R1 = initialisation value */

213
    ALLOC_PRIM( SIZEOF_StgMutVar, R1_PTR, stg_newMutVarzh);
214 215

    mv = Hp - SIZEOF_StgMutVar + WDS(1);
216
    SET_HDR(mv,stg_MUT_VAR_DIRTY_info,W_[CCCS]);
217 218 219 220 221
    StgMutVar_var(mv) = R1;
    
    RET_P(mv);
}

222
stg_atomicModifyMutVarzh
223
{
224
    W_ mv, f, z, x, y, r, h;
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243
    /* Args: R1 :: MutVar#,  R2 :: a -> (a,b) */

    /* If x is the current contents of the MutVar#, then 
       We want to make the new contents point to

         (sel_0 (f x))
 
       and the return value is
	 
	 (sel_1 (f x))

        obviously we can share (f x).

         z = [stg_ap_2 f x]  (max (HS + 2) MIN_UPD_SIZE)
	 y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
         r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
    */

#if MIN_UPD_SIZE > 1
244
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
245 246
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
#else
247
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
248 249 250 251
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
#endif

#if MIN_UPD_SIZE > 2
252
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
253 254
#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
#else
255
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(2))
256 257 258 259 260
#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),0)
#endif

#define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)

261
   HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, stg_atomicModifyMutVarzh);
262

263 264
   mv = R1;
   f = R2;
265 266 267 268 269 270

   TICK_ALLOC_THUNK_2();
   CCCS_ALLOC(THUNK_2_SIZE);
   z = Hp - THUNK_2_SIZE + WDS(1);
   SET_HDR(z, stg_ap_2_upd_info, W_[CCCS]);
   LDV_RECORD_CREATE(z);
271
   StgThunk_payload(z,0) = f;
272 273 274 275 276 277

   TICK_ALLOC_THUNK_1();
   CCCS_ALLOC(THUNK_1_SIZE);
   y = z - THUNK_1_SIZE;
   SET_HDR(y, stg_sel_0_upd_info, W_[CCCS]);
   LDV_RECORD_CREATE(y);
278
   StgThunk_payload(y,0) = z;
279 280 281 282 283 284

   TICK_ALLOC_THUNK_1();
   CCCS_ALLOC(THUNK_1_SIZE);
   r = y - THUNK_1_SIZE;
   SET_HDR(r, stg_sel_1_upd_info, W_[CCCS]);
   LDV_RECORD_CREATE(r);
285 286
   StgThunk_payload(r,0) = z;

287 288 289 290 291 292 293 294
 retry:
   x = StgMutVar_var(mv);
   StgThunk_payload(z,1) = x;
#ifdef THREADED_RTS
   (h) = foreign "C" cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y) [];
   if (h != x) { goto retry; }
#else
   StgMutVar_var(mv) = y;
295
#endif
296

297 298 299 300
   if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
     foreign "C" dirty_MUT_VAR(BaseReg "ptr", mv "ptr") [];
   }

301 302 303 304 305 306 307 308 309
   RET_P(r);
}

/* -----------------------------------------------------------------------------
   Weak Pointer Primitives
   -------------------------------------------------------------------------- */

STRING(stg_weak_msg,"New weak pointer at %p\n")

310
stg_mkWeakzh
311 312 313 314 315 316 317 318 319 320 321
{
  /* R1 = key
     R2 = value
     R3 = finalizer (or NULL)
  */
  W_ w;

  if (R3 == NULL) {
    R3 = stg_NO_FINALIZER_closure;
  }

322
  ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, stg_mkWeakzh );
323 324 325 326

  w = Hp - SIZEOF_StgWeak + WDS(1);
  SET_HDR(w, stg_WEAK_info, W_[CCCS]);

327 328 329 330 331 332 333 334
  // We don't care about cfinalizer here.
  // Should StgWeak_cfinalizer(w) be stg_NO_FINALIZER_closure or
  // something else?

  StgWeak_key(w)        = R1;
  StgWeak_value(w)      = R2;
  StgWeak_finalizer(w)  = R3;
  StgWeak_cfinalizer(w) = stg_NO_FINALIZER_closure;
335

336
  ACQUIRE_LOCK(sm_mutex);
337 338
  StgWeak_link(w)	= W_[weak_ptr_list];
  W_[weak_ptr_list] 	= w;
339
  RELEASE_LOCK(sm_mutex);
340

341
  IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);
342 343 344 345

  RET_P(w);
}

346
stg_mkWeakForeignEnvzh
347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365
{
  /* R1 = key
     R2 = value
     R3 = finalizer
     R4 = pointer
     R5 = has environment (0 or 1)
     R6 = environment
  */
  W_ w, payload_words, words, p;

  W_ key, val, fptr, ptr, flag, eptr;

  key  = R1;
  val  = R2;
  fptr = R3;
  ptr  = R4;
  flag = R5;
  eptr = R6;

366
  ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR, stg_mkWeakForeignEnvzh );
367 368 369 370 371 372

  w = Hp - SIZEOF_StgWeak + WDS(1);
  SET_HDR(w, stg_WEAK_info, W_[CCCS]);

  payload_words = 4;
  words         = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
373
  ("ptr" p)     = foreign "C" allocate(MyCapability() "ptr", words) [];
374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391

  TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
  SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);

  StgArrWords_words(p)     = payload_words;
  StgArrWords_payload(p,0) = fptr;
  StgArrWords_payload(p,1) = ptr;
  StgArrWords_payload(p,2) = eptr;
  StgArrWords_payload(p,3) = flag;

  // We don't care about the value here.
  // Should StgWeak_value(w) be stg_NO_FINALIZER_closure or something else?

  StgWeak_key(w)        = key;
  StgWeak_value(w)      = val;
  StgWeak_finalizer(w)  = stg_NO_FINALIZER_closure;
  StgWeak_cfinalizer(w) = p;

392
  ACQUIRE_LOCK(sm_mutex);
393 394
  StgWeak_link(w)   = W_[weak_ptr_list];
  W_[weak_ptr_list] = w;
395
  RELEASE_LOCK(sm_mutex);
396 397 398 399 400

  IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);

  RET_P(w);
}
401

402
stg_finalizzeWeakzh
403 404 405
{
  /* R1 = weak ptr
   */
406
  W_ w, f, arr;
407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433

  w = R1;

  // already dead?
  if (GET_INFO(w) == stg_DEAD_WEAK_info) {
      RET_NP(0,stg_NO_FINALIZER_closure);
  }

  // kill it
#ifdef PROFILING
  // @LDV profiling
  // A weak pointer is inherently used, so we do not need to call
  // LDV_recordDead_FILL_SLOP_DYNAMIC():
  //    LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
  // or, LDV_recordDead():
  //    LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
  // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as 
  // large as weak pointers, so there is no need to fill the slop, either.
  // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
#endif

  //
  // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
  //
  SET_INFO(w,stg_DEAD_WEAK_info);
  LDV_RECORD_CREATE(w);

434 435 436
  f   = StgWeak_finalizer(w);
  arr = StgWeak_cfinalizer(w);

437
  StgDeadWeak_link(w) = StgWeak_link(w);
438

439 440 441 442 443 444 445
  if (arr != stg_NO_FINALIZER_closure) {
    foreign "C" runCFinalizer(StgArrWords_payload(arr,0),
                              StgArrWords_payload(arr,1),
                              StgArrWords_payload(arr,2),
                              StgArrWords_payload(arr,3)) [];
  }

446 447 448 449 450 451 452 453
  /* return the finalizer */
  if (f == stg_NO_FINALIZER_closure) {
      RET_NP(0,stg_NO_FINALIZER_closure);
  } else {
      RET_NP(1,f);
  }
}

454
stg_deRefWeakzh
455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470
{
  /* R1 = weak ptr */
  W_ w, code, val;

  w = R1;
  if (GET_INFO(w) == stg_WEAK_info) {
    code = 1;
    val = StgWeak_value(w);
  } else {
    code = 0;
    val = w;
  }
  RET_NP(code,val);
}

/* -----------------------------------------------------------------------------
471
   Floating point operations.
472 473
   -------------------------------------------------------------------------- */

474
stg_decodeFloatzuIntzh
475 476 477
{ 
    W_ p;
    F_ arg;
478 479 480
    W_ mp_tmp1;
    W_ mp_tmp_w;

481
    STK_CHK_GEN( WDS(2), NO_PTRS, stg_decodeFloatzuIntzh );
482 483 484

    mp_tmp1  = Sp - WDS(1);
    mp_tmp_w = Sp - WDS(2);
485 486 487 488 489 490 491 492 493 494 495
    
    /* arguments: F1 = Float# */
    arg = F1;
    
    /* Perform the operation */
    foreign "C" __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg) [];
    
    /* returns: (Int# (mantissa), Int# (exponent)) */
    RET_NN(W_[mp_tmp1], W_[mp_tmp_w]);
}

496
stg_decodeDoublezu2Intzh
497 498 499
{ 
    D_ arg;
    W_ p;
500 501 502 503 504
    W_ mp_tmp1;
    W_ mp_tmp2;
    W_ mp_result1;
    W_ mp_result2;

505
    STK_CHK_GEN( WDS(4), NO_PTRS, stg_decodeDoublezu2Intzh );
506 507 508 509 510

    mp_tmp1    = Sp - WDS(1);
    mp_tmp2    = Sp - WDS(2);
    mp_result1 = Sp - WDS(3);
    mp_result2 = Sp - WDS(4);
511 512 513 514 515

    /* arguments: D1 = Double# */
    arg = D1;

    /* Perform the operation */
516 517 518 519 520 521 522
    foreign "C" __decodeDouble_2Int(mp_tmp1 "ptr", mp_tmp2 "ptr",
                                    mp_result1 "ptr", mp_result2 "ptr",
                                    arg) [];

    /* returns:
       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
    RET_NNNN(W_[mp_tmp1], W_[mp_tmp2], W_[mp_result1], W_[mp_result2]);
523 524
}

525 526 527 528
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

529
stg_forkzh
530 531
{
  /* args: R1 = closure to spark */
532

533
  MAYBE_GC(R1_PTR, stg_forkzh);
534

535 536 537 538
  W_ closure;
  W_ threadid;
  closure = R1;

539
  ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr", 
540 541
				RtsFlags_GcFlags_initialStkSize(RtsFlags), 
				closure "ptr") [];
542 543 544 545 546 547

  /* start blocked if the current thread is blocked */
  StgTSO_flags(threadid) = 
     StgTSO_flags(threadid) |  (StgTSO_flags(CurrentTSO) & 
                                (TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32));

548 549
  foreign "C" scheduleThread(MyCapability() "ptr", threadid "ptr") [];

550 551
  // context switch soon, but not immediately: we don't want every
  // forkIO to force a context-switch.
552
  Capability_context_switch(MyCapability()) = 1 :: CInt;
553 554 555 556
  
  RET_P(threadid);
}

557
stg_forkOnzh
558 559 560
{
  /* args: R1 = cpu, R2 = closure to spark */

561
  MAYBE_GC(R2_PTR, stg_forkOnzh);
562 563 564 565 566 567 568

  W_ cpu;
  W_ closure;
  W_ threadid;
  cpu = R1;
  closure = R2;

569
  ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr", 
570
				RtsFlags_GcFlags_initialStkSize(RtsFlags), 
571
				closure "ptr") [];
572 573 574 575 576 577

  /* start blocked if the current thread is blocked */
  StgTSO_flags(threadid) = 
     StgTSO_flags(threadid) |  (StgTSO_flags(CurrentTSO) & 
                                (TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32));

578
  foreign "C" scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr") [];
579

580 581
  // context switch soon, but not immediately: we don't want every
  // forkIO to force a context-switch.
582
  Capability_context_switch(MyCapability()) = 1 :: CInt;
583
  
584
  RET_P(threadid);
585 586
}

587
stg_yieldzh
588 589 590 591
{
  jump stg_yield_noregs;
}

592
stg_myThreadIdzh
593 594 595 596 597
{
  /* no args. */
  RET_P(CurrentTSO);
}

598
stg_labelThreadzh
599 600 601 602 603
{
  /* args: 
	R1 = ThreadId#
	R2 = Addr# */
#ifdef DEBUG
604
  foreign "C" labelThread(R1 "ptr", R2 "ptr") [];
605 606 607 608
#endif
  jump %ENTRY_CODE(Sp(0));
}

609
stg_isCurrentThreadBoundzh
610 611 612
{
  /* no args */
  W_ r;
613
  (r) = foreign "C" isThreadBound(CurrentTSO) [];
614 615 616
  RET_N(r);
}

617
stg_threadStatuszh
618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649
{
    /* args: R1 :: ThreadId# */
    W_ tso;
    W_ why_blocked;
    W_ what_next;
    W_ ret;

    tso = R1;
    loop:
      if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) {
          tso = StgTSO__link(tso);
          goto loop;
      }

    what_next   = TO_W_(StgTSO_what_next(tso));
    why_blocked = TO_W_(StgTSO_why_blocked(tso));
    // Note: these two reads are not atomic, so they might end up
    // being inconsistent.  It doesn't matter, since we
    // only return one or the other.  If we wanted to return the
    // contents of block_info too, then we'd have to do some synchronisation.

    if (what_next == ThreadComplete) {
        ret = 16;  // NB. magic, matches up with GHC.Conc.threadStatus
    } else {
        if (what_next == ThreadKilled) {
            ret = 17;
        } else {
            ret = why_blocked;
        }
    }
    RET_N(ret);
}
650 651 652 653 654 655 656 657 658

/* -----------------------------------------------------------------------------
 * TVar primitives
 * -------------------------------------------------------------------------- */

#define SP_OFF 0

// Catch retry frame ------------------------------------------------------------

659
INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
660
#if defined(PROFILING)
661
  W_ unused1, W_ unused2,
662
#endif
663
  W_ unused3, P_ unused4, P_ unused5)
664 665 666 667 668
{
   W_ r, frame, trec, outer;

   frame = Sp;
   trec = StgTSO_trec(CurrentTSO);
669
   outer  = StgTRecHeader_enclosing_trec(trec);
670
   (r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
Simon Marlow's avatar
Simon Marlow committed
671
   if (r != 0) {
672 673 674 675 676
     /* Succeeded (either first branch or second branch) */
     StgTSO_trec(CurrentTSO) = outer;
     Sp = Sp + SIZEOF_StgCatchRetryFrame;
     jump %ENTRY_CODE(Sp(SP_OFF));
   } else {
tharris@microsoft.com's avatar
tharris@microsoft.com committed
677
     /* Did not commit: re-execute */
678
     W_ new_trec;
679
     ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
680
     StgTSO_trec(CurrentTSO) = new_trec;
Simon Marlow's avatar
Simon Marlow committed
681
     if (StgCatchRetryFrame_running_alt_code(frame) != 0::I32) {
682 683 684 685
       R1 = StgCatchRetryFrame_alt_code(frame);
     } else {
       R1 = StgCatchRetryFrame_first_code(frame);
     }
686
     jump stg_ap_v_fast;
687 688
   }
}
689 690


Simon Marlow's avatar
Simon Marlow committed
691
// Atomically frame ------------------------------------------------------------
692

693
INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
694
#if defined(PROFILING)
695
  W_ unused1, W_ unused2,
696
#endif
697
  P_ code, P_ next_invariant_to_check, P_ result)
698
{
tharris@microsoft.com's avatar
tharris@microsoft.com committed
699
  W_ frame, trec, valid, next_invariant, q, outer;
700

701 702 703
  frame  = Sp;
  trec   = StgTSO_trec(CurrentTSO);
  result = R1;
704
  outer  = StgTRecHeader_enclosing_trec(trec);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
705 706 707

  if (outer == NO_TREC) {
    /* First time back at the atomically frame -- pick up invariants */
708
    ("ptr" q) = foreign "C" stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr") [];
tharris@microsoft.com's avatar
tharris@microsoft.com committed
709
    StgAtomicallyFrame_next_invariant_to_check(frame) = q;
710
    StgAtomicallyFrame_result(frame) = result;
711 712

  } else {
tharris@microsoft.com's avatar
tharris@microsoft.com committed
713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729
    /* Second/subsequent time back at the atomically frame -- abort the
     * tx that's checking the invariant and move on to the next one */
    StgTSO_trec(CurrentTSO) = outer;
    q = StgAtomicallyFrame_next_invariant_to_check(frame);
    StgInvariantCheckQueue_my_execution(q) = trec;
    foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
    /* Don't free trec -- it's linked from q and will be stashed in the
     * invariant if we eventually commit. */
    q = StgInvariantCheckQueue_next_queue_entry(q);
    StgAtomicallyFrame_next_invariant_to_check(frame) = q;
    trec = outer;
  }

  q = StgAtomicallyFrame_next_invariant_to_check(frame);

  if (q != END_INVARIANT_CHECK_QUEUE) {
    /* We can't commit yet: another invariant to check */
730
    ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [];
731
    StgTSO_trec(CurrentTSO) = trec;
tharris@microsoft.com's avatar
tharris@microsoft.com committed
732 733 734

    next_invariant = StgInvariantCheckQueue_invariant(q);
    R1 = StgAtomicInvariant_code(next_invariant);
735
    jump stg_ap_v_fast;
tharris@microsoft.com's avatar
tharris@microsoft.com committed
736 737 738 739

  } else {

    /* We've got no more invariants to check, try to commit */
740
    (valid) = foreign "C" stmCommitTransaction(MyCapability() "ptr", trec "ptr") [];
tharris@microsoft.com's avatar
tharris@microsoft.com committed
741 742 743
    if (valid != 0) {
      /* Transaction was valid: commit succeeded */
      StgTSO_trec(CurrentTSO) = NO_TREC;
744
      R1 = StgAtomicallyFrame_result(frame);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
745 746 747 748
      Sp = Sp + SIZEOF_StgAtomicallyFrame;
      jump %ENTRY_CODE(Sp(SP_OFF));
    } else {
      /* Transaction was not valid: try again */
749
      ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
tharris@microsoft.com's avatar
tharris@microsoft.com committed
750 751 752 753 754
      StgTSO_trec(CurrentTSO) = trec;
      StgAtomicallyFrame_next_invariant_to_check(frame) = END_INVARIANT_CHECK_QUEUE;
      R1 = StgAtomicallyFrame_code(frame);
      jump stg_ap_v_fast;
    }
755 756 757
  }
}

758 759 760 761
INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME,
#if defined(PROFILING)
  W_ unused1, W_ unused2,
#endif
762
  P_ code, P_ next_invariant_to_check, P_ result)
763 764 765 766 767 768
{
  W_ frame, trec, valid;

  frame = Sp;

  /* The TSO is currently waiting: should we stop waiting? */
769
  (valid) = foreign "C" stmReWait(MyCapability() "ptr", CurrentTSO "ptr") [];
Simon Marlow's avatar
Simon Marlow committed
770
  if (valid != 0) {
771 772 773 774
    /* Previous attempt is still valid: no point trying again yet */
    jump stg_block_noregs;
  } else {
    /* Previous attempt is no longer valid: try again */
775
    ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
776 777 778
    StgTSO_trec(CurrentTSO) = trec;
    StgHeader_info(frame) = stg_atomically_frame_info;
    R1 = StgAtomicallyFrame_code(frame);
779
    jump stg_ap_v_fast;
780
  }
781
}
782 783 784 785 786 787 788 789 790 791

// STM catch frame --------------------------------------------------------------

#define SP_OFF 0

/* Catch frames are very similar to update frames, but when entering
 * one we just pop the frame off the stack and perform the correct
 * kind of return to the activation record underneath us on the stack.
 */

792 793 794 795
INFO_TABLE_RET(stg_catch_stm_frame, CATCH_STM_FRAME,
#if defined(PROFILING)
  W_ unused1, W_ unused2,
#endif
796
  P_ unused3, P_ unused4)
Simon Marlow's avatar
Simon Marlow committed
797 798 799 800
   {
      W_ r, frame, trec, outer;
      frame = Sp;
      trec = StgTSO_trec(CurrentTSO);
801
      outer  = StgTRecHeader_enclosing_trec(trec);
802
      (r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
Simon Marlow's avatar
Simon Marlow committed
803 804 805 806 807 808 809 810
      if (r != 0) {
        /* Commit succeeded */
        StgTSO_trec(CurrentTSO) = outer;
        Sp = Sp + SIZEOF_StgCatchSTMFrame;
        jump Sp(SP_OFF);
      } else {
        /* Commit failed */
        W_ new_trec;
811
        ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
Simon Marlow's avatar
Simon Marlow committed
812 813 814 815 816
        StgTSO_trec(CurrentTSO) = new_trec;
        R1 = StgCatchSTMFrame_code(frame);
        jump stg_ap_v_fast;
      }
   }
817 818 819 820


// Primop definition ------------------------------------------------------------

821
stg_atomicallyzh
822 823 824 825 826
{
  W_ frame;
  W_ old_trec;
  W_ new_trec;
  
827
  // stmStartTransaction may allocate
828
  MAYBE_GC (R1_PTR, stg_atomicallyzh); 
829

830
  /* Args: R1 = m :: STM a */
831
  STK_CHK_GEN(SIZEOF_StgAtomicallyFrame + WDS(1), R1_PTR, stg_atomicallyzh);
832

833 834 835 836
  old_trec = StgTSO_trec(CurrentTSO);

  /* Nested transactions are not allowed; raise an exception */
  if (old_trec != NO_TREC) {
837
     R1 = base_ControlziExceptionziBase_nestedAtomically_closure;
838
     jump stg_raisezh;
839 840
  }

841 842 843 844
  /* Set up the atomically frame */
  Sp = Sp - SIZEOF_StgAtomicallyFrame;
  frame = Sp;

845
  SET_HDR(frame,stg_atomically_frame_info, W_[CCCS]);
846
  StgAtomicallyFrame_code(frame) = R1;
847
  StgAtomicallyFrame_result(frame) = NO_TREC;
tharris@microsoft.com's avatar
tharris@microsoft.com committed
848
  StgAtomicallyFrame_next_invariant_to_check(frame) = END_INVARIANT_CHECK_QUEUE;
849 850

  /* Start the memory transcation */
851
  ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", old_trec "ptr") [R1];
852 853 854
  StgTSO_trec(CurrentTSO) = new_trec;

  /* Apply R1 to the realworld token */
855
  jump stg_ap_v_fast;
856 857 858
}


859
stg_catchSTMzh
860 861 862 863 864
{
  W_ frame;
  
  /* Args: R1 :: STM a */
  /* Args: R2 :: Exception -> STM a */
865
  STK_CHK_GEN(SIZEOF_StgCatchSTMFrame + WDS(1), R1_PTR & R2_PTR, stg_catchSTMzh);
866 867 868 869 870

  /* Set up the catch frame */
  Sp = Sp - SIZEOF_StgCatchSTMFrame;
  frame = Sp;

871
  SET_HDR(frame, stg_catch_stm_frame_info, W_[CCCS]);
872
  StgCatchSTMFrame_handler(frame) = R2;
tharris@microsoft.com's avatar
tharris@microsoft.com committed
873 874 875 876 877 878
  StgCatchSTMFrame_code(frame) = R1;

  /* Start a nested transaction to run the body of the try block in */
  W_ cur_trec;  
  W_ new_trec;
  cur_trec = StgTSO_trec(CurrentTSO);
879
  ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", cur_trec "ptr");
tharris@microsoft.com's avatar
tharris@microsoft.com committed
880
  StgTSO_trec(CurrentTSO) = new_trec;
881 882

  /* Apply R1 to the realworld token */
883
  jump stg_ap_v_fast;
884 885 886
}


887
stg_catchRetryzh
888 889 890 891 892
{
  W_ frame;
  W_ new_trec;
  W_ trec;

893
  // stmStartTransaction may allocate
894
  MAYBE_GC (R1_PTR & R2_PTR, stg_catchRetryzh); 
895

896 897
  /* Args: R1 :: STM a */
  /* Args: R2 :: STM a */
898
  STK_CHK_GEN(SIZEOF_StgCatchRetryFrame + WDS(1), R1_PTR & R2_PTR, stg_catchRetryzh);
899 900 901

  /* Start a nested transaction within which to run the first code */
  trec = StgTSO_trec(CurrentTSO);
902
  ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [R1,R2];
903 904 905 906 907 908
  StgTSO_trec(CurrentTSO) = new_trec;

  /* Set up the catch-retry frame */
  Sp = Sp - SIZEOF_StgCatchRetryFrame;
  frame = Sp;
  
909
  SET_HDR(frame, stg_catch_retry_frame_info, W_[CCCS]);
910
  StgCatchRetryFrame_running_alt_code(frame) = 0 :: CInt; // false;
911 912 913 914
  StgCatchRetryFrame_first_code(frame) = R1;
  StgCatchRetryFrame_alt_code(frame) = R2;

  /* Apply R1 to the realworld token */
915
  jump stg_ap_v_fast;
916 917 918
}


919
stg_retryzh
920 921 922 923 924 925 926
{
  W_ frame_type;
  W_ frame;
  W_ trec;
  W_ outer;
  W_ r;

927
  MAYBE_GC (NO_PTRS, stg_retryzh); // STM operations may allocate
928 929 930 931

  // Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME
retry_pop_stack:
  StgTSO_sp(CurrentTSO) = Sp;
932
  (frame_type) = foreign "C" findRetryFrameHelper(CurrentTSO "ptr") [];
933 934
  Sp = StgTSO_sp(CurrentTSO);
  frame = Sp;
tharris@microsoft.com's avatar
tharris@microsoft.com committed
935
  trec = StgTSO_trec(CurrentTSO);
936
  outer  = StgTRecHeader_enclosing_trec(trec);
937 938 939 940

  if (frame_type == CATCH_RETRY_FRAME) {
    // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
    ASSERT(outer != NO_TREC);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
941 942 943
    // Abort the transaction attempting the current branch
    foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
    foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
Simon Marlow's avatar
Simon Marlow committed
944
    if (!StgCatchRetryFrame_running_alt_code(frame) != 0::I32) {
tharris@microsoft.com's avatar
tharris@microsoft.com committed
945
      // Retry in the first branch: try the alternative
946
      ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
947
      StgTSO_trec(CurrentTSO) = trec;
948
      StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
949
      R1 = StgCatchRetryFrame_alt_code(frame);
950
      jump stg_ap_v_fast;
951
    } else {
tharris@microsoft.com's avatar
tharris@microsoft.com committed
952 953 954 955
      // Retry in the alternative code: propagate the retry
      StgTSO_trec(CurrentTSO) = outer;
      Sp = Sp + SIZEOF_StgCatchRetryFrame;
      goto retry_pop_stack;
956 957 958 959 960
    }
  }

  // We've reached the ATOMICALLY_FRAME: attempt to wait 
  ASSERT(frame_type == ATOMICALLY_FRAME);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
961 962 963 964 965 966 967
  if (outer != NO_TREC) {
    // We called retry while checking invariants, so abort the current
    // invariant check (merging its TVar accesses into the parents read
    // set so we'll wait on them)
    foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
    foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
    trec = outer;
968
    StgTSO_trec(CurrentTSO) = trec;
969
    outer  = StgTRecHeader_enclosing_trec(trec);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
970
  }
971
  ASSERT(outer == NO_TREC);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
972

973
  (r) = foreign "C" stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr") [];
Simon Marlow's avatar
Simon Marlow committed
974
  if (r != 0) {
975
    // Transaction was valid: stmWait put us on the TVars' queues, we now block
976
    StgHeader_info(frame) = stg_atomically_waiting_frame_info;
977
    Sp = frame;
978
    // Fix up the stack in the unregisterised case: the return convention is different.
979 980
    R3 = trec; // passing to stmWaitUnblock()
    jump stg_block_stmwait;
981 982
  } else {
    // Transaction was not valid: retry immediately
983
    ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
984 985 986
    StgTSO_trec(CurrentTSO) = trec;
    R1 = StgAtomicallyFrame_code(frame);
    Sp = frame;
987
    jump stg_ap_v_fast;
988 989 990 991
  }
}


992
stg_checkzh
tharris@microsoft.com's avatar
tharris@microsoft.com committed
993 994 995 996
{
  W_ trec, closure;

  /* Args: R1 = invariant closure */
997
  MAYBE_GC (R1_PTR, stg_checkzh); 
tharris@microsoft.com's avatar
tharris@microsoft.com committed
998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008

  trec = StgTSO_trec(CurrentTSO);
  closure = R1;
  foreign "C" stmAddInvariantToCheck(MyCapability() "ptr", 
                                     trec "ptr",
                                     closure "ptr") [];

  jump %ENTRY_CODE(Sp(0));
}


1009
stg_newTVarzh
1010 1011
{
  W_ tv;
1012
  W_ new_value;
1013 1014 1015

  /* Args: R1 = initialisation value */

1016
  MAYBE_GC (R1_PTR, stg_newTVarzh); 
1017
  new_value = R1;
1018
  ("ptr" tv) = foreign "C" stmNewTVar(MyCapability() "ptr", new_value "ptr") [];
1019 1020 1021 1022
  RET_P(tv);
}


1023
stg_readTVarzh
1024 1025 1026 1027 1028 1029 1030
{
  W_ trec;
  W_ tvar;
  W_ result;

  /* Args: R1 = TVar closure */

1031
  MAYBE_GC (R1_PTR, stg_readTVarzh); // Call to stmReadTVar may allocate
1032 1033
  trec = StgTSO_trec(CurrentTSO);
  tvar = R1;
1034
  ("ptr" result) = foreign "C" stmReadTVar(MyCapability() "ptr", trec "ptr", tvar "ptr") [];
1035 1036 1037 1038

  RET_P(result);
}

1039
stg_readTVarIOzh
1040 1041 1042 1043 1044 1045 1046 1047 1048 1049
{
    W_ result;

again:
    result = StgTVar_current_value(R1);
    if (%INFO_PTR(result) == stg_TREC_HEADER_info) {
        goto again;
    }
    RET_P(result);
}
1050

1051
stg_writeTVarzh
1052 1053 1054 1055 1056 1057 1058 1059
{
  W_ trec;
  W_ tvar;
  W_ new_value;
  
  /* Args: R1 = TVar closure */
  /*       R2 = New value    */

1060
  MAYBE_GC (R1_PTR & R2_PTR, stg_writeTVarzh); // Call to stmWriteTVar may allocate
1061 1062 1063
  trec = StgTSO_trec(CurrentTSO);
  tvar = R1;
  new_value = R2;
1064
  foreign "C" stmWriteTVar(MyCapability() "ptr", trec "ptr", tvar "ptr", new_value "ptr") [];
1065 1066 1067 1068 1069

  jump %ENTRY_CODE(Sp(0));
}


1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101
/* -----------------------------------------------------------------------------
 * MVar primitives
 *
 * take & putMVar work as follows.  Firstly, an important invariant:
 *
 *    If the MVar is full, then the blocking queue contains only
 *    threads blocked on putMVar, and if the MVar is empty then the
 *    blocking queue contains only threads blocked on takeMVar.
 *
 * takeMvar:
 *    MVar empty : then add ourselves to the blocking queue
 *    MVar full  : remove the value from the MVar, and
 *                 blocking queue empty     : return
 *                 blocking queue non-empty : perform the first block