PrimOps.cmm 72.5 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
}

David Feuer's avatar
David Feuer committed
567
stg_atomicModifyMutVar2zh ( gcptr mv, gcptr f )
568
{
David Feuer's avatar
David Feuer committed
569
    W_ z, x, y, 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

David Feuer's avatar
David Feuer committed
578
         (# x, (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
#if defined(MIN_UPD_SIZE) && MIN_UPD_SIZE > 1
587
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
588 589
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
#else
590
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
591 592 593
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
#endif

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

David Feuer's avatar
David Feuer committed
602
#define SIZE (THUNK_2_SIZE + THUNK_1_SIZE)
603

tibbe's avatar
tibbe committed
604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622
    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;

  retry:
    x = StgMutVar_var(mv);
    StgThunk_payload(z,1) = x;
Ben Gamari's avatar
Ben Gamari committed
623
#if defined(THREADED_RTS)
624
    (h) = prim %cmpxchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y);
tibbe's avatar
tibbe committed
625
    if (h != x) { goto retry; }
626
#else
tibbe's avatar
tibbe committed
627
    StgMutVar_var(mv) = y;
628
#endif
629

tibbe's avatar
tibbe committed
630 631 632
    if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
        ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
    }
633

David Feuer's avatar
David Feuer committed
634
    return (x,z);
635 636
}

David Feuer's avatar
David Feuer committed
637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689
stg_atomicModifyMutVarzuzh ( gcptr mv, gcptr f )
{
    W_ z, x, h;

    /* If x is the current contents of the MutVar#, then
       We want to make the new contents point to

         (f x)

       and the return value is

         (# x, (f x) #)

        obviously we can share (f x).

         z = [stg_ap_2 f x]  (max (HS + 2) MIN_UPD_SIZE)
    */

#if defined(MIN_UPD_SIZE) && MIN_UPD_SIZE > 2
#define THUNK_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
#define TICK_ALLOC_THUNK() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
#else
#define THUNK_SIZE (SIZEOF_StgThunkHeader + WDS(2))
#define TICK_ALLOC_THUNK() TICK_ALLOC_UP_THK(WDS(2),0)
#endif

    HP_CHK_GEN_TICKY(THUNK_SIZE);

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

  retry:
    x = StgMutVar_var(mv);
    StgThunk_payload(z,1) = x;
#if defined(THREADED_RTS)
    (h) = prim %cmpxchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, z);
    if (h != x) { goto retry; }
#else
    StgMutVar_var(mv) = z;
#endif

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

    return (x,z);
}


690 691 692 693
/* -----------------------------------------------------------------------------
   Weak Pointer Primitives
   -------------------------------------------------------------------------- */

694 695 696
stg_mkWeakzh ( gcptr key,
               gcptr value,
               gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
697
{
tibbe's avatar
tibbe committed
698
    gcptr w;
699

tibbe's avatar
tibbe committed
700
    ALLOC_PRIM (SIZEOF_StgWeak)
701

tibbe's avatar
tibbe committed
702 703
    w = Hp - SIZEOF_StgWeak + WDS(1);
    SET_HDR(w, stg_WEAK_info, CCCS);
704

tibbe's avatar
tibbe committed
705 706 707 708
    StgWeak_key(w)         = key;
    StgWeak_value(w)       = value;
    StgWeak_finalizer(w)   = finalizer;
    StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
709

710 711 712 713 714
    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;
    }
715

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

tibbe's avatar
tibbe committed
718
    return (w);
719 720
}

721
stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
722
{
tibbe's avatar
tibbe committed
723
    jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
724 725
}

726 727 728 729 730
stg_addCFinalizzerToWeakzh ( W_ fptr,   // finalizer
                             W_ ptr,
                             W_ flag,   // has environment (0 or 1)
                             W_ eptr,
                             gcptr w )
731
{
tibbe's avatar
tibbe committed
732
    W_ c, info;
733

tibbe's avatar
tibbe committed
734
    ALLOC_PRIM (SIZEOF_StgCFinalizerList)
735

tibbe's avatar
tibbe committed
736 737
    c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
    SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
738

tibbe's avatar
tibbe committed
739 740 741 742
    StgCFinalizerList_fptr(c) = fptr;
    StgCFinalizerList_ptr(c) = ptr;
    StgCFinalizerList_eptr(c) = eptr;
    StgCFinalizerList_flag(c) = flag;
743

tibbe's avatar
tibbe committed
744
    LOCK_CLOSURE(w, info);
745

tibbe's avatar
tibbe committed
746 747 748 749 750
    if (info == stg_DEAD_WEAK_info) {
        // Already dead.
        unlockClosure(w, info);
        return (0);
    }
751

tibbe's avatar
tibbe committed
752 753
    StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
    StgWeak_cfinalizers(w) = c;
754

tibbe's avatar
tibbe committed
755
    unlockClosure(w, info);
756

tibbe's avatar
tibbe committed
757
    recordMutable(w);
758

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

tibbe's avatar
tibbe committed
761
    return (1);
762
}
763

764
stg_finalizzeWeakzh ( gcptr w )
765
{
tibbe's avatar
tibbe committed
766 767
    gcptr f, list;
    W_ info;
768

tibbe's avatar
tibbe committed
769
    LOCK_CLOSURE(w, info);
770

tibbe's avatar
tibbe committed
771 772 773 774 775
    // already dead?
    if (info == stg_DEAD_WEAK_info) {
        unlockClosure(w, info);
        return (0,stg_NO_FINALIZER_closure);
    }
776

tibbe's avatar
tibbe committed
777 778
    f    = StgWeak_finalizer(w);
    list = StgWeak_cfinalizers(w);
779

tibbe's avatar
tibbe committed
780
    // kill it
Ben Gamari's avatar
Ben Gamari committed
781
#if defined(PROFILING)
tibbe's avatar
tibbe committed
782 783 784 785 786 787 788 789
    // @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.
790
    // See stg_DEAD_WEAK_info in StgMiscClosures.cmm.
791 792
#endif

tibbe's avatar
tibbe committed
793 794 795 796
    //
    // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
    //
    unlockClosure(w, stg_DEAD_WEAK_info);
797

tibbe's avatar
tibbe committed
798
    LDV_RECORD_CREATE(w);
799

tibbe's avatar
tibbe committed
800 801 802
    if (list != stg_NO_FINALIZER_closure) {
      ccall runCFinalizers(list);
    }
803

tibbe's avatar
tibbe committed
804 805 806 807 808 809
    /* return the finalizer */
    if (f == stg_NO_FINALIZER_closure) {
        return (0,stg_NO_FINALIZER_closure);
    } else {
        return (1,f);
    }
810 811
}

812
stg_deRefWeakzh ( gcptr w )
813
{
tibbe's avatar
tibbe committed
814 815
    W_ code, info;
    gcptr val;
816

tibbe's avatar
tibbe committed
817
    info = GET_INFO(w);
818

tibbe's avatar
tibbe committed
819 820 821 822
    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.
823

tibbe's avatar
tibbe committed
824 825 826
        LOCK_CLOSURE(w, info);
        unlockClosure(w, info);
    }
827

tibbe's avatar
tibbe committed
828 829 830 831 832 833 834 835
    if (info == stg_WEAK_info) {
        code = 1;
        val = StgWeak_value(w);
    } else {
        code = 0;
        val = w;
    }
    return (code,val);
836 837 838
}

/* -----------------------------------------------------------------------------
839
   Floating point operations.
840 841
   -------------------------------------------------------------------------- */

842
stg_decodeFloatzuIntzh ( F_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
843
{
844
    W_ p;
845
    W_ tmp, mp_tmp1, mp_tmp_w, r1, r2;
846

847
    STK_CHK_GEN_N (WDS(2));
848

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

tibbe's avatar
tibbe committed
851 852
        mp_tmp1  = tmp + WDS(1);
        mp_tmp_w = tmp;
853

tibbe's avatar
tibbe committed
854 855
        /* Perform the operation */
        ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
856

tibbe's avatar
tibbe committed
857 858
        r1 = W_[mp_tmp1];
        r2 = W_[mp_tmp_w];
859
    }
ian@well-typed.com's avatar
ian@well-typed.com committed
860

861
    /* returns: (Int# (mantissa), Int# (exponent)) */
862
    return (r1, r2);
863 864
}

865
stg_decodeDoublezu2Intzh ( D_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
866
{
867 868 869
    W_ p, tmp;
    W_ mp_tmp1, mp_tmp2, mp_result1, mp_result2;
    W_ r1, r2, r3, r4;
870

871
    STK_CHK_GEN_N (WDS(4));
872

873 874
    reserve 4 = tmp {

tibbe's avatar
tibbe committed
875 876 877 878
        mp_tmp1    = tmp + WDS(3);
        mp_tmp2    = tmp + WDS(2);
        mp_result1 = tmp + WDS(1);
        mp_result2 = tmp;
879

tibbe's avatar
tibbe committed
880 881 882 883 884 885 886 887 888
        /* 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];
889
    }
890 891 892

    /* returns:
       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
893
    return (r1, r2, r3, r4);
894 895
}

896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911
/* 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));
}

912 913 914 915
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

916
stg_forkzh ( gcptr closure )
917
{
tibbe's avatar
tibbe committed
918
    MAYBE_GC_P(stg_forkzh, closure);
919

tibbe's avatar
tibbe committed
920
    gcptr threadid;
921

tibbe's avatar
tibbe committed
922 923 924
    ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
                                  RtsFlags_GcFlags_initialStkSize(RtsFlags),
                                  closure "ptr");
925

tibbe's avatar
tibbe committed
926 927 928 929
    /* 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));
930

tibbe's avatar
tibbe committed
931
    ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
932

tibbe's avatar
tibbe committed
933 934 935
    // 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
936

tibbe's avatar
tibbe committed
937
    return (threadid);
938 939
}

940
stg_forkOnzh ( W_ cpu, gcptr closure )
941
{
942
again: MAYBE_GC(again);
943

tibbe's avatar
tibbe committed
944
    gcptr threadid;
945

tibbe's avatar
tibbe committed
946 947 948 949
    ("ptr" threadid) = ccall createIOThread(
        MyCapability() "ptr",
        RtsFlags_GcFlags_initialStkSize(RtsFlags),
        closure "ptr");
950

tibbe's avatar
tibbe committed
951 952 953 954
    /* 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));
955

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

tibbe's avatar
tibbe committed
958 959 960
    // 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
961

tibbe's avatar
tibbe committed
962
    return (threadid);
963 964
}

965
stg_yieldzh ()
simonmar's avatar