PrimOps.cmm 57.7 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
#if !defined(mingw32_HOST_OS)
39
import sm_mutex;
40
#endif
41

42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
/*-----------------------------------------------------------------------------
  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.
 */

57
stg_newByteArrayzh
58 59
{
    W_ words, payload_words, n, p;
60
    MAYBE_GC(NO_PTRS,stg_newByteArrayzh);
61 62 63
    n = R1;
    payload_words = ROUNDUP_BYTES_TO_WDS(n);
    words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
64
    ("ptr" p) = foreign "C" allocate(MyCapability() "ptr",words) [];
65 66 67 68 69 70
    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
71 72 73
#define BA_ALIGN 16
#define BA_MASK  (BA_ALIGN-1)

74
stg_newPinnedByteArrayzh
75
{
76
    W_ words, bytes, payload_words, p;
77

78
    MAYBE_GC(NO_PTRS,stg_newPinnedByteArrayzh);
79 80 81 82 83 84 85 86 87 88 89
    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
90

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

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

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

103
stg_newAlignedPinnedByteArrayzh
Simon Marlow's avatar
Simon Marlow committed
104
{
105
    W_ words, bytes, payload_words, p, alignment;
Simon Marlow's avatar
Simon Marlow committed
106

107
    MAYBE_GC(NO_PTRS,stg_newAlignedPinnedByteArrayzh);
108 109
    bytes = R1;
    alignment = R2;
Simon Marlow's avatar
Simon Marlow committed
110

111 112
    /* 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
113

114 115 116 117 118 119 120 121
    /* 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);
122

123
    ("ptr" p) = foreign "C" allocatePinned(MyCapability() "ptr", words) [];
124 125
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);

126 127 128 129
    /* 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));
130 131 132 133 134 135

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

136
stg_newArrayzh
137
{
138
    W_ words, n, init, arr, p, size;
139 140 141
    /* Args: R1 = words, R2 = initialisation value */

    n = R1;
142
    MAYBE_GC(R2_PTR,stg_newArrayzh);
143

144 145 146 147 148
    // 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;
149
    ("ptr" arr) = foreign "C" allocate(MyCapability() "ptr",words) [R2];
150 151
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);

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

    // 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;
    }
165 166 167 168 169 170 171
    // Initialise the mark bits with 0
  for2:
    if (p < arr + WDS(size)) {
	W_[p] = 0;
	p = p + WDS(1);
	goto for2;
    }
172 173 174 175

    RET_P(arr);
}

176
stg_unsafeThawArrayzh
177 178 179 180 181 182
{
  // 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
183
  // the mutable list is not easy).
184
  // 
185
  // So that we can tell whether a MUT_ARR_PTRS_FROZEN is on the mutable list,
186 187 188
  // 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.
  //
189 190
  // 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
191
  // the closure type is MUT_ARR_PTRS_FROZEN0 if it is on the mutable list,
192 193 194
  // 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.
195
  //
196
  if (StgHeader_info(R1) != stg_MUT_ARR_PTRS_FROZEN0_info) {
197
	SET_INFO(R1,stg_MUT_ARR_PTRS_DIRTY_info);
198
	recordMutable(R1, R1);
199 200 201
	// must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
	RET_P(R1);
  } else {
202
	SET_INFO(R1,stg_MUT_ARR_PTRS_DIRTY_info);
203
	RET_P(R1);
204 205 206 207 208 209 210
  }
}

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

