PrimOps.cmm 69.7 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 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441
/* -----------------------------------------------------------------------------
   SmallArray primitives
   -------------------------------------------------------------------------- */

stg_newSmallArrayzh ( W_ n /* words */, gcptr init )
{
    W_ words, size, p;
    gcptr arr;

    again: MAYBE_GC(again);

    words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n;
    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0);

    SET_HDR(arr, stg_SMALL_MUT_ARR_PTRS_DIRTY_info, CCCS);
    StgSmallMutArrPtrs_ptrs(arr) = n;

    // Initialise all elements of the the array with the value in R2
    p = arr + SIZEOF_StgSmallMutArrPtrs;
  for:
    if (p < arr + SIZEOF_StgSmallMutArrPtrs + WDS(n)) {
        W_[p] = init;
        p = p + WDS(1);
        goto for;
    }

    return (arr);
}

stg_unsafeThawSmallArrayzh ( gcptr arr )
{
    // See stg_unsafeThawArrayzh
    if (StgHeader_info(arr) != stg_SMALL_MUT_ARR_PTRS_FROZEN0_info) {
        SET_INFO(arr, stg_SMALL_MUT_ARR_PTRS_DIRTY_info);
        recordMutable(arr);
        // must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
        return (arr);
    } else {
        SET_INFO(arr, stg_SMALL_MUT_ARR_PTRS_DIRTY_info);
        return (arr);
    }
}

stg_cloneSmallArrayzh ( gcptr src, W_ offset, W_ n )
{
    cloneSmallArray(stg_SMALL_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
}

stg_cloneSmallMutableArrayzh ( gcptr src, W_ offset, W_ n )
{
    cloneSmallArray(stg_SMALL_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
}

// We have to escape the "z" in the name.
stg_freezzeSmallArrayzh ( gcptr src, W_ offset, W_ n )
{
    cloneSmallArray(stg_SMALL_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
}

stg_thawSmallArrayzh ( gcptr src, W_ offset, W_ n )
{
    cloneSmallArray(stg_SMALL_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
}

stg_copySmallArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n)
{
    W_ dst_p, src_p, bytes;

    SET_INFO(dst, stg_SMALL_MUT_ARR_PTRS_DIRTY_info);

    dst_p = dst + SIZEOF_StgSmallMutArrPtrs + WDS(dst_off);
    src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(src_off);
    bytes = WDS(n);
    prim %memcpy(dst_p, src_p, bytes, WDS(1));

    return ();
}

stg_copySmallMutableArrayzh ( gcptr src, W_ src_off, gcptr dst, W_ dst_off, W_ n)
{
    W_ dst_p, src_p, bytes;

    SET_INFO(dst, stg_SMALL_MUT_ARR_PTRS_DIRTY_info);

    dst_p = dst + SIZEOF_StgSmallMutArrPtrs + WDS(dst_off);
    src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(src_off);
    bytes = WDS(n);
    if (src == dst) {
        prim %memmove(dst_p, src_p, bytes, WDS(1));
    } else {
        prim %memcpy(dst_p, src_p, bytes, WDS(1));
    }

    return ();
}

// RRN: Uses the ticketed approach; see casMutVar
stg_casSmallArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
/* SmallMutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, Any a #) */
{
    gcptr h;
    W_ p, len;

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

    if (h != old) {
        // Failure, return what was there instead of 'old':
        return (1,h);
    } else {
        // Compare and Swap Succeeded:
        SET_HDR(arr, stg_SMALL_MUT_ARR_PTRS_DIRTY_info, CCCS);
        return (0,new);
    }
}


442 443 444 445
/* -----------------------------------------------------------------------------
   MutVar primitives
   -------------------------------------------------------------------------- */

446
stg_newMutVarzh ( gcptr init )
447 448 449
{
    W_ mv;

450
    ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init);
451 452

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

456
    return (mv);
457 458
}

459 460 461 462 463
// 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.
464
stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
465
 /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, Any a #) */
Simon Marlow's avatar
Simon Marlow committed
466
{
467
    gcptr h;
Simon Marlow's avatar
Simon Marlow committed
468

469 470
    (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var,
                          old, new);
Simon Marlow's avatar
Simon Marlow committed
471
    if (h != old) {
472
        return (1,h);
Simon Marlow's avatar
Simon Marlow committed
473
    } else {
474
        if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
475
           ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
476
        }
477
        return (0,new);
Simon Marlow's avatar
Simon Marlow committed
478 479 480
    }
}

481
stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
482
{
483
    W_ z, x, y, r, h;
484

ian@well-typed.com's avatar
ian@well-typed.com committed
485
    /* If x is the current contents of the MutVar#, then
486 487 488
       We want to make the new contents point to

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

490
       and the return value is
ian@well-typed.com's avatar
ian@well-typed.com committed
491 492

         (sel_1 (f x))
493 494 495 496

        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
497
         y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
498 499 500 501
         r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
    */

#if MIN_UPD_SIZE > 1
502
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
503 504
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
#else
505
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
506 507 508 509
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
#endif

#if MIN_UPD_SIZE > 2
510
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
511 512
#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
#else
513
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(2))
514 515 516 517 518
#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),0)
#endif

#define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)

519
   HP_CHK_GEN_TICKY(SIZE);
520 521 522 523

   TICK_ALLOC_THUNK_2();
   CCCS_ALLOC(THUNK_2_SIZE);
   z = Hp - THUNK_2_SIZE + WDS(1);
524
   SET_HDR(z, stg_ap_2_upd_info, CCCS);
525
   LDV_RECORD_CREATE(z);
526
   StgThunk_payload(z,0) = f;
527 528 529 530

   TICK_ALLOC_THUNK_1();
   CCCS_ALLOC(THUNK_1_SIZE);
   y = z - THUNK_1_SIZE;
531
   SET_HDR(y, stg_sel_0_upd_info, CCCS);
532
   LDV_RECORD_CREATE(y);
533
   StgThunk_payload(y,0) = z;
534 535 536 537

   TICK_ALLOC_THUNK_1();
   CCCS_ALLOC(THUNK_1_SIZE);
   r = y - THUNK_1_SIZE;
538
   SET_HDR(r, stg_sel_1_upd_info, CCCS);
539
   LDV_RECORD_CREATE(r);
540 541
   StgThunk_payload(r,0) = z;

542 543 544 545
 retry:
   x = StgMutVar_var(mv);
   StgThunk_payload(z,1) = x;
#ifdef THREADED_RTS
546
   (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y);
547 548 549
   if (h != x) { goto retry; }
#else
   StgMutVar_var(mv) = y;
550
#endif
551

552
   if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
553
     ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
554 555
   }

556
   return (r);
557 558 559 560 561 562 563 564
}

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

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

565 566 567
stg_mkWeakzh ( gcptr key,
               gcptr value,
               gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
568
{
569
  gcptr w;
570

571
  ALLOC_PRIM (SIZEOF_StgWeak)
572 573

  w = Hp - SIZEOF_StgWeak + WDS(1);
574
  SET_HDR(w, stg_WEAK_info, CCCS);
575

576 577 578 579
  StgWeak_key(w)         = key;
  StgWeak_value(w)       = value;
  StgWeak_finalizer(w)   = finalizer;
  StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
580

581
  ACQUIRE_LOCK(sm_mutex);
582 583
  StgWeak_link(w) = generation_weak_ptr_list(W_[g0]);
  generation_weak_ptr_list(W_[g0]) = w;
584
  RELEASE_LOCK(sm_mutex);
585

586
  IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
587

588
  return (w);
589 590
}

591
stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
592
{
593
  jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
594 595
}

596 597 598 599 600 601 602
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 )
603
{
604
  W_ c, info;
605

606
  ALLOC_PRIM (SIZEOF_StgCFinalizerList)
607

608 609
  c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
  SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
610

611 612 613 614
  StgCFinalizerList_fptr(c) = fptr;
  StgCFinalizerList_ptr(c) = ptr;
  StgCFinalizerList_eptr(c) = eptr;
  StgCFinalizerList_flag(c) = flag;
615

616 617 618 619 620 621 622 623
  LOCK_CLOSURE(w, info);

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

624 625
  StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
  StgWeak_cfinalizers(w) = c;
626

627
  unlockClosure(w, info);
628

629
  recordMutable(w);
630

631
  IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
632

633
  return (1);
634
}
635

636
stg_finalizzeWeakzh ( gcptr w )
637
{
638 639 640
  gcptr f, list;
  W_ info;

641
  LOCK_CLOSURE(w, info);
642 643

  // already dead?
644 645
  if (info == stg_DEAD_WEAK_info) {
      unlockClosure(w, info);
646
      return (0,stg_NO_FINALIZER_closure);
647 648
  }

649 650 651
  f    = StgWeak_finalizer(w);
  list = StgWeak_cfinalizers(w);

652 653 654 655 656 657 658 659
  // 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
660
  // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
661 662 663 664 665 666 667
  // 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()?
  //
668
  unlockClosure(w, stg_DEAD_WEAK_info);
669

670
  LDV_RECORD_CREATE(w);
671

672 673
  if (list != stg_NO_FINALIZER_closure) {
    ccall runCFinalizers(list);
674 675
  }

676 677
  /* return the finalizer */
  if (f == stg_NO_FINALIZER_closure) {
678
      return (0,stg_NO_FINALIZER_closure);
679
  } else {
680
      return (1,f);
681 682 683
  }
}

684
stg_deRefWeakzh ( gcptr w )
685
{
686
  W_ code, info;
687
  gcptr val;
688

689 690 691 692 693 694 695
  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.

696
    LOCK_CLOSURE(w, info);
697 698 699 700
    unlockClosure(w, info);
  }

  if (info == stg_WEAK_info) {
701 702 703 704 705 706
    code = 1;
    val = StgWeak_value(w);
  } else {
    code = 0;
    val = w;
  }
707
  return (code,val);
708 709 710
}

/* -----------------------------------------------------------------------------
711
   Floating point operations.
712 713
   -------------------------------------------------------------------------- */

714
stg_decodeFloatzuIntzh ( F_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
715
{
716
    W_ p;
717
    W_ tmp, mp_tmp1, mp_tmp_w, r1, r2;
718

719
    STK_CHK_GEN_N (WDS(2));
720

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

723 724 725 726 727 728 729 730 731
      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
732

733
    /* returns: (Int# (mantissa), Int# (exponent)) */
734
    return (r1, r2);
735 736
}

737
stg_decodeDoublezu2Intzh ( D_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
738
{
739 740 741
    W_ p, tmp;
    W_ mp_tmp1, mp_tmp2, mp_result1, mp_result2;
    W_ r1, r2, r3, r4;
742

743
    STK_CHK_GEN_N (WDS(4));
744

745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761
    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];
    }
762 763 764

    /* returns:
       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
765
    return (r1, r2, r3, r4);
766 767
}

768 769 770 771
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

772
stg_forkzh ( gcptr closure )
773
{
774
  MAYBE_GC_P(stg_forkzh, closure);
775

776
  gcptr threadid;
777

ian@well-typed.com's avatar
ian@well-typed.com committed
778 779
  ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
                                RtsFlags_GcFlags_initialStkSize(RtsFlags),
780
                                closure "ptr");
781 782

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

787
  ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
788

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

793
  return (threadid);
794 795
}

796
stg_forkOnzh ( W_ cpu, gcptr closure )
797
{
798
again: MAYBE_GC(again);
799

800
  gcptr threadid;
801

ian@well-typed.com's avatar
ian@well-typed.com committed
802 803
  ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
                                RtsFlags_GcFlags_initialStkSize(RtsFlags),
804
                                closure "ptr");
805 806

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

811
  ccall scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr");
812

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

817
  return (threadid);
818 819
}

820
stg_yieldzh ()
821
{
822 823 824 825 826
  // 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;
827
  jump stg_yield_noregs();
828 829
}

830
stg_myThreadIdzh ()
831
{
832
  return (CurrentTSO);
833 834
}

835
stg_labelThreadzh ( gcptr threadid, W_ addr )
836
{
837
#if defined(DEBUG) || defined(TRACING) || defined(DTRACE)
838
  ccall labelThread(MyCapability() "ptr", threadid "ptr", addr "ptr");
839
#endif
840
  return ();
841 842
}

843
stg_isCurrentThreadBoundzh (/* no args */)
844 845
{
  W_ r;
846 847
  (r) = ccall isThreadBound(CurrentTSO);
  return (r);
848 849
}

850
stg_threadStatuszh ( gcptr tso )
851 852 853
{
    W_ why_blocked;
    W_ what_next;
854
    W_ ret, cap, locked;
855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871

    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;
        }
    }
872 873 874 875 876 877 878 879 880

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

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

881
    return (ret,cap,locked);
882
}
883 884 885 886 887

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

888 889 890
// Catch retry frame -----------------------------------------------------------

#define CATCH_RETRY_FRAME_FIELDS(w_,p_,info_ptr,        \
Simon Marlow's avatar
Simon Marlow committed
891
                                 p1, p2,                \
892 893 894 895
                                 running_alt_code,      \
                                 first_code,            \
                                 alt_code)              \
  w_ info_ptr,                                          \
Simon Marlow's avatar
Simon Marlow committed
896
  PROF_HDR_FIELDS(w_,p1,p2)                             \
897 898 899
  w_ running_alt_code,                                  \
  p_ first_code,                                        \
  p_ alt_code
900 901


902
INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
903
               CATCH_RETRY_FRAME_FIELDS(W_,P_,
Simon Marlow's avatar
Simon Marlow committed
904
                                        info_ptr, p1, p2,
905 906 907 908
                                        running_alt_code,
                                        first_code,
                                        alt_code))
    return (P_ ret)
909
{
910 911
    W_ r;
    gcptr trec, outer, arg;
912

913 914 915 916 917 918 919 920 921 922 923 924 925 926 927
    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
928
                (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
929 930 931 932 933 934
                                          running_alt_code,
                                          first_code,
                                          alt_code))
                (alt_code);
        } else {
            jump stg_ap_v_fast
Simon Marlow's avatar
Simon Marlow committed
935
                (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
936 937 938 939 940 941 942
                                          running_alt_code,
                                          first_code,
                                          alt_code))
                (first_code);
        }
    }
}
943

Simon Marlow's avatar
Simon Marlow committed
944
// Atomically frame ------------------------------------------------------------
945

946
// This must match StgAtomicallyFrame in Closures.h
Simon Marlow's avatar
Simon Marlow committed
947
#define ATOMICALLY_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,code,next,result)  \
948
  w_ info_ptr,                                                          \
Simon Marlow's avatar
Simon Marlow committed
949
  PROF_HDR_FIELDS(w_,p1,p2)                                             \
950 951 952 953 954
  p_ code,                                                              \
  p_ next,                                                              \
  p_ result


955
INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
956 957
               // layout of the frame, and bind the field names
               ATOMICALLY_FRAME_FIELDS(W_,P_,
Simon Marlow's avatar
Simon Marlow committed
958
                                       info_ptr, p1, p2,
959 960 961 962
                                       code,
                                       next_invariant,
                                       frame_result))
    return (P_ result) // value returned to the frame
963
{
964 965
  W_ valid;
  gcptr trec, outer, next_invariant, q;
966

967
  trec   = StgTSO_trec(CurrentTSO);
968
  outer  = StgTRecHeader_enclosing_trec(trec);
tharris@microsoft.com's avatar
tharris@microsoft.com committed
969 970 971

  if (outer == NO_TREC) {
    /* First time back at the atomically frame -- pick up invariants */
972 973 974
    ("ptr" next_invariant) =
        ccall stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr");
    frame_result = result;
975 976

  } else {