PrimOps.cmm 57.8 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
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
67
    StgArrWords_bytes(p) = n;
68 69 70
    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, n, bytes, payload_words, p;
77

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

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

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

    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
100
    StgArrWords_bytes(p) = n;
Simon Marlow's avatar
Simon Marlow committed
101 102 103
    RET_P(p);
}

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

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

112 113
    bytes = n;

114 115
    /* 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
116

117 118 119 120 121 122 123 124
    /* 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);
125

126
    ("ptr" p) = foreign "C" allocatePinned(MyCapability() "ptr", words) [];
127 128
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);

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

    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
135
    StgArrWords_bytes(p) = n;
136 137 138
    RET_P(p);
}

139
stg_newArrayzh
140
{
141
    W_ words, n, init, arr, p, size;
142 143 144
    /* Args: R1 = words, R2 = initialisation value */

    n = R1;
145
    MAYBE_GC(R2_PTR,stg_newArrayzh);
146

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

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

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

    RET_P(arr);
}

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

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

214
stg_newMutVarzh
215 216 217 218
{
    W_ mv;
    /* Args: R1 = initialisation value */

219
    ALLOC_PRIM( SIZEOF_StgMutVar, R1_PTR, stg_newMutVarzh);
220 221

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

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

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

#define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)

267
   HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, stg_atomicModifyMutVarzh);
268

269 270
   mv = R1;
   f = R2;
271 272 273 274 275 276

   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);
277
   StgThunk_payload(z,0) = f;
278 279 280 281 282 283

   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);
284
   StgThunk_payload(y,0) = z;
285 286 287 288 289 290

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

293 294 295 296 297 298 299 300
 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;
301
#endif
302

303 304 305 306
   if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
     foreign "C" dirty_MUT_VAR(BaseReg "ptr", mv "ptr") [];
   }

307 308 309 310 311 312 313 314 315
   RET_P(r);
}

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

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

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

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

328
  ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, stg_mkWeakzh );
329 330 331 332

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

333 334 335 336 337 338 339 340
  // 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;
341

342
  ACQUIRE_LOCK(sm_mutex);
343 344
  StgWeak_link(w)	= W_[weak_ptr_list];
  W_[weak_ptr_list] 	= w;
345
  RELEASE_LOCK(sm_mutex);
346

347
  IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);
348 349 350 351

  RET_P(w);
}

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

372
  ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR, stg_mkWeakForeignEnvzh );
373 374 375 376 377 378

  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;
379
  ("ptr" p)     = foreign "C" allocate(MyCapability() "ptr", words) [];
380 381 382 383

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

384
  StgArrWords_bytes(p)     = WDS(payload_words);
385 386 387 388 389 390 391 392 393 394 395 396 397
  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;

398
  ACQUIRE_LOCK(sm_mutex);
399 400
  StgWeak_link(w)   = W_[weak_ptr_list];
  W_[weak_ptr_list] = w;
401
  RELEASE_LOCK(sm_mutex);
402 403 404 405 406

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

  RET_P(w);
}
407

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

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

440 441 442
  f   = StgWeak_finalizer(w);
  arr = StgWeak_cfinalizer(w);

443
  StgDeadWeak_link(w) = StgWeak_link(w);
444

445 446 447 448 449 450 451
  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)) [];
  }

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

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

/* -----------------------------------------------------------------------------
477
   Floating point operations.
478 479
   -------------------------------------------------------------------------- */

480
stg_decodeFloatzuIntzh
481 482 483
{ 
    W_ p;
    F_ arg;
484 485 486
    W_ mp_tmp1;
    W_ mp_tmp_w;

487
    STK_CHK_GEN( WDS(2), NO_PTRS, stg_decodeFloatzuIntzh );
488 489 490

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

502
stg_decodeDoublezu2Intzh
503 504 505
{ 
    D_ arg;
    W_ p;
506 507 508 509 510
    W_ mp_tmp1;
    W_ mp_tmp2;
    W_ mp_result1;
    W_ mp_result2;

511
    STK_CHK_GEN( WDS(4), NO_PTRS, stg_decodeDoublezu2Intzh );
512 513 514 515 516

    mp_tmp1    = Sp - WDS(1);
    mp_tmp2    = Sp - WDS(2);
    mp_result1 = Sp - WDS(3);
    mp_result2 = Sp - WDS(4);
517 518 519 520 521

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

    /* Perform the operation */
522 523 524 525 526 527 528
    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]);
529 530
}

531 532 533 534
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

535
stg_forkzh
536 537
{
  /* args: R1 = closure to spark */
538

539
  MAYBE_GC(R1_PTR, stg_forkzh);
540

541 542 543 544
  W_ closure;
  W_ threadid;
  closure = R1;

545
  ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr", 
546 547
				RtsFlags_GcFlags_initialStkSize(RtsFlags), 
				closure "ptr") [];
548 549

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

554 555
  foreign "C" scheduleThread(MyCapability() "ptr", threadid "ptr") [];

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

563
stg_forkOnzh
564 565 566
{
  /* args: R1 = cpu, R2 = closure to spark */

567
  MAYBE_GC(R2_PTR, stg_forkOnzh);
568 569 570 571 572 573 574

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

575
  ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr", 
576
				RtsFlags_GcFlags_initialStkSize(RtsFlags), 
577
				closure "ptr") [];
578 579

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

584
  foreign "C" scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr") [];
585

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

593
stg_yieldzh
594 595 596 597
{
  jump stg_yield_noregs;
}

598
stg_myThreadIdzh
599 600 601 602 603
{
  /* no args. */
  RET_P(CurrentTSO);
}

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

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

623
stg_threadStatuszh
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 653 654 655
{
    /* 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);
}
656 657 658 659 660 661 662 663 664

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

#define SP_OFF 0

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

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

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


Simon Marlow's avatar
Simon Marlow committed
697
// Atomically frame ------------------------------------------------------------
698

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

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

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

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

    next_invariant = StgInvariantCheckQueue_invariant(q);
    R1 = StgAtomicInvariant_code(next_invariant);
741
    jump stg_ap_v_fast;
tharris@microsoft.com's avatar
tharris@microsoft.com committed
742 743 744 745

  } else {

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

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

  frame = Sp;

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

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

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


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

827
stg_atomicallyzh
828 829 830 831 832
{
  W_ frame;
  W_ old_trec;
  W_ new_trec;
  
833
  // stmStartTransaction may allocate
834
  MAYBE_GC (R1_PTR, stg_atomicallyzh); 
835

836
  /* Args: R1 = m :: STM a */
837
  STK_CHK_GEN(SIZEOF_StgAtomicallyFrame + WDS(1), R1_PTR, stg_atomicallyzh);
838

839 840 841 842
  old_trec = StgTSO_trec(CurrentTSO);

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

847 848 849 850
  /* Set up the atomically frame */
  Sp = Sp - SIZEOF_StgAtomicallyFrame;
  frame = Sp;

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

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

  /* Apply R1 to the realworld token */
861
  jump stg_ap_v_fast;
862 863 864
}


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

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

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

  /* Apply R1 to the realworld token */
889
  jump stg_ap_v_fast;
890 891 892
}


893
stg_catchRetryzh
894 895 896 897 898
{
  W_ frame;
  W_ new_trec;
  W_ trec;

899
  // stmStartTransaction may allocate
900
  MAYBE_GC (R1_PTR & R2_PTR, stg_catchRetryzh); 
901

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

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

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

  /* Apply R1 to the realworld token */
921
  jump stg_ap_v_fast;
922 923 924
}


925
stg_retryzh
926 927 928 929 930 931 932
{
  W_ frame_type;
  W_ frame;
  W_ trec;
  W_ outer;
  W_ r;

933
  MAYBE_GC (NO_PTRS, stg_retryzh); // STM operations may allocate
934 935 936 937

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

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

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

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


998
stg_checkzh
tharris@microsoft.com's avatar
tharris@microsoft.com committed
999 1000 1001 1002
{
  W_ trec, closure;

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

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

  jump %ENTRY_CODE(Sp(0));
}


1015
stg_newTVarzh
1016 1017
{
  W_ tv;
1018
  W_ new_value;
1019 1020 1021

  /* Args: R1 = initialisation value */

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


1029
stg_readTVarzh
1030 1031 1032 1033 1034 1035 1036
{
  W_ trec;
  W_ tvar;
  W_ result;

  /* Args: R1 = TVar closure */

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

  RET_P(result);
}

1045
stg_readTVarIOzh
1046 1047 1048 1049 1050 1051 1052 1053 1054 1055
{
    W_ result;

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