211
stg_newMutVarzh
212 213 214 215
{
    W_ mv;
    /* Args: R1 = initialisation value */

216
    ALLOC_PRIM( SIZEOF_StgMutVar, R1_PTR, stg_newMutVarzh);
217 218

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

225
stg_atomicModifyMutVarzh
226
{
227
    W_ mv, f, z, x, y, r, h;
228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246
    /* 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
247
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
248 249
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
#else
250
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
251 252 253 254
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
#endif

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

#define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)

264
   HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, stg_atomicModifyMutVarzh);
265

266 267
   mv = R1;
   f = R2;
268 269 270 271 272 273

   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);
274
   StgThunk_payload(z,0) = f;
275 276 277 278 279 280

   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);
281
   StgThunk_payload(y,0) = z;
282 283 284 285 286 287

   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);
288 289
   StgThunk_payload(r,0) = z;

290 291 292 293 294 295 296 297
 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;
298
#endif
299

300 301 302 303
   if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
     foreign "C" dirty_MUT_VAR(BaseReg "ptr", mv "ptr") [];
   }

304 305 306 307 308 309 310 311 312
   RET_P(r);
}

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

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

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

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

325
  ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, stg_mkWeakzh );
326 327 328 329

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

330 331 332 333 334 335 336 337
  // 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;
338

339
  ACQUIRE_LOCK(sm_mutex);
340 341
  StgWeak_link(w)	= W_[weak_ptr_list];
  W_[weak_ptr_list] 	= w;
342
  RELEASE_LOCK(sm_mutex);
343

344
  IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);
345 346 347 348

  RET_P(w);
}

349
stg_mkWeakForeignEnvzh
350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368
{
  /* 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;

369
  ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR, stg_mkWeakForeignEnvzh );
370 371 372 373 374 375

  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;
376
  ("ptr" p)     = foreign "C" allocate(MyCapability() "ptr", words) [];
377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394

  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;

395
  ACQUIRE_LOCK(sm_mutex);
396 397
  StgWeak_link(w)   = W_[weak_ptr_list];
  W_[weak_ptr_list] = w;
398
  RELEASE_LOCK(sm_mutex);
399 400 401 402 403

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

  RET_P(w);
}
404

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

  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);

437 438 439
  f   = StgWeak_finalizer(w);
  arr = StgWeak_cfinalizer(w);

440
  StgDeadWeak_link(w) = StgWeak_link(w);
441

442 443 444 445 446 447 448
  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)) [];
  }

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

457
stg_deRefWeakzh
458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473
{
  /* 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);
}

/* -----------------------------------------------------------------------------
474
   Floating point operations.
475 476
   -------------------------------------------------------------------------- */

477
stg_decodeFloatzuIntzh
478 479 480
{ 
    W_ p;
    F_ arg;
481 482 483
    W_ mp_tmp1;
    W_ mp_tmp_w;

484
    STK_CHK_GEN( WDS(2), NO_PTRS, stg_decodeFloatzuIntzh );
485 486 487

    mp_tmp1  = Sp - WDS(1);
    mp_tmp_w = Sp - WDS(2);
488 489 490 491 492 493 494 495 496 497 498
    
    /* 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]);
}

499
stg_decodeDoublezu2Intzh
500 501 502
{ 
    D_ arg;
    W_ p;
503 504 505 506 507
    W_ mp_tmp1;
    W_ mp_tmp2;
    W_ mp_result1;
    W_ mp_result2;

508
    STK_CHK_GEN( WDS(4), NO_PTRS, stg_decodeDoublezu2Intzh );
509 510 511 512 513

    mp_tmp1    = Sp - WDS(1);
    mp_tmp2    = Sp - WDS(2);
    mp_result1 = Sp - WDS(3);
    mp_result2 = Sp - WDS(4);
514 515 516 517 518

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

    /* Perform the operation */
519 520 521 522 523 524 525
    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]);
526 527
}

528 529 530 531
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

