PrimOps.cmm 73.1 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"
26

27
#ifdef __PIC__
28 29
import pthread_mutex_lock;
import pthread_mutex_unlock;
30
#endif
31
import CLOSURE base_ControlziExceptionziBase_nestedAtomically_closure;
32 33
import EnterCriticalSection;
import LeaveCriticalSection;
34
import CLOSURE ghczmprim_GHCziTypes_False_closure;
35
#if defined(USE_MINIINTERPRETER) || !defined(mingw32_HOST_OS)
36
import CLOSURE sm_mutex;
37
#endif
38 39 40
#ifdef PROFILING
import CLOSURE CCS_MAIN;
#endif
41

42 43 44 45 46 47 48 49 50 51 52 53 54
/*-----------------------------------------------------------------------------
  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.
 */

55
stg_newByteArrayzh ( W_ n )
56
{
57 58 59 60 61
    W_ words, payload_words;
    gcptr p;

    MAYBE_GC_N(stg_newByteArrayzh, n);

62
    payload_words = ROUNDUP_BYTES_TO_WDS(n);
siddhanathan's avatar
siddhanathan committed
63
    words = BYTES_TO_WDS(SIZEOF_StgArrBytes) + payload_words;
64
    ("ptr" p) = ccall allocate(MyCapability() "ptr",words);
siddhanathan's avatar
siddhanathan committed
65
    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
66
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
siddhanathan's avatar
siddhanathan committed
67
    StgArrBytes_bytes(p) = n;
68
    return (p);
69 70
}

Simon Marlow's avatar
Simon Marlow committed
71 72 73
#define BA_ALIGN 16
#define BA_MASK  (BA_ALIGN-1)

74
stg_newPinnedByteArrayzh ( W_ n )
75
{
76 77 78 79
    W_ words, bytes, payload_words;
    gcptr p;

    MAYBE_GC_N(stg_newPinnedByteArrayzh, n);
80

81
    bytes = n;
82 83 84 85
    /* 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
86
    bytes = bytes + SIZEOF_StgArrBytes;
87 88 89 90 91
    /* 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
92

93
    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
siddhanathan's avatar
siddhanathan committed
94
    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
Simon Marlow's avatar
Simon Marlow committed
95

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

100
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
siddhanathan's avatar
siddhanathan committed
101
    StgArrBytes_bytes(p) = n;
102
    return (p);
Simon Marlow's avatar
Simon Marlow committed
103 104
}

105
stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment )
Simon Marlow's avatar
Simon Marlow committed
106
{
107 108
    W_ words, bytes, payload_words;
    gcptr p;
Simon Marlow's avatar
Simon Marlow committed
109

110
    again: MAYBE_GC(again);
Simon Marlow's avatar
Simon Marlow committed
111

112 113 114 115 116
    /* 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; }

117 118
    bytes = n;

119 120
    /* 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
121

122 123
    /* When we actually allocate memory, we need to allow space for the
       header: */
siddhanathan's avatar
siddhanathan committed
124
    bytes = bytes + SIZEOF_StgArrBytes;
125 126 127 128 129
    /* 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);
130

131
    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
siddhanathan's avatar
siddhanathan committed
132
    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
133

134 135 136
    /* 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
137
    p = p + ((-p - SIZEOF_StgArrBytes) & (alignment - 1));
138

139
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
siddhanathan's avatar
siddhanathan committed
140
    StgArrBytes_bytes(p) = n;
141
    return (p);
142 143
}

144 145 146 147 148 149 150 151 152 153 154
stg_isPinnedByteArrayzh ( gcptr mba )
// MutableByteArray# s -> Int#
{
    W_ bd, flags;
    bd = Bdescr(mba);
    // pinned byte arrays live in blocks with the BF_PINNED flag set.
    // See the comment in Storage.c:allocatePinned.
    flags = TO_W_(bdescr_flags(bd));
    return (flags & BF_PINNED != 0);
}

155 156 157 158 159
// 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
160
   ASSERT(new_size <= StgArrBytes_bytes(mba));
161

siddhanathan's avatar
siddhanathan committed
162
   OVERWRITING_CLOSURE_OFS(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) +
163
                                 ROUNDUP_BYTES_TO_WDS(new_size)));
siddhanathan's avatar
siddhanathan committed
164
   StgArrBytes_bytes(mba) = new_size;
165 166 167 168 169 170 171 172 173 174 175
   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
176
stg_resizzeMutableByteArrayzh ( gcptr mba, W_ new_size )
177 178 179 180 181 182 183 184 185
// 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
186
      OVERWRITING_CLOSURE_OFS(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) +
187
                                    new_size_wds));
siddhanathan's avatar
siddhanathan committed
188
      StgArrBytes_bytes(mba) = new_size;
189 190 191 192 193 194 195 196 197 198 199 200 201 202
      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
203
                   StgArrBytes_bytes(mba), SIZEOF_W);
204 205 206 207 208

      return (new_mba);
   }
}

209 210 211 212 213
// 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
214
    W_ p, h;
215

siddhanathan's avatar
siddhanathan committed
216
    p = arr + SIZEOF_StgArrBytes + WDS(ind);
217 218 219 220 221
    (h) = ccall cas(p, old, new);

    return(h);
}

222

223
stg_newArrayzh ( W_ n /* words */, gcptr init )
224
{
tibbe's avatar
tibbe committed
225 226
    W_ words, size, p;
    gcptr arr;
227

228
    again: MAYBE_GC(again);
229

230 231 232 233 234
    // 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;
235
    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
tibbe's avatar
tibbe committed
236
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
237

238
    SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
239
    StgMutArrPtrs_ptrs(arr) = n;
240
    StgMutArrPtrs_size(arr) = size;
241 242 243 244

    // Initialise all elements of the the array with the value in R2
    p = arr + SIZEOF_StgMutArrPtrs;
  for:
tibbe's avatar
tibbe committed
245
    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) {
ian@well-typed.com's avatar
ian@well-typed.com committed
246 247 248
        W_[p] = init;
        p = p + WDS(1);
        goto for;
249 250
    }

251
    return (arr);
252 253
}

254
stg_unsafeThawArrayzh ( gcptr arr )
255
{
tibbe's avatar
tibbe committed
256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274
    // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST
    //
    // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN
    // normally doesn't.  However, when we freeze a MUT_ARR_PTRS, we leave
    // it on the mutable list for the GC to remove (removing something from
    // the mutable list is not easy).
    //
    // So that we can tell whether a MUT_ARR_PTRS_FROZEN is on the mutable list,
    // 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.
    //
    // 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
    // the closure type is MUT_ARR_PTRS_FROZEN0 if it is on the mutable list,
    // 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.
    //
    if (StgHeader_info(arr) != stg_MUT_ARR_PTRS_FROZEN0_info) {
275 276
        SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
        recordMutable(arr);
ian@well-typed.com's avatar
ian@well-typed.com committed
277 278
        // must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
        return (arr);
tibbe's avatar
tibbe committed
279
    } else {
ian@well-typed.com's avatar
ian@well-typed.com committed
280 281
        SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
        return (arr);
tibbe's avatar
tibbe committed
282
    }
283 284
}

285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304
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)
}

305 306
stg_cloneArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
307
    cloneArray(stg_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
308 309 310 311
}

stg_cloneMutableArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
312
    cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
313 314 315 316 317
}

// We have to escape the "z" in the name.
stg_freezzeArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
318
    cloneArray(stg_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
319 320 321 322
}

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

326
// RRN: Uses the ticketed approach; see casMutVar
327
stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
328
/* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, Any a #) */
329
{
tibbe's avatar
tibbe committed
330 331
    gcptr h;
    W_ p, len;
332 333

    p = arr + SIZEOF_StgMutArrPtrs + WDS(ind);
334
    (h) = ccall cas(p, old, new);
335

336 337
    if (h != old) {
        // Failure, return what was there instead of 'old':
338
        return (1,h);
339 340
    } else {
        // Compare and Swap Succeeded:
rrnewton's avatar
rrnewton committed
341 342 343 344
        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;
345
        return (0,new);
346 347 348
    }
}

349
stg_newArrayArrayzh ( W_ n /* words */ )
350
{
tibbe's avatar
tibbe committed
351 352
    W_ words, size, p;
    gcptr arr;
353

354
    MAYBE_GC_N(stg_newArrayArrayzh, n);
355 356 357 358 359 360

    // 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;
361
    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
tibbe's avatar
tibbe committed
362
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
363 364 365 366 367 368 369 370

    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
371
    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) {
ian@well-typed.com's avatar
ian@well-typed.com committed
372 373 374
        W_[p] = arr;
        p = p + WDS(1);
        goto for;
375 376
    }

377
    return (arr);
378 379
}

pumpkin's avatar
pumpkin committed
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 442 443 444 445 446 447 448 449 450 451 452 453 454
/* -----------------------------------------------------------------------------
   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);
455
    prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
456 457 458 459 460 461 462 463 464 465 466 467 468 469

    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) {
470
        prim %memmove(dst_p, src_p, bytes, SIZEOF_W);
471
    } else {
472
        prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498
    }

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


499 500 501 502
/* -----------------------------------------------------------------------------
   MutVar primitives
   -------------------------------------------------------------------------- */

503
stg_newMutVarzh ( gcptr init )
504 505 506
{
    W_ mv;

507
    ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init);
508 509

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

513
    return (mv);
514 515
}

516 517 518 519 520
// 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.
521
stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
522
 /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, Any a #) */
Simon Marlow's avatar
Simon Marlow committed
523
{
524
    gcptr h;
Simon Marlow's avatar
Simon Marlow committed
525

tibbe's avatar
tibbe committed
526
    (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, old, new);
Simon Marlow's avatar
Simon Marlow committed
527
    if (h != old) {
528
        return (1,h);
Simon Marlow's avatar
Simon Marlow committed
529
    } else {
530
        if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
tibbe's avatar
tibbe committed
531
            ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
532
        }
533
        return (0,new);
Simon Marlow's avatar
Simon Marlow committed
534 535 536
    }
}

537
stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
538
{
539
    W_ z, x, y, r, h;
540

ian@well-typed.com's avatar
ian@well-typed.com committed
541
    /* If x is the current contents of the MutVar#, then
542 543 544
       We want to make the new contents point to

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

546
       and the return value is
ian@well-typed.com's avatar
ian@well-typed.com committed
547 548

         (sel_1 (f x))
549 550 551 552

        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
553
         y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
554 555 556 557
         r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
    */

#if MIN_UPD_SIZE > 1
558
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
559 560
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
#else
561
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
562 563 564 565
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
#endif

#if MIN_UPD_SIZE > 2
566
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
567 568
#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
#else
569
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(2))
570 571 572 573 574
#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
575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600
    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;
601
#ifdef THREADED_RTS
tibbe's avatar
tibbe committed
602 603
    (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y);
    if (h != x) { goto retry; }
604
#else
tibbe's avatar
tibbe committed
605
    StgMutVar_var(mv) = y;
606
#endif
607

tibbe's avatar
tibbe committed
608 609 610
    if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
        ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
    }
611

tibbe's avatar
tibbe committed
612
    return (r);
613 614 615 616 617 618 619 620
}

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

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

621 622 623
stg_mkWeakzh ( gcptr key,
               gcptr value,
               gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
624
{
tibbe's avatar
tibbe committed
625
    gcptr w;
626

tibbe's avatar
tibbe committed
627
    ALLOC_PRIM (SIZEOF_StgWeak)
628

tibbe's avatar
tibbe committed
629 630
    w = Hp - SIZEOF_StgWeak + WDS(1);
    SET_HDR(w, stg_WEAK_info, CCCS);
631

tibbe's avatar
tibbe committed
632 633 634 635
    StgWeak_key(w)         = key;
    StgWeak_value(w)       = value;
    StgWeak_finalizer(w)   = finalizer;
    StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
636

637 638 639 640 641
    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;
    }
642

tibbe's avatar
tibbe committed
643
    IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
644

tibbe's avatar
tibbe committed
645
    return (w);
646 647
}

648
stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
649
{
tibbe's avatar
tibbe committed
650
    jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
651 652
}

653 654 655 656 657 658 659
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 )
660
{
tibbe's avatar
tibbe committed
661
    W_ c, info;
662

tibbe's avatar
tibbe committed
663
    ALLOC_PRIM (SIZEOF_StgCFinalizerList)
664

tibbe's avatar
tibbe committed
665 666
    c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
    SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
667

tibbe's avatar
tibbe committed
668 669 670 671
    StgCFinalizerList_fptr(c) = fptr;
    StgCFinalizerList_ptr(c) = ptr;
    StgCFinalizerList_eptr(c) = eptr;
    StgCFinalizerList_flag(c) = flag;
672

tibbe's avatar
tibbe committed
673
    LOCK_CLOSURE(w, info);
674

tibbe's avatar
tibbe committed
675 676 677 678 679
    if (info == stg_DEAD_WEAK_info) {
        // Already dead.
        unlockClosure(w, info);
        return (0);
    }
680

tibbe's avatar
tibbe committed
681 682
    StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
    StgWeak_cfinalizers(w) = c;
683

tibbe's avatar
tibbe committed
684
    unlockClosure(w, info);
685

tibbe's avatar
tibbe committed
686
    recordMutable(w);
687

tibbe's avatar
tibbe committed
688
    IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
689

tibbe's avatar
tibbe committed
690
    return (1);
691
}
692

693
stg_finalizzeWeakzh ( gcptr w )
694
{
tibbe's avatar
tibbe committed
695 696
    gcptr f, list;
    W_ info;
697

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

tibbe's avatar
tibbe committed
700 701 702 703 704
    // already dead?
    if (info == stg_DEAD_WEAK_info) {
        unlockClosure(w, info);
        return (0,stg_NO_FINALIZER_closure);
    }
705

tibbe's avatar
tibbe committed
706 707
    f    = StgWeak_finalizer(w);
    list = StgWeak_cfinalizers(w);
708

tibbe's avatar
tibbe committed
709
    // kill it
710
#ifdef PROFILING
tibbe's avatar
tibbe committed
711 712 713 714 715 716 717 718 719
    // @LDV profiling
    // A weak pointer is inherently used, so we do not need to call
    // LDV_recordDead_FILL_SLOP_DYNAMIC():
    //    LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
    // or, LDV_recordDead():
    //    LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
    // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
    // large as weak pointers, so there is no need to fill the slop, either.
    // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
720 721
#endif

tibbe's avatar
tibbe committed
722 723 724 725
    //
    // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
    //
    unlockClosure(w, stg_DEAD_WEAK_info);
726

tibbe's avatar
tibbe committed
727
    LDV_RECORD_CREATE(w);
728

tibbe's avatar
tibbe committed
729 730 731
    if (list != stg_NO_FINALIZER_closure) {
      ccall runCFinalizers(list);
    }
732

tibbe's avatar
tibbe committed
733 734 735 736 737 738
    /* return the finalizer */
    if (f == stg_NO_FINALIZER_closure) {
        return (0,stg_NO_FINALIZER_closure);
    } else {
        return (1,f);
    }
739 740
}

741
stg_deRefWeakzh ( gcptr w )
742
{
tibbe's avatar
tibbe committed
743 744
    W_ code, info;
    gcptr val;
745

tibbe's avatar
tibbe committed
746
    info = GET_INFO(w);
747

tibbe's avatar
tibbe committed
748 749 750 751
    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.
752

tibbe's avatar
tibbe committed
753 754 755
        LOCK_CLOSURE(w, info);
        unlockClosure(w, info);
    }
756

tibbe's avatar
tibbe committed
757 758 759 760 761 762 763 764
    if (info == stg_WEAK_info) {
        code = 1;
        val = StgWeak_value(w);
    } else {
        code = 0;
        val = w;
    }
    return (code,val);
765 766 767
}

/* -----------------------------------------------------------------------------
768
   Floating point operations.
769 770
   -------------------------------------------------------------------------- */

771
stg_decodeFloatzuIntzh ( F_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
772
{
773
    W_ p;
774
    W_ tmp, mp_tmp1, mp_tmp_w, r1, r2;
775

776
    STK_CHK_GEN_N (WDS(2));
777

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

tibbe's avatar
tibbe committed
780 781
        mp_tmp1  = tmp + WDS(1);
        mp_tmp_w = tmp;
782

tibbe's avatar
tibbe committed
783 784
        /* Perform the operation */
        ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
785

tibbe's avatar
tibbe committed
786 787
        r1 = W_[mp_tmp1];
        r2 = W_[mp_tmp_w];
788
    }
ian@well-typed.com's avatar
ian@well-typed.com committed
789

790
    /* returns: (Int# (mantissa), Int# (exponent)) */
791
    return (r1, r2);
792 793
}

794
stg_decodeDoublezu2Intzh ( D_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
795
{
796 797 798
    W_ p, tmp;
    W_ mp_tmp1, mp_tmp2, mp_result1, mp_result2;
    W_ r1, r2, r3, r4;
799

800
    STK_CHK_GEN_N (WDS(4));
801

802 803
    reserve 4 = tmp {

tibbe's avatar
tibbe committed
804 805 806 807
        mp_tmp1    = tmp + WDS(3);
        mp_tmp2    = tmp + WDS(2);
        mp_result1 = tmp + WDS(1);
        mp_result2 = tmp;
808

tibbe's avatar
tibbe committed
809 810 811 812 813 814 815 816 817
        /* 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];
818
    }
819 820 821

    /* returns:
       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
822
    return (r1, r2, r3, r4);
823 824
}

825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840
/* 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));
}

841 842 843 844
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

845
stg_forkzh ( gcptr closure )
846
{
tibbe's avatar
tibbe committed
847
    MAYBE_GC_P(stg_forkzh, closure);
848

tibbe's avatar
tibbe committed
849
    gcptr threadid;
850

tibbe's avatar
tibbe committed
851 852 853
    ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
                                  RtsFlags_GcFlags_initialStkSize(RtsFlags),
                                  closure "ptr");
854

tibbe's avatar
tibbe committed
855 856 857 858
    /* 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));
859

tibbe's avatar
tibbe committed
860
    ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
861

tibbe's avatar
tibbe committed
862 863 864
    // 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
865

tibbe's avatar
tibbe committed
866
    return (threadid);
867 868
}

869
stg_forkOnzh ( W_ cpu, gcptr closure )
870
{
871
again: MAYBE_GC(again);
872

tibbe's avatar
tibbe committed
873
    gcptr threadid;
874

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

tibbe's avatar
tibbe committed
880 881 882 883
    /* 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));
884

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

tibbe's avatar
tibbe committed
887 888 889
    // 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
890

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

894
stg_yieldzh ()
895
{
tibbe's avatar
tibbe committed
896 897 898 899 900 901
    // 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();
902 903
}

904
stg_myThreadIdzh ()
905
{
tibbe's avatar
tibbe committed
906
    return (CurrentTSO);
907 908
}

909
stg_labelThreadzh ( gcptr threadid, W_ addr )
910
{
911
#if defined(DEBUG) || defined(TRACING) || defined(DTRACE)
tibbe's avatar
tibbe committed
912
    ccall labelThread(MyCapability() "ptr", threadid "ptr", addr "ptr");
913
#endif
tibbe's avatar
tibbe committed
914
    return ();
915 916
}

917
stg_isCurrentThreadBoundzh (/* no args */)
918
{
tibbe's avatar
tibbe committed
919 920 921
    W_ r;
    (r) = ccall isThreadBound(CurrentTSO);
    return (r);
922 923
}

924
stg_threadStatuszh ( gcptr tso )
925 926 927
{
    W_ why_blocked;
    W_ what_next;
928
    W_ ret, cap, locked;
929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945

    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;
        }
    }
946 947 948 949 950 951 952 953 954

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

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

955
    return (ret,cap,locked);
956
}
957 958 959 960 961

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

962 963 964
// Catch retry frame -----------------------------------------------------------

#define CATCH_RETRY_FRAME_FIELDS(w_,p_,info_ptr,        \
Simon Marlow's avatar
Simon Marlow committed
965
                                 p1, p2,                \
966 967 968 969
                                 running_alt_code,      \
                                 first_code,            \
                                 alt_code)              \
  w_ info_ptr,                                          \
Simon Marlow's avatar
Simon Marlow committed
970
  PROF_HDR_FIELDS(w_,p1,p2)                             \
971 972 973
  w_ running_alt_code,                                  \
  p_ first_code,                                        \
  p_ alt_code
974 975


976
INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
977
               CATCH_RETRY_FRAME_FIELDS(W_,P_,
Simon Marlow's avatar
Simon Marlow committed
978
                                        info_ptr, p1, p2,
979 980 981 982
                                        running_alt_code,
                                        first_code,
                                        alt_code))
    return (P_ ret)
983
{
984 985
    W_ r;
    gcptr trec, outer, arg;
986

987 988 989 990 991 992 993 994 995