PrimOps.cmm 66.6 KB
Newer Older
1
/* -*- tab-width: 8 -*- */
2 3
/* -----------------------------------------------------------------------------
 *
4
 * (c) The GHC Team, 1998-2012
5 6 7 8 9 10 11 12 13
 *
 * 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.
 *
14 15 16
 * Entry convention: the entry convention for a primop is the
 * NativeNodeCall convention, and the return convention is
 * NativeReturn.  (see compiler/cmm/CmmCallConv.hs)
17 18 19 20 21 22 23 24 25
 *
 * 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"

26
#ifdef __PIC__
27 28
import pthread_mutex_lock;
import pthread_mutex_unlock;
29
#endif
30
import base_ControlziExceptionziBase_nestedAtomically_closure;
31 32
import EnterCriticalSection;
import LeaveCriticalSection;
Ian Lynagh's avatar
Ian Lynagh committed
33
import ghczmprim_GHCziTypes_False_closure;
34
#if defined(USE_MINIINTERPRETER) || !defined(mingw32_HOST_OS)
35
import sm_mutex;
36
#endif
37

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

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

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

51
stg_newByteArrayzh ( W_ n )
52
{
53 54 55 56 57
    W_ words, payload_words;
    gcptr p;

    MAYBE_GC_N(stg_newByteArrayzh, n);

58 59
    payload_words = ROUNDUP_BYTES_TO_WDS(n);
    words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
60
    ("ptr" p) = ccall allocate(MyCapability() "ptr",words);
61
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
62
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
63
    StgArrWords_bytes(p) = n;
64
    return (p);
65 66
}

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

70
stg_newPinnedByteArrayzh ( W_ n )
71
{
72 73 74 75
    W_ words, bytes, payload_words;
    gcptr p;

    MAYBE_GC_N(stg_newPinnedByteArrayzh, n);
76

77
    bytes = n;
78 79 80 81 82 83 84 85 86 87
    /* 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
88

89
    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
Simon Marlow's avatar
Simon Marlow committed
90 91
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);

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

96
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
97
    StgArrWords_bytes(p) = n;
98
    return (p);
Simon Marlow's avatar
Simon Marlow committed
99 100
}

101
stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment )
Simon Marlow's avatar
Simon Marlow committed
102
{
103 104
    W_ words, bytes, payload_words;
    gcptr p;
Simon Marlow's avatar
Simon Marlow committed
105

106
    again: MAYBE_GC(again);
Simon Marlow's avatar
Simon Marlow committed
107

108 109 110 111 112
    /* we always supply at least word-aligned memory, so there's no
       need to allow extra space for alignment if the requirement is less
       than a word.  This also prevents mischief with alignment == 0. */
    if (alignment <= SIZEOF_W) { alignment = 1; }

113 114
    bytes = n;

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

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

127
    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
128 129
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);

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

135
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
136
    StgArrWords_bytes(p) = n;
137
    return (p);
138 139
}

140 141 142 143 144
// RRN: This one does not use the "ticketing" approach because it
// deals in unboxed scalars, not heap pointers.
stg_casIntArrayzh( gcptr arr, W_ ind, W_ old, W_ new )
/* MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) */
{
tibbe's avatar
tibbe committed
145
    W_ p, h;
146 147 148 149 150 151 152

    p = arr + SIZEOF_StgArrWords + WDS(ind);
    (h) = ccall cas(p, old, new);

    return(h);
}

153 154 155 156

stg_fetchAddIntArrayzh( gcptr arr, W_ ind, W_ incr )
/* MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) */
{
tibbe's avatar
tibbe committed
157
    W_ p, h;
158 159

    p = arr + SIZEOF_StgArrWords + WDS(ind);
160
    (h) = ccall atomic_inc(p, incr);
161 162 163 164 165

    return(h);
}


166
stg_newArrayzh ( W_ n /* words */, gcptr init )
167
{
tibbe's avatar
tibbe committed
168 169
    W_ words, size, p;
    gcptr arr;
170

171
    again: MAYBE_GC(again);
172

173 174 175 176 177
    // 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;
178
    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
tibbe's avatar
tibbe committed
179
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
180

181
    SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
182
    StgMutArrPtrs_ptrs(arr) = n;
183
    StgMutArrPtrs_size(arr) = size;
184 185 186 187

    // Initialise all elements of the the array with the value in R2
    p = arr + SIZEOF_StgMutArrPtrs;
  for:
tibbe's avatar
tibbe committed
188
    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) {
ian@well-typed.com's avatar
ian@well-typed.com committed
189 190 191
        W_[p] = init;
        p = p + WDS(1);
        goto for;
192 193
    }

194
    return (arr);
195 196
}

197
stg_unsafeThawArrayzh ( gcptr arr )
198 199 200
{
  // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST
  //
ian@well-typed.com's avatar
ian@well-typed.com committed
201
  // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN
202 203
  // 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
204
  // the mutable list is not easy).
ian@well-typed.com's avatar
ian@well-typed.com committed
205
  //
206
  // So that we can tell whether a MUT_ARR_PTRS_FROZEN is on the mutable list,
207 208 209
  // 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.
  //
210 211
  // 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
212
  // the closure type is MUT_ARR_PTRS_FROZEN0 if it is on the mutable list,
213 214 215
  // 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.
216
  //
217 218 219
  if (StgHeader_info(arr) != stg_MUT_ARR_PTRS_FROZEN0_info) {
        SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
        recordMutable(arr);
ian@well-typed.com's avatar
ian@well-typed.com committed
220 221
        // must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
        return (arr);
222
  } else {
ian@well-typed.com's avatar
ian@well-typed.com committed
223 224
        SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
        return (arr);
225 226 227
  }
}

228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247
stg_copyArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n )
{
    copyArray(src, src_off, dst, dst_off, n)
}

stg_copyMutableArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n )
{
    copyMutableArray(src, src_off, dst, dst_off, n)
}

stg_copyArrayArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n )
{
    copyArray(src, src_off, dst, dst_off, n)
}

stg_copyMutableArrayArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n )
{
    copyMutableArray(src, src_off, dst, dst_off, n)
}

248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268
stg_cloneArrayzh ( gcptr src, W_ offset, W_ n )
{
  cloneArray(stg_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
}

stg_cloneMutableArrayzh ( gcptr src, W_ offset, W_ n )
{
  cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
}

// We have to escape the "z" in the name.
stg_freezzeArrayzh ( gcptr src, W_ offset, W_ n )
{
  cloneArray(stg_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
}

stg_thawArrayzh ( gcptr src, W_ offset, W_ n )
{
  cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
}

269
// RRN: Uses the ticketed approach; see casMutVar
270
stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
271
/* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, Any a #) */
272
{
tibbe's avatar
tibbe committed
273 274
    gcptr h;
    W_ p, len;
275 276

    p = arr + SIZEOF_StgMutArrPtrs + WDS(ind);
277
    (h) = ccall cas(p, old, new);
278 279 280
    
    if (h != old) {
        // Failure, return what was there instead of 'old':
281
        return (1,h);
282 283
    } else {
        // Compare and Swap Succeeded:
rrnewton's avatar
rrnewton committed
284 285 286 287
        SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
        len = StgMutArrPtrs_ptrs(arr);
        // The write barrier.  We must write a byte into the mark table:
        I8[arr + SIZEOF_StgMutArrPtrs + WDS(len) + (ind >> MUT_ARR_PTRS_CARD_BITS )] = 1;
288
        return (0,new);
289 290 291
    }
}

292
stg_newArrayArrayzh ( W_ n /* words */ )
293
{
tibbe's avatar
tibbe committed
294 295
    W_ words, size, p;
    gcptr arr;
296

297
    MAYBE_GC_N(stg_newArrayArrayzh, n);
298 299 300 301 302 303

    // 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;
304
    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
tibbe's avatar
tibbe committed
305
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
306 307 308 309 310 311 312 313

    SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, W_[CCCS]);
    StgMutArrPtrs_ptrs(arr) = n;
    StgMutArrPtrs_size(arr) = size;

    // Initialise all elements of the array with a pointer to the new array
    p = arr + SIZEOF_StgMutArrPtrs;
  for:
tibbe's avatar
tibbe committed
314
    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) {
ian@well-typed.com's avatar
ian@well-typed.com committed
315 316 317
        W_[p] = arr;
        p = p + WDS(1);
        goto for;
318 319
    }

320
    return (arr);
321 322
}

pumpkin's avatar
pumpkin committed
323

324 325 326 327
/* -----------------------------------------------------------------------------
   MutVar primitives
   -------------------------------------------------------------------------- */

328
stg_newMutVarzh ( gcptr init )
329 330 331
{
    W_ mv;

332
    ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init);
333 334

    mv = Hp - SIZEOF_StgMutVar + WDS(1);
335
    SET_HDR(mv,stg_MUT_VAR_DIRTY_info,CCCS);
336
    StgMutVar_var(mv) = init;
ian@well-typed.com's avatar
ian@well-typed.com committed
337

338
    return (mv);
339 340
}

341 342 343 344 345
// RRN: To support the "ticketed" approach, we return the NEW rather
// than old value if the CAS is successful.  This is received in an
// opaque form in the Haskell code, preventing the compiler from
// changing its pointer identity.  The ticket can then be safely used
// in future CAS operations.
346
stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
347
 /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, Any a #) */
Simon Marlow's avatar
Simon Marlow committed
348
{
349
    gcptr h;
Simon Marlow's avatar
Simon Marlow committed
350

351 352
    (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var,
                          old, new);
Simon Marlow's avatar
Simon Marlow committed
353
    if (h != old) {
354
        return (1,h);
Simon Marlow's avatar
Simon Marlow committed
355
    } else {
356
        if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
357
           ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
358
        }
359
        return (0,new);
Simon Marlow's avatar
Simon Marlow committed
360 361 362
    }
}

363
stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
364
{
365
    W_ z, x, y, r, h;
366

ian@well-typed.com's avatar
ian@well-typed.com committed
367
    /* If x is the current contents of the MutVar#, then
368 369 370
       We want to make the new contents point to

         (sel_0 (f x))
ian@well-typed.com's avatar
ian@well-typed.com committed
371

372
       and the return value is
ian@well-typed.com's avatar
ian@well-typed.com committed
373 374

         (sel_1 (f x))
375 376 377 378

        obviously we can share (f x).

         z = [stg_ap_2 f x]  (max (HS + 2) MIN_UPD_SIZE)
ian@well-typed.com's avatar
ian@well-typed.com committed
379
         y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
380 381 382 383
         r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
    */

#if MIN_UPD_SIZE > 1
384
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
385 386
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
#else
387
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
388 389 390 391
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
#endif

#if MIN_UPD_SIZE > 2
392
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
393 394
#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
#else
395
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(2))
396 397 398 399 400
#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),0)
#endif

#define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)

401
   HP_CHK_GEN_TICKY(SIZE);
402 403 404 405

   TICK_ALLOC_THUNK_2();
   CCCS_ALLOC(THUNK_2_SIZE);
   z = Hp - THUNK_2_SIZE + WDS(1);
406
   SET_HDR(z, stg_ap_2_upd_info, CCCS);
407
   LDV_RECORD_CREATE(z);
408
   StgThunk_payload(z,0) = f;
409 410 411 412

   TICK_ALLOC_THUNK_1();
   CCCS_ALLOC(THUNK_1_SIZE);
   y = z - THUNK_1_SIZE;
413
   SET_HDR(y, stg_sel_0_upd_info, CCCS);
414
   LDV_RECORD_CREATE(y);
415
   StgThunk_payload(y,0) = z;
416 417 418 419

   TICK_ALLOC_THUNK_1();
   CCCS_ALLOC(THUNK_1_SIZE);
   r = y - THUNK_1_SIZE;
420
   SET_HDR(r, stg_sel_1_upd_info, CCCS);
421
   LDV_RECORD_CREATE(r);
422 423
   StgThunk_payload(r,0) = z;

424 425 426 427
 retry:
   x = StgMutVar_var(mv);
   StgThunk_payload(z,1) = x;
#ifdef THREADED_RTS
428
   (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y);
429 430 431
   if (h != x) { goto retry; }
#else
   StgMutVar_var(mv) = y;
432
#endif
433

434
   if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
435
     ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
436 437
   }

438
   return (r);
439 440 441 442 443 444 445 446
}

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

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

447 448 449
stg_mkWeakzh ( gcptr key,
               gcptr value,
               gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
450
{
451
  gcptr w;
452

453
  ALLOC_PRIM (SIZEOF_StgWeak)
454 455

  w = Hp - SIZEOF_StgWeak + WDS(1);
456
  SET_HDR(w, stg_WEAK_info, CCCS);
457

458 459 460 461
  StgWeak_key(w)         = key;
  StgWeak_value(w)       = value;
  StgWeak_finalizer(w)   = finalizer;
  StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
462

463
  ACQUIRE_LOCK(sm_mutex);
464 465
  StgWeak_link(w) = generation_weak_ptr_list(W_[g0]);
  generation_weak_ptr_list(W_[g0]) = w;
466
  RELEASE_LOCK(sm_mutex);
467

468
  IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
469

470
  return (w);
471 472
}

473
stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
474
{
475
  jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
476 477
}

478 479 480 481 482 483 484
STRING(stg_cfinalizer_msg,"Adding a finalizer to %p\n")

stg_addCFinalizzerToWeakzh ( W_ fptr,   // finalizer
                             W_ ptr,
                             W_ flag,   // has environment (0 or 1)
                             W_ eptr,
                             gcptr w )
485
{
486
  W_ c, info;
487

488
  ALLOC_PRIM (SIZEOF_StgCFinalizerList)
489

490 491
  c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
  SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
492

493 494 495 496
  StgCFinalizerList_fptr(c) = fptr;
  StgCFinalizerList_ptr(c) = ptr;
  StgCFinalizerList_eptr(c) = eptr;
  StgCFinalizerList_flag(c) = flag;
497

498 499 500 501 502 503 504 505
  LOCK_CLOSURE(w, info);

  if (info == stg_DEAD_WEAK_info) {
    // Already dead.
    unlockClosure(w, info);
    return (0);
  }

506 507
  StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
  StgWeak_cfinalizers(w) = c;
508

509
  unlockClosure(w, info);
510

511
  recordMutable(w);
512

513
  IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
514

515
  return (1);
516
}
517

518
stg_finalizzeWeakzh ( gcptr w )
519
{
520 521 522
  gcptr f, list;
  W_ info;

523
  LOCK_CLOSURE(w, info);
524 525

  // already dead?
526 527
  if (info == stg_DEAD_WEAK_info) {
      unlockClosure(w, info);
528
      return (0,stg_NO_FINALIZER_closure);
529 530
  }

531 532 533
  f    = StgWeak_finalizer(w);
  list = StgWeak_cfinalizers(w);

534 535 536 537 538 539 540 541
  // 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));
ian@well-typed.com's avatar
ian@well-typed.com committed
542
  // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
543 544 545 546 547 548 549
  // 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()?
  //
550
  unlockClosure(w, stg_DEAD_WEAK_info);
551

552
  LDV_RECORD_CREATE(w);
553

554 555
  if (list != stg_NO_FINALIZER_closure) {
    ccall runCFinalizers(list);
556 557
  }

558 559
  /* return the finalizer */
  if (f == stg_NO_FINALIZER_closure) {
560
      return (0,stg_NO_FINALIZER_closure);
561
  } else {
562
      return (1,f);
563 564 565
  }
}

566
stg_deRefWeakzh ( gcptr w )
567
{
568
  W_ code, info;
569
  gcptr val;
570

571 572 573 574 575 576 577
  info = GET_INFO(w);

  if (info == stg_WHITEHOLE_info) {
    // w is locked by another thread. Now it's not immediately clear if w is
    // alive or not. We use lockClosure to wait for the info pointer to become
    // something other than stg_WHITEHOLE_info.

578
    LOCK_CLOSURE(w, info);
579 580 581 582
    unlockClosure(w, info);
  }

  if (info == stg_WEAK_info) {
583 584 585 586 587 588
    code = 1;
    val = StgWeak_value(w);
  } else {
    code = 0;
    val = w;
  }
589
  return (code,val);
590 591 592
}

/* -----------------------------------------------------------------------------
593
   Floating point operations.
594 595
   -------------------------------------------------------------------------- */

596
stg_decodeFloatzuIntzh ( F_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
597
{
598
    W_ p;
599
    W_ tmp, mp_tmp1, mp_tmp_w, r1, r2;
600

601
    STK_CHK_GEN_N (WDS(2));
602

603
    reserve 2 = tmp {
ian@well-typed.com's avatar
ian@well-typed.com committed
604

605 606 607 608 609 610 611 612 613
      mp_tmp1  = tmp + WDS(1);
      mp_tmp_w = tmp;

      /* Perform the operation */
      ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);

      r1 = W_[mp_tmp1];
      r2 = W_[mp_tmp_w];
    }
ian@well-typed.com's avatar
ian@well-typed.com committed
614

615
    /* returns: (Int# (mantissa), Int# (exponent)) */
616
    return (r1, r2);
617 618
}

619
stg_decodeDoublezu2Intzh ( D_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
620
{
621 622 623
    W_ p, tmp;
    W_ mp_tmp1, mp_tmp2, mp_result1, mp_result2;
    W_ r1, r2, r3, r4;
624

625
    STK_CHK_GEN_N (WDS(4));
626

627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643
    reserve 4 = tmp {

      mp_tmp1    = tmp + WDS(3);
      mp_tmp2    = tmp + WDS(2);
      mp_result1 = tmp + WDS(1);
      mp_result2 = tmp;
  
      /* Perform the operation */
      ccall __decodeDouble_2Int(mp_tmp1 "ptr", mp_tmp2 "ptr",
                                      mp_result1 "ptr", mp_result2 "ptr",
                                      arg);

      r1 = W_[mp_tmp1];
      r2 = W_[mp_tmp2];
      r3 = W_[mp_result1];
      r4 = W_[mp_result2];
    }
644 645 646

    /* returns:
       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
647
    return (r1, r2, r3, r4);
648 649
}

650 651 652 653
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

654
stg_forkzh ( gcptr closure )
655
{
656
  MAYBE_GC_P(stg_forkzh, closure);
657

658
  gcptr threadid;
659

ian@well-typed.com's avatar
ian@well-typed.com committed
660 661
  ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
                                RtsFlags_GcFlags_initialStkSize(RtsFlags),
662
                                closure "ptr");
663 664

  /* start blocked if the current thread is blocked */
665
  StgTSO_flags(threadid) = %lobits16(
ian@well-typed.com's avatar
ian@well-typed.com committed
666
     TO_W_(StgTSO_flags(threadid)) |
667
     TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
668

669
  ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
670

671 672
  // context switch soon, but not immediately: we don't want every
  // forkIO to force a context-switch.
673
  Capability_context_switch(MyCapability()) = 1 :: CInt;
ian@well-typed.com's avatar
ian@well-typed.com committed
674

675
  return (threadid);
676 677
}

678
stg_forkOnzh ( W_ cpu, gcptr closure )
679
{
680
again: MAYBE_GC(again);
681

682
  gcptr threadid;
683

ian@well-typed.com's avatar
ian@well-typed.com committed
684 685
  ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
                                RtsFlags_GcFlags_initialStkSize(RtsFlags),
686
                                closure "ptr");
687 688

  /* start blocked if the current thread is blocked */
689
  StgTSO_flags(threadid) = %lobits16(
ian@well-typed.com's avatar
ian@well-typed.com committed
690
     TO_W_(StgTSO_flags(threadid)) |
691
     TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
692

693
  ccall scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr");
694

695 696
  // context switch soon, but not immediately: we don't want every
  // forkIO to force a context-switch.
697
  Capability_context_switch(MyCapability()) = 1 :: CInt;
ian@well-typed.com's avatar
ian@well-typed.com committed
698

699
  return (threadid);
700 701
}

702
stg_yieldzh ()
703
{
704 705 706 707 708
  // when we yield to the scheduler, we have to tell it to put the
  // current thread to the back of the queue by setting the
  // context_switch flag.  If we don't do this, it will run the same
  // thread again.
  Capability_context_switch(MyCapability()) = 1 :: CInt;
709
  jump stg_yield_noregs();
710 711
}

712
stg_myThreadIdzh ()
713
{
714
  return (CurrentTSO);
715 716
}

717
stg_labelThreadzh ( gcptr threadid, W_ addr )
718
{
719
#if defined(DEBUG) || defined(TRACING) || defined(DTRACE)
720
  ccall labelThread(MyCapability() "ptr", threadid "ptr", addr "ptr");
721
#endif
722
  return ();
723 724
}

725
stg_isCurrentThreadBoundzh (/* no args */)
726 727
{
  W_ r;
728 729
  (r) = ccall isThreadBound(CurrentTSO);
  return (r);
730 731
}

732
stg_threadStatuszh ( gcptr tso )
733 734 735
{
    W_ why_blocked;
    W_ what_next;
736
    W_ ret, cap, locked;
737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753

    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;
        }
    }
754 755 756 757 758 759 760 761 762

    cap = TO_W_(Capability_no(StgTSO_cap(tso)));

    if ((TO_W_(StgTSO_flags(tso)) & TSO_LOCKED) != 0) {
        locked = 1;
    } else {
        locked = 0;
    }

763
    return (ret,cap,locked);
764
}
765 766 767 768 769

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

770 771 772
// Catch retry frame -----------------------------------------------------------

#define CATCH_RETRY_FRAME_FIELDS(w_,p_,info_ptr,        \
Simon Marlow's avatar
Simon Marlow committed
773
                                 p1, p2,                \
774 775 776 777
                                 running_alt_code,      \
                                 first_code,            \
                                 alt_code)              \
  w_ info_ptr,                                          \
Simon Marlow's avatar
Simon Marlow committed
778
  PROF_HDR_FIELDS(w_,p1,p2)                             \
779 780 781
  w_ running_alt_code,                                  \
  p_ first_code,                                        \
  p_ alt_code
782 783


784
INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
785
               CATCH_RETRY_FRAME_FIELDS(W_,P_,
Simon Marlow's avatar
Simon Marlow committed
786
                                        info_ptr, p1, p2,
787 788 789 790
                                        running_alt_code,
                                        first_code,
                                        alt_code))
    return (P_ ret)
791
{
792 793
    W_ r;
    gcptr trec, outer, arg;
794

795 796 797 798 799 800 801 802 803 804 805 806 807 808 809
    trec = StgTSO_trec(CurrentTSO);
    outer  = StgTRecHeader_enclosing_trec(trec);
    (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
    if (r != 0) {
        // Succeeded (either first branch or second branch)
        StgTSO_trec(CurrentTSO) = outer;
        return (ret);
    } else {
        // Did not commit: re-execute
        P_ new_trec;
        ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr",
                                                           outer "ptr");
        StgTSO_trec(CurrentTSO) = new_trec;
        if (running_alt_code != 0) {
            jump stg_ap_v_fast
Simon Marlow's avatar
Simon Marlow committed
810
                (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
811 812 813 814 815 816
                                          running_alt_code,
                                          first_code,
                                          alt_code))
                (alt_code);
        } else {
            jump stg_ap_v_fast
Simon Marlow's avatar
Simon Marlow committed
817
                (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
818 819 820 821 822 823 824
                                          running_alt_code,
                                          first_code,
                                          alt_code))
                (first_code);
        }
    }
}
825

Simon Marlow's avatar
Simon Marlow committed
826
// Atomically frame ------------------------------------------------------------
827

828
// This must match StgAtomicallyFrame in Closures.h
Simon Marlow's avatar
Simon Marlow committed
829
#define ATOMICALLY_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,code,next,result)  \
830
  w_ info_ptr,                                                          \
Simon Marlow's avatar
Simon Marlow committed
831
  PROF_HDR_FIELDS(w_,p1,p2)                                             \
832 833 834 835 836
  p_ code,                                                              \
  p_ next,                                                              \
  p_ result


837
INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
838 839
               // layout of the frame, and bind the field names
               ATOMICALLY_FRAME_FIELDS(W_,P_,
Simon Marlow's avatar
Simon Marlow committed
840
                                       info_ptr, p1, p2,
841 842 843 844
                                       code,
                                       next_invariant,
                                       frame_result))
    return (P_ result) // value returned to the frame
845
{
846 847
  W_ valid;
  gcptr trec, outer, next_invariant, q;
848

849
  trec   = StgTSO_trec(CurrentTSO);
850
  outer  = StgTRecHeader_enclosing_trec(trec);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
851 852 853

  if (outer == NO_TREC) {
    /* First time back at the atomically frame -- pick up invariants */
854 855 856
    ("ptr" next_invariant) =
        ccall stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr");
    frame_result = result;
857 858

  } else {
tharris@microsoft.com's avatar
tharris@microsoft.com committed
859 860 861
    /* 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;
862 863
    StgInvariantCheckQueue_my_execution(next_invariant) = trec;
    ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
tharris@microsoft.com's avatar
tharris@microsoft.com committed
864 865
    /* Don't free trec -- it's linked from q and will be stashed in the
     * invariant if we eventually commit. */
866 867
    next_invariant =
       StgInvariantCheckQueue_next_queue_entry(next_invariant);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
868 869 870
    trec = outer;
  }

871
  if (next_invariant != END_INVARIANT_CHECK_QUEUE) {
tharris@microsoft.com's avatar
tharris@microsoft.com committed
872
    /* We can't commit yet: another invariant to check */
873
    ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", trec "ptr");
874
    StgTSO_trec(CurrentTSO) = trec;
875 876
    q = StgInvariantCheckQueue_invariant(next_invariant);
    jump stg_ap_v_fast
Simon Marlow's avatar
Simon Marlow committed
877 878
        (ATOMICALLY_FRAME_FIELDS(,,info_ptr,p1,p2,
                                 code,next_invariant,frame_result))
879
        (StgAtomicInvariant_code(q));
tharris@microsoft.com's avatar
tharris@microsoft.com committed
880 881 882 883

  } else {

    /* We've got no more invariants to check, try to commit */
884
    (valid) = ccall stmCommitTransaction(MyCapability() "ptr", trec "ptr");
tharris@microsoft.com's avatar
tharris@microsoft.com committed
885 886 887
    if (valid != 0) {
      /* Transaction was valid: commit succeeded */
      StgTSO_trec(CurrentTSO) = NO_TREC;
888
      return (frame_result);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
889 890
    } else {
      /* Transaction was not valid: try again */
891
      ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
tharris@microsoft.com's avatar
tharris@microsoft.com committed
892
      StgTSO_trec(CurrentTSO) = trec;
893 894 895 896 897
      next_invariant = END_INVARIANT_CHECK_QUEUE;

      jump stg_ap_v_fast
          // push the StgAtomicallyFrame again: the code generator is
          // clever enough to only assign the fields that have changed.
Simon Marlow's avatar
Simon Marlow committed
898 899
          (ATOMICALLY_FRAME_FIELDS(,,info_ptr,p1,p2,
                                   code,next_invariant,frame_result))
900
          (code);
tharris@microsoft.com's avatar
tharris@microsoft.com committed