532
stg_forkzh
533 534
{
  /* args: R1 = closure to spark */
535

536
  MAYBE_GC(R1_PTR, stg_forkzh);
537

538 539 540 541
  W_ closure;
  W_ threadid;
  closure = R1;

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

  /* start blocked if the current thread is blocked */
547 548 549
  StgTSO_flags(threadid) = %lobits16(
     TO_W_(StgTSO_flags(threadid)) | 
     TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
550

551 552
  foreign "C" scheduleThread(MyCapability() "ptr", threadid "ptr") [];

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

560
stg_forkOnzh
561 562 563
{
  /* args: R1 = cpu, R2 = closure to spark */

564
  MAYBE_GC(R2_PTR, stg_forkOnzh);
565 566 567 568 569 570 571

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

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

  /* start blocked if the current thread is blocked */
577 578 579
  StgTSO_flags(threadid) = %lobits16(
     TO_W_(StgTSO_flags(threadid)) | 
     TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
580

581
  foreign "C" scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr") [];
582

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

590
stg_yieldzh
591 592 593 594
{
  jump stg_yield_noregs;
}

595
stg_myThreadIdzh
596 597 598 599 600
{
  /* no args. */
  RET_P(CurrentTSO);
}

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

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

620
stg_threadStatuszh
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 650 651 652
{
    /* 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);
}
653 654 655 656 657 658 659 660 661

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

#define SP_OFF 0

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

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

   frame = Sp;
   trec = StgTSO_trec(CurrentTSO);
672
   outer  = StgTRecHeader_enclosing_trec(trec);
673
   (r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
Simon Marlow's avatar
Simon Marlow committed
674
   if (r != 0) {
675 676 677 678 679
     /* 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
680
     /* Did not commit: re-execute */
681
     W_ new_trec;
682
     ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
683
     StgTSO_trec(CurrentTSO) = new_trec;
Simon Marlow's avatar
Simon Marlow committed
684
     if (StgCatchRetryFrame_running_alt_code(frame) != 0::I32) {
685 686 687 688
       R1 = StgCatchRetryFrame_alt_code(frame);
     } else {
       R1 = StgCatchRetryFrame_first_code(frame);
     }
689
     jump stg_ap_v_fast;
690 691
   }
}
692 693


Simon Marlow's avatar
Simon Marlow committed
694
// Atomically frame ------------------------------------------------------------
695

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

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

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

  } else {
tharris@microsoft.com's avatar
tharris@microsoft.com committed
716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732
    /* 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 */
733
    ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [];
734
    StgTSO_trec(CurrentTSO) = trec;
tharris@microsoft.com's avatar
tharris@microsoft.com committed
735 736 737

    next_invariant = StgInvariantCheckQueue_invariant(q);
    R1 = StgAtomicInvariant_code(next_invariant);
738
    jump stg_ap_v_fast;
tharris@microsoft.com's avatar
tharris@microsoft.com committed
739 740 741 742

  } else {

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

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

  frame = Sp;

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

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

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


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

824
stg_atomicallyzh
825 826 827 828 829
{
  W_ frame;
  W_ old_trec;
  W_ new_trec;
  
830
  // stmStartTransaction may allocate
831
  MAYBE_GC (R1_PTR, stg_atomicallyzh); 
832

833
  /* Args: R1 = m :: STM a */
834
  STK_CHK_GEN(SIZEOF_StgAtomicallyFrame + WDS(1), R1_PTR, stg_atomicallyzh);
835

836 837 838 839
  old_trec = StgTSO_trec(CurrentTSO);

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

844 845 846 847
  /* Set up the atomically frame */
  Sp = Sp - SIZEOF_StgAtomicallyFrame;
  frame = Sp;

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

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

  /* Apply R1 to the realworld token */
858
  jump stg_ap_v_fast;
859 860 861
}


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

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

874
  SET_HDR(frame, stg_catch_stm_frame_info, W_[CCCS]);
875
  StgCatchSTMFrame_handler(frame) = R2;
tharris@microsoft.com's avatar
tharris@microsoft.com committed
876 877 878 879 880 881
  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);
882
  ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", cur_trec "ptr");
tharris@microsoft.com's avatar
tharris@microsoft.com committed
883
  StgTSO_trec(CurrentTSO) = new_trec;
884 885

  /* Apply R1 to the realworld token */
886
  jump stg_ap_v_fast;
887 888 889
}


890
stg_catchRetryzh
891 892 893 894 895
{
  W_ frame;
  W_ new_trec;
  W_ trec;

896
  // stmStartTransaction may allocate
897
  MAYBE_GC (R1_PTR & R2_PTR, stg_catchRetryzh); 
898

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

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

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

  /* Apply R1 to the realworld token */
918
  jump stg_ap_v_fast;
919 920 921
}


922
stg_retryzh
923 924 925 926 927 928 929
{
  W_ frame_type;
  W_ frame;
  W_ trec;
  W_ outer;
  W_ r;

930
  MAYBE_GC (NO_PTRS, stg_retryzh); // STM operations may allocate
931 932 933 934

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

  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
944 945 946
    // 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
947
    if (!StgCatchRetryFrame_running_alt_code(frame) != 0::I32) {
tharris@microsoft.com's avatar
tharris@microsoft.com committed
948
      // Retry in the first branch: try the alternative
949
      ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
950
      StgTSO_trec(CurrentTSO) = trec;
951
      StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
952
      R1 = StgCatchRetryFrame_alt_code(frame);
953
      jump stg_ap_v_fast;
954
    } else {
tharris@microsoft.com's avatar
tharris@microsoft.com committed
955 956 957 958
      // Retry in the alternative code: propagate the retry
      StgTSO_trec(CurrentTSO) = outer;
      Sp = Sp + SIZEOF_StgCatchRetryFrame;
      goto retry_pop_stack;
959 960 961 962 963
    }
  }

  // We've reached the ATOMICALLY_FRAME: attempt to wait 
  ASSERT(frame_type == ATOMICALLY_FRAME);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
964 965 966 967 968 969 970
  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;
971
    StgTSO_trec(CurrentTSO) = trec;
972
    outer  = StgTRecHeader_enclosing_trec(trec);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
973
  }
974
  ASSERT(outer == NO_TREC);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
975

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


995
stg_checkzh
tharris@microsoft.com's avatar
tharris@microsoft.com committed
996 997 998 999
{
  W_ trec, closure;

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

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

  jump %ENTRY_CODE(Sp(0));
}


1012
stg_newTVarzh
1013 1014
{
  W_ tv;
1015
  W_ new_value;
1016 1017 1018

  /* Args: R1 = initialisation value */

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


1026
stg_readTVarzh
1027 1028 1029 1030 1031 1032 1033
{
  W_ trec;
  W_ tvar;
  W_ result;

  /* Args: R1 = TVar closure */

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

  RET_P(result);
}

1042
stg_readTVarIOzh
1043 1044 1045 1046 1047 1048 1049 1050 1051 1052
{
    W_ result;

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

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

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