PrimOps.cmm 71.4 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
 *
 * 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"
25
#include "MachDeps.h"
Simon Marlow's avatar
Simon Marlow committed
26
#include "SMPClosureOps.h"
27

Ben Gamari's avatar
Ben Gamari committed
28
#if defined(__PIC__)
29 30
import pthread_mutex_lock;
import pthread_mutex_unlock;
31
#endif
32
import CLOSURE base_ControlziExceptionziBase_nestedAtomically_closure;
33
import CLOSURE base_GHCziIOziException_heapOverflow_closure;
34 35
import EnterCriticalSection;
import LeaveCriticalSection;
36
import CLOSURE ghczmprim_GHCziTypes_False_closure;
37
#if defined(USE_MINIINTERPRETER) || !defined(mingw32_HOST_OS)
38
import CLOSURE sm_mutex;
39
#endif
Ben Gamari's avatar
Ben Gamari committed
40
#if defined(PROFILING)
41 42
import CLOSURE CCS_MAIN;
#endif
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 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 ( W_ n )
58
{
59 60 61 62 63
    W_ words, payload_words;
    gcptr p;

    MAYBE_GC_N(stg_newByteArrayzh, n);

64
    payload_words = ROUNDUP_BYTES_TO_WDS(n);
siddhanathan's avatar
siddhanathan committed
65
    words = BYTES_TO_WDS(SIZEOF_StgArrBytes) + payload_words;
66 67 68 69
    ("ptr" p) = ccall allocateMightFail(MyCapability() "ptr", words);
    if (p == NULL) {
        jump stg_raisezh(base_GHCziIOziException_heapOverflow_closure);
    }
siddhanathan's avatar
siddhanathan committed
70
    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
71
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
siddhanathan's avatar
siddhanathan committed
72
    StgArrBytes_bytes(p) = n;
73
    return (p);
74 75
}

Simon Marlow's avatar
Simon Marlow committed
76 77 78
#define BA_ALIGN 16
#define BA_MASK  (BA_ALIGN-1)

79
stg_newPinnedByteArrayzh ( W_ n )
80
{
81 82 83 84
    W_ words, bytes, payload_words;
    gcptr p;

    MAYBE_GC_N(stg_newPinnedByteArrayzh, n);
85

86
    bytes = n;
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: */
siddhanathan's avatar
siddhanathan committed
91
    bytes = bytes + SIZEOF_StgArrBytes;
92 93 94 95 96
    /* 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
97

98
    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
99 100 101
    if (p == NULL) {
        jump stg_raisezh(base_GHCziIOziException_heapOverflow_closure);
    }
siddhanathan's avatar
siddhanathan committed
102
    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
Simon Marlow's avatar
Simon Marlow committed
103

104 105
    /* Now we need to move p forward so that the payload is aligned
       to BA_ALIGN bytes: */
siddhanathan's avatar
siddhanathan committed
106
    p = p + ((-p - SIZEOF_StgArrBytes) & BA_MASK);
Simon Marlow's avatar
Simon Marlow committed
107

108
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
siddhanathan's avatar
siddhanathan committed
109
    StgArrBytes_bytes(p) = n;
110
    return (p);
Simon Marlow's avatar
Simon Marlow committed
111 112
}

113
stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment )
Simon Marlow's avatar
Simon Marlow committed
114
{
115 116
    W_ words, bytes, payload_words;
    gcptr p;
Simon Marlow's avatar
Simon Marlow committed
117

118
    again: MAYBE_GC(again);
Simon Marlow's avatar
Simon Marlow committed
119

120 121 122 123 124
    /* 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; }

125 126
    bytes = n;

127 128
    /* 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
129

130 131
    /* When we actually allocate memory, we need to allow space for the
       header: */
siddhanathan's avatar
siddhanathan committed
132
    bytes = bytes + SIZEOF_StgArrBytes;
133 134 135 136 137
    /* 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);
138

139
    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
140 141 142
    if (p == NULL) {
        jump stg_raisezh(base_GHCziIOziException_heapOverflow_closure);
    }
siddhanathan's avatar
siddhanathan committed
143
    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
144

145 146 147
    /* 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 */
siddhanathan's avatar
siddhanathan committed
148
    p = p + ((-p - SIZEOF_StgArrBytes) & (alignment - 1));
149

150
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
siddhanathan's avatar
siddhanathan committed
151
    StgArrBytes_bytes(p) = n;
152
    return (p);
153 154
}

155 156
stg_isByteArrayPinnedzh ( gcptr ba )
// ByteArray# s -> Int#
157 158
{
    W_ bd, flags;
159
    bd = Bdescr(ba);
160
    // Pinned byte arrays live in blocks with the BF_PINNED flag set.
Gabor Greif's avatar
Gabor Greif committed
161
    // We also consider BF_LARGE objects to be immovable. See #13894.
162
    // See the comment in Storage.c:allocatePinned.
163
    // We also consider BF_COMPACT objects to be immovable. See #14900.
164
    flags = TO_W_(bdescr_flags(bd));
165
    return (flags & (BF_PINNED | BF_LARGE | BF_COMPACT) != 0);
166 167
}

168 169 170 171 172 173
stg_isMutableByteArrayPinnedzh ( gcptr mba )
// MutableByteArray# s -> Int#
{
    jump stg_isByteArrayPinnedzh(mba);
}

174 175 176 177 178
// shrink size of MutableByteArray in-place
stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size )
// MutableByteArray# s -> Int# -> State# s -> State# s
{
   ASSERT(new_size >= 0);
siddhanathan's avatar
siddhanathan committed
179
   ASSERT(new_size <= StgArrBytes_bytes(mba));
180

siddhanathan's avatar
siddhanathan committed
181
   OVERWRITING_CLOSURE_OFS(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) +
182
                                 ROUNDUP_BYTES_TO_WDS(new_size)));
siddhanathan's avatar
siddhanathan committed
183
   StgArrBytes_bytes(mba) = new_size;
184 185 186 187 188 189 190 191 192 193 194
   LDV_RECORD_CREATE(mba);

   return ();
}

// resize MutableByteArray
//
// The returned MutableByteArray is either the original
// MutableByteArray resized in-place or, if not possible, a newly
// allocated (unpinned) MutableByteArray (with the original content
// copied over)
Gabor Greif's avatar
Gabor Greif committed
195
stg_resizzeMutableByteArrayzh ( gcptr mba, W_ new_size )
196 197 198 199 200 201 202 203 204
// MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #)
{
   W_ new_size_wds;

   ASSERT(new_size >= 0);

   new_size_wds = ROUNDUP_BYTES_TO_WDS(new_size);

   if (new_size_wds <= BYTE_ARR_WDS(mba)) {
siddhanathan's avatar
siddhanathan committed
205
      OVERWRITING_CLOSURE_OFS(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) +
206
                                    new_size_wds));
siddhanathan's avatar
siddhanathan committed
207
      StgArrBytes_bytes(mba) = new_size;
208 209 210 211 212 213 214 215 216 217 218 219 220 221
      LDV_RECORD_CREATE(mba);

      return (mba);
   } else {
      (P_ new_mba) = call stg_newByteArrayzh(new_size);

      // maybe at some point in the future we may be able to grow the
      // MBA in-place w/o copying if we know the space after the
      // current MBA is still available, as often we want to grow the
      // MBA shortly after we allocated the original MBA. So maybe no
      // further allocations have occurred by then.

      // copy over old content
      prim %memcpy(BYTE_ARR_CTS(new_mba), BYTE_ARR_CTS(mba),
siddhanathan's avatar
siddhanathan committed
222
                   StgArrBytes_bytes(mba), SIZEOF_W);
223 224 225 226 227

      return (new_mba);
   }
}

228 229 230 231 232
// 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
233
    W_ p, h;
234

siddhanathan's avatar
siddhanathan committed
235
    p = arr + SIZEOF_StgArrBytes + WDS(ind);
236
    (h) = prim %cmpxchgW(p, old, new);
237 238 239 240

    return(h);
}

241

242
stg_newArrayzh ( W_ n /* words */, gcptr init )
243
{
tibbe's avatar
tibbe committed
244 245
    W_ words, size, p;
    gcptr arr;
246

247
    again: MAYBE_GC(again);
248

249 250 251 252 253
    // 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;
254 255 256 257
    ("ptr" arr) = ccall allocateMightFail(MyCapability() "ptr",words);
    if (arr == NULL) {
        jump stg_raisezh(base_GHCziIOziException_heapOverflow_closure);
    }
tibbe's avatar
tibbe committed
258
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
259

260
    SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
261
    StgMutArrPtrs_ptrs(arr) = n;
262
    StgMutArrPtrs_size(arr) = size;
263

264
    // Initialise all elements of the array with the value in R2
265 266
    p = arr + SIZEOF_StgMutArrPtrs;
  for:
267
    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) (likely: True) {
ian@well-typed.com's avatar
ian@well-typed.com committed
268 269 270
        W_[p] = init;
        p = p + WDS(1);
        goto for;
271 272
    }

273
    return (arr);
274 275
}

276
stg_unsafeThawArrayzh ( gcptr arr )
277
{
278 279 280 281 282 283
    // A MUT_ARR_PTRS always lives on a mut_list, but a MUT_ARR_PTRS_FROZEN
    // doesn't. To decide whether to add the thawed array to a mut_list we check
    // the info table. MUT_ARR_PTRS_FROZEN_DIRTY means it's already on a
    // mut_list so no need to add it again. MUT_ARR_PTRS_FROZEN_CLEAN means it's
    // not and we should add it to a mut_list.
    if (StgHeader_info(arr) != stg_MUT_ARR_PTRS_FROZEN_DIRTY_info) {
284
        SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
285
        // must be done after SET_INFO, because it ASSERTs closure_MUTABLE():
286
        recordMutable(arr);
ian@well-typed.com's avatar
ian@well-typed.com committed
287
        return (arr);
tibbe's avatar
tibbe committed
288
    } else {
ian@well-typed.com's avatar
ian@well-typed.com committed
289 290
        SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
        return (arr);
tibbe's avatar
tibbe committed
291
    }
292 293
}

294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
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)
}

314 315
stg_cloneArrayzh ( gcptr src, W_ offset, W_ n )
{
316
    cloneArray(stg_MUT_ARR_PTRS_FROZEN_CLEAN_info, src, offset, n)
317 318 319 320
}

stg_cloneMutableArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
321
    cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
322 323 324 325 326
}

// We have to escape the "z" in the name.
stg_freezzeArrayzh ( gcptr src, W_ offset, W_ n )
{
327
    cloneArray(stg_MUT_ARR_PTRS_FROZEN_CLEAN_info, src, offset, n)
328 329 330 331
}

stg_thawArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
332
    cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
333 334
}

335
// RRN: Uses the ticketed approach; see casMutVar
336
stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
337
/* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, Any a #) */
338
{
tibbe's avatar
tibbe committed
339 340
    gcptr h;
    W_ p, len;
341 342

    p = arr + SIZEOF_StgMutArrPtrs + WDS(ind);
343
    (h) = prim %cmpxchgW(p, old, new);
344

345 346
    if (h != old) {
        // Failure, return what was there instead of 'old':
347
        return (1,h);
348 349
    } else {
        // Compare and Swap Succeeded:
rrnewton's avatar
rrnewton committed
350 351 352 353
        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;
354
        return (0,new);
355 356 357
    }
}

358
stg_newArrayArrayzh ( W_ n /* words */ )
359
{
tibbe's avatar
tibbe committed
360 361
    W_ words, size, p;
    gcptr arr;
362

363
    MAYBE_GC_N(stg_newArrayArrayzh, n);
364 365 366 367 368 369

    // 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;
370 371 372 373
    ("ptr" arr) = ccall allocateMightFail(MyCapability() "ptr",words);
    if (arr == NULL) {
        jump stg_raisezh(base_GHCziIOziException_heapOverflow_closure);
    }
tibbe's avatar
tibbe committed
374
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
375 376 377 378 379 380 381 382

    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:
383
    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) (likely: True) {
ian@well-typed.com's avatar
ian@well-typed.com committed
384 385 386
        W_[p] = arr;
        p = p + WDS(1);
        goto for;
387 388
    }

389
    return (arr);
390 391
}

pumpkin's avatar
pumpkin committed
392

393 394 395 396 397 398 399 400 401 402 403 404
/* -----------------------------------------------------------------------------
   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;
405 406 407 408
    ("ptr" arr) = ccall allocateMightFail(MyCapability() "ptr",words);
    if (arr == NULL) {
        jump stg_raisezh(base_GHCziIOziException_heapOverflow_closure);
    }
409 410 411 412 413
    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0);

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

414
    // Initialise all elements of the array with the value in R2
415 416
    p = arr + SIZEOF_StgSmallMutArrPtrs;
  for:
417
    if (p < arr + SIZEOF_StgSmallMutArrPtrs + WDS(n)) (likely: True) {
418 419 420 421 422 423 424 425 426 427 428
        W_[p] = init;
        p = p + WDS(1);
        goto for;
    }

    return (arr);
}

stg_unsafeThawSmallArrayzh ( gcptr arr )
{
    // See stg_unsafeThawArrayzh
429
    if (StgHeader_info(arr) != stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY_info) {
430 431 432 433 434 435 436 437 438 439 440 441
        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 )
{
442
    cloneSmallArray(stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN_info, src, offset, n)
443 444 445 446 447 448 449 450 451 452
}

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 )
{
453
    cloneSmallArray(stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN_info, src, offset, n)
454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469
}

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);
470
    prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
471 472 473 474 475 476 477 478 479 480 481 482 483 484

    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) {
485
        prim %memmove(dst_p, src_p, bytes, SIZEOF_W);
486
    } else {
487
        prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
488 489 490 491 492 493 494 495 496 497 498 499 500
    }

    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);
501
    (h) = prim %cmpxchgW(p, old, new);
502 503 504 505 506 507 508 509 510 511 512 513

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


514 515 516 517
/* -----------------------------------------------------------------------------
   MutVar primitives
   -------------------------------------------------------------------------- */

518
stg_newMutVarzh ( gcptr init )
519 520 521
{
    W_ mv;

522
    ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init);
523 524

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

528
    return (mv);
529 530
}

531 532 533 534 535
// 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.
536
stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
537
 /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, Any a #) */
Simon Marlow's avatar
Simon Marlow committed
538
{
539
#if defined(THREADED_RTS)
540
    gcptr h;
Simon Marlow's avatar
Simon Marlow committed
541

542
    (h) = prim %cmpxchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, old, new);
Simon Marlow's avatar
Simon Marlow committed
543
    if (h != old) {
544
        return (1,h);
Simon Marlow's avatar
Simon Marlow committed
545
    } else {
546
        if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
tibbe's avatar
tibbe committed
547
            ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
548
        }
549
        return (0,new);
Simon Marlow's avatar
Simon Marlow committed
550
    }
551 552 553 554 555 556 557 558 559 560 561 562 563 564
#else
    gcptr prev_val;

    prev_val = StgMutVar_var(mv);
    if (prev_val != old) {
        return (1,prev_val);
    } else {
        StgMutVar_var(mv) = new;
        if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
            ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
        }
        return (0,new);
    }
#endif
Simon Marlow's avatar
Simon Marlow committed
565 566
}

567
stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
568
{
569
    W_ z, x, y, r, h;
570

ian@well-typed.com's avatar
ian@well-typed.com committed
571
    /* If x is the current contents of the MutVar#, then
572 573 574
       We want to make the new contents point to

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

576
       and the return value is
ian@well-typed.com's avatar
ian@well-typed.com committed
577 578

         (sel_1 (f x))
579 580 581 582

        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
583
         y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
584 585 586
         r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
    */

587
#if defined(MIN_UPD_SIZE) && MIN_UPD_SIZE > 1
588
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
589 590
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
#else
591
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
592 593 594
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
#endif

595
#if defined(MIN_UPD_SIZE) && MIN_UPD_SIZE > 2
596
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
597 598
#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
#else
599
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(2))
600 601 602 603 604
#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),0)
#endif

#define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)

tibbe's avatar
tibbe committed
605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630
    HP_CHK_GEN_TICKY(SIZE);

    TICK_ALLOC_THUNK_2();
    CCCS_ALLOC(THUNK_2_SIZE);
    z = Hp - THUNK_2_SIZE + WDS(1);
    SET_HDR(z, stg_ap_2_upd_info, CCCS);
    LDV_RECORD_CREATE(z);
    StgThunk_payload(z,0) = f;

    TICK_ALLOC_THUNK_1();
    CCCS_ALLOC(THUNK_1_SIZE);
    y = z - THUNK_1_SIZE;
    SET_HDR(y, stg_sel_0_upd_info, CCCS);
    LDV_RECORD_CREATE(y);
    StgThunk_payload(y,0) = z;

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

  retry:
    x = StgMutVar_var(mv);
    StgThunk_payload(z,1) = x;
Ben Gamari's avatar
Ben Gamari committed
631
#if defined(THREADED_RTS)
632
    (h) = prim %cmpxchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y);
tibbe's avatar
tibbe committed
633
    if (h != x) { goto retry; }
634
#else
tibbe's avatar
tibbe committed
635
    StgMutVar_var(mv) = y;
636
#endif
637

tibbe's avatar
tibbe committed
638 639 640
    if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
        ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
    }
641

tibbe's avatar
tibbe committed
642
    return (r);
643 644 645 646 647 648
}

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

649 650 651
stg_mkWeakzh ( gcptr key,
               gcptr value,
               gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
652
{
tibbe's avatar
tibbe committed
653
    gcptr w;
654

tibbe's avatar
tibbe committed
655
    ALLOC_PRIM (SIZEOF_StgWeak)
656

tibbe's avatar
tibbe committed
657 658
    w = Hp - SIZEOF_StgWeak + WDS(1);
    SET_HDR(w, stg_WEAK_info, CCCS);
659

tibbe's avatar
tibbe committed
660 661 662 663
    StgWeak_key(w)         = key;
    StgWeak_value(w)       = value;
    StgWeak_finalizer(w)   = finalizer;
    StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
664

665 666 667 668 669
    StgWeak_link(w) = Capability_weak_ptr_list_hd(MyCapability());
    Capability_weak_ptr_list_hd(MyCapability()) = w;
    if (Capability_weak_ptr_list_tl(MyCapability()) == NULL) {
        Capability_weak_ptr_list_tl(MyCapability()) = w;
    }
670

671
    IF_DEBUG(weak, ccall debugBelch("New weak pointer at %p\n",w));
672

tibbe's avatar
tibbe committed
673
    return (w);
674 675
}

676
stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
677
{
tibbe's avatar
tibbe committed
678
    jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
679 680
}

681 682 683 684 685
stg_addCFinalizzerToWeakzh ( W_ fptr,   // finalizer
                             W_ ptr,
                             W_ flag,   // has environment (0 or 1)
                             W_ eptr,
                             gcptr w )
686
{
tibbe's avatar
tibbe committed
687
    W_ c, info;
688

tibbe's avatar
tibbe committed
689
    ALLOC_PRIM (SIZEOF_StgCFinalizerList)
690

tibbe's avatar
tibbe committed
691 692
    c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
    SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
693

tibbe's avatar
tibbe committed
694 695 696 697
    StgCFinalizerList_fptr(c) = fptr;
    StgCFinalizerList_ptr(c) = ptr;
    StgCFinalizerList_eptr(c) = eptr;
    StgCFinalizerList_flag(c) = flag;
698

tibbe's avatar
tibbe committed
699
    LOCK_CLOSURE(w, info);
700

tibbe's avatar
tibbe committed
701 702 703 704 705
    if (info == stg_DEAD_WEAK_info) {
        // Already dead.
        unlockClosure(w, info);
        return (0);
    }
706

tibbe's avatar
tibbe committed
707 708
    StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
    StgWeak_cfinalizers(w) = c;
709

tibbe's avatar
tibbe committed
710
    unlockClosure(w, info);
711

tibbe's avatar
tibbe committed
712
    recordMutable(w);
713

714
    IF_DEBUG(weak, ccall debugBelch("Adding a finalizer to %p\n",w));
715

tibbe's avatar
tibbe committed
716
    return (1);
717
}
718

719
stg_finalizzeWeakzh ( gcptr w )
720
{
tibbe's avatar
tibbe committed
721 722
    gcptr f, list;
    W_ info;
723

tibbe's avatar
tibbe committed
724
    LOCK_CLOSURE(w, info);
725

tibbe's avatar
tibbe committed
726 727 728 729 730
    // already dead?
    if (info == stg_DEAD_WEAK_info) {
        unlockClosure(w, info);
        return (0,stg_NO_FINALIZER_closure);
    }
731

tibbe's avatar
tibbe committed
732 733
    f    = StgWeak_finalizer(w);
    list = StgWeak_cfinalizers(w);
734

tibbe's avatar
tibbe committed
735
    // kill it
Ben Gamari's avatar
Ben Gamari committed
736
#if defined(PROFILING)
tibbe's avatar
tibbe committed
737 738 739 740 741 742 743 744
    // @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.
745
    // See stg_DEAD_WEAK_info in StgMiscClosures.cmm.
746 747
#endif

tibbe's avatar
tibbe committed
748 749 750 751
    //
    // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
    //
    unlockClosure(w, stg_DEAD_WEAK_info);
752

tibbe's avatar
tibbe committed
753
    LDV_RECORD_CREATE(w);
754

tibbe's avatar
tibbe committed
755 756 757
    if (list != stg_NO_FINALIZER_closure) {
      ccall runCFinalizers(list);
    }
758

tibbe's avatar
tibbe committed
759 760 761 762 763 764
    /* return the finalizer */
    if (f == stg_NO_FINALIZER_closure) {
        return (0,stg_NO_FINALIZER_closure);
    } else {
        return (1,f);
    }
765 766
}

767
stg_deRefWeakzh ( gcptr w )
768
{
tibbe's avatar
tibbe committed
769 770
    W_ code, info;
    gcptr val;
771

tibbe's avatar
tibbe committed
772
    info = GET_INFO(w);
773

tibbe's avatar
tibbe committed
774 775 776 777
    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.
778

tibbe's avatar
tibbe committed
779 780 781
        LOCK_CLOSURE(w, info);
        unlockClosure(w, info);
    }
782

tibbe's avatar
tibbe committed
783 784 785 786 787 788 789 790
    if (info == stg_WEAK_info) {
        code = 1;
        val = StgWeak_value(w);
    } else {
        code = 0;
        val = w;
    }
    return (code,val);
791 792 793
}

/* -----------------------------------------------------------------------------
794
   Floating point operations.
795 796
   -------------------------------------------------------------------------- */

797
stg_decodeFloatzuIntzh ( F_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
798
{
799
    W_ p;
800
    W_ tmp, mp_tmp1, mp_tmp_w, r1, r2;
801

802
    STK_CHK_GEN_N (WDS(2));
803

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

tibbe's avatar
tibbe committed
806 807
        mp_tmp1  = tmp + WDS(1);
        mp_tmp_w = tmp;
808

tibbe's avatar
tibbe committed
809 810
        /* Perform the operation */
        ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
811

tibbe's avatar
tibbe committed
812 813
        r1 = W_[mp_tmp1];
        r2 = W_[mp_tmp_w];
814
    }
ian@well-typed.com's avatar
ian@well-typed.com committed
815

816
    /* returns: (Int# (mantissa), Int# (exponent)) */
817
    return (r1, r2);
818 819
}

820
stg_decodeDoublezu2Intzh ( D_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
821
{
822 823 824
    W_ p, tmp;
    W_ mp_tmp1, mp_tmp2, mp_result1, mp_result2;
    W_ r1, r2, r3, r4;
825

826
    STK_CHK_GEN_N (WDS(4));
827

828 829
    reserve 4 = tmp {

tibbe's avatar
tibbe committed
830 831 832 833
        mp_tmp1    = tmp + WDS(3);
        mp_tmp2    = tmp + WDS(2);
        mp_result1 = tmp + WDS(1);
        mp_result2 = tmp;
834

tibbe's avatar
tibbe committed
835 836 837 838 839 840 841 842 843
        /* 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];
844
    }
845 846 847

    /* returns:
       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
848
    return (r1, r2, r3, r4);
849 850
}

851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866
/* Double# -> (# Int64#, Int# #) */
stg_decodeDoublezuInt64zh ( D_ arg )
{
    CInt exp;
    I64  mant;
    W_   mant_ptr;

    STK_CHK_GEN_N (SIZEOF_INT64);
    reserve BYTES_TO_WDS(SIZEOF_INT64) = mant_ptr {
        (exp) = ccall __decodeDouble_Int64(mant_ptr "ptr", arg);
        mant = I64[mant_ptr];
    }

    return (mant, TO_W_(exp));
}

867 868 869 870
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

871
stg_forkzh ( gcptr closure )
872
{
tibbe's avatar
tibbe committed
873
    MAYBE_GC_P(stg_forkzh, closure);
874

tibbe's avatar
tibbe committed
875
    gcptr threadid;
876

tibbe's avatar
tibbe committed
877 878 879
    ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
                                  RtsFlags_GcFlags_initialStkSize(RtsFlags),
                                  closure "ptr");
880

tibbe's avatar
tibbe committed
881 882 883 884
    /* start blocked if the current thread is blocked */
    StgTSO_flags(threadid) = %lobits16(
        TO_W_(StgTSO_flags(threadid)) |
        TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
885

tibbe's avatar
tibbe committed
886
    ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
887

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

tibbe's avatar
tibbe committed
892
    return (threadid);
893 894
}

895
stg_forkOnzh ( W_ cpu, gcptr closure )
896
{
897
again: MAYBE_GC(again);
898

tibbe's avatar
tibbe committed
899
    gcptr threadid;
900

tibbe's avatar
tibbe committed
901 902 903 904
    ("ptr" threadid) = ccall createIOThread(
        MyCapability() "ptr",
        RtsFlags_GcFlags_initialStkSize(RtsFlags),
        closure "ptr");
905

tibbe's avatar
tibbe committed
906 907 908 909
    /* start blocked if the current thread is blocked */
    StgTSO_flags(threadid) = %lobits16(
        TO_W_(StgTSO_flags(threadid)) |
        TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
910

tibbe's avatar
tibbe committed
911
    ccall scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr");
912

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

tibbe's avatar
tibbe committed
917
    return (threadid);
918 919
}

920
stg_yieldzh ()
921
{
tibbe's avatar
tibbe committed
922 923 924 925 926 927
    // 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;
    jump stg_yield_noregs();
928 929
}

930
stg_labelThreadzh ( gcptr threadid, W_ addr )
931
{
932
#if defined(DEBUG) || defined(TRACING) || defined(DTRACE)
tibbe's avatar
tibbe committed
933
    ccall labelThread(MyCapability() "ptr", threadid "ptr", addr "ptr");
934
#endif
tibbe's avatar
tibbe committed
935
    return ();
936 937
}

938
stg_isCurrentThreadBoundzh (/* no args */)