PrimOps.cmm 73.2 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
stg_isByteArrayPinnedzh ( gcptr ba )
// ByteArray# s -> Int#
146 147
{
    W_ bd, flags;
148
    bd = Bdescr(ba);
149 150 151 152 153 154
    // 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 160
stg_isMutableByteArrayPinnedzh ( gcptr mba )
// MutableByteArray# s -> Int#
{
    jump stg_isByteArrayPinnedzh(mba);
}

161 162 163 164 165
// 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
166
   ASSERT(new_size <= StgArrBytes_bytes(mba));
167

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

      return (new_mba);
   }
}

215 216 217 218 219
// 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
220
    W_ p, h;
221

siddhanathan's avatar
siddhanathan committed
222
    p = arr + SIZEOF_StgArrBytes + WDS(ind);
223 224 225 226 227
    (h) = ccall cas(p, old, new);

    return(h);
}

228

229
stg_newArrayzh ( W_ n /* words */, gcptr init )
230
{
tibbe's avatar
tibbe committed
231 232
    W_ words, size, p;
    gcptr arr;
233

234
    again: MAYBE_GC(again);
235

236 237 238 239 240
    // 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;
241
    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
tibbe's avatar
tibbe committed
242
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
243

244
    SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
245
    StgMutArrPtrs_ptrs(arr) = n;
246
    StgMutArrPtrs_size(arr) = size;
247 248 249 250

    // Initialise all elements of the the array with the value in R2
    p = arr + SIZEOF_StgMutArrPtrs;
  for:
tibbe's avatar
tibbe committed
251
    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) {
ian@well-typed.com's avatar
ian@well-typed.com committed
252 253 254
        W_[p] = init;
        p = p + WDS(1);
        goto for;
255 256
    }

257
    return (arr);
258 259
}

260
stg_unsafeThawArrayzh ( gcptr arr )
261
{
tibbe's avatar
tibbe committed
262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280
    // 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) {
281 282
        SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
        recordMutable(arr);
ian@well-typed.com's avatar
ian@well-typed.com committed
283 284
        // must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
        return (arr);
tibbe's avatar
tibbe committed
285
    } else {
ian@well-typed.com's avatar
ian@well-typed.com committed
286 287
        SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
        return (arr);
tibbe's avatar
tibbe committed
288
    }
289 290
}

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

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

stg_cloneMutableArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
318
    cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
319 320 321 322 323
}

// We have to escape the "z" in the name.
stg_freezzeArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
324
    cloneArray(stg_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
325 326 327 328
}

stg_thawArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
329
    cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
330 331
}

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

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

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

355
stg_newArrayArrayzh ( W_ n /* words */ )
356
{
tibbe's avatar
tibbe committed
357 358
    W_ words, size, p;
    gcptr arr;
359

360
    MAYBE_GC_N(stg_newArrayArrayzh, n);
361 362 363 364 365 366

    // 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;
367
    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
tibbe's avatar
tibbe committed
368
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
369 370 371 372 373 374 375 376

    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
377
    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) {
ian@well-typed.com's avatar
ian@well-typed.com committed
378 379 380
        W_[p] = arr;
        p = p + WDS(1);
        goto for;
381 382
    }

383
    return (arr);
384 385
}

pumpkin's avatar
pumpkin committed
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 455 456 457 458 459 460
/* -----------------------------------------------------------------------------
   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);
461
    prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
462 463 464 465 466 467 468 469 470 471 472 473 474 475

    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) {
476
        prim %memmove(dst_p, src_p, bytes, SIZEOF_W);
477
    } else {
478
        prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504
    }

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


505 506 507 508
/* -----------------------------------------------------------------------------
   MutVar primitives
   -------------------------------------------------------------------------- */

509
stg_newMutVarzh ( gcptr init )
510 511 512
{
    W_ mv;

513
    ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init);
514 515

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

519
    return (mv);
520 521
}

522 523 524 525 526
// 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.
527
stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
528
 /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, Any a #) */
Simon Marlow's avatar
Simon Marlow committed
529
{
530
    gcptr h;
Simon Marlow's avatar
Simon Marlow committed
531

tibbe's avatar
tibbe committed
532
    (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, old, new);
Simon Marlow's avatar
Simon Marlow committed
533
    if (h != old) {
534
        return (1,h);
Simon Marlow's avatar
Simon Marlow committed
535
    } else {
536
        if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
tibbe's avatar
tibbe committed
537
            ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
538
        }
539
        return (0,new);
Simon Marlow's avatar
Simon Marlow committed
540 541 542
    }
}

543
stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
544
{
545
    W_ z, x, y, r, h;
546

ian@well-typed.com's avatar
ian@well-typed.com committed
547
    /* If x is the current contents of the MutVar#, then
548 549 550
       We want to make the new contents point to

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

552
       and the return value is
ian@well-typed.com's avatar
ian@well-typed.com committed
553 554

         (sel_1 (f x))
555 556 557 558

        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
559
         y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
560 561 562 563
         r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
    */

#if MIN_UPD_SIZE > 1
564
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
565 566
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
#else
567
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
568 569 570 571
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
#endif

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

tibbe's avatar
tibbe committed
614 615 616
    if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
        ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
    }
617

tibbe's avatar
tibbe committed
618
    return (r);
619 620 621 622 623 624 625 626
}

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

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

627 628 629
stg_mkWeakzh ( gcptr key,
               gcptr value,
               gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
630
{
tibbe's avatar
tibbe committed
631
    gcptr w;
632

tibbe's avatar
tibbe committed
633
    ALLOC_PRIM (SIZEOF_StgWeak)
634

tibbe's avatar
tibbe committed
635 636
    w = Hp - SIZEOF_StgWeak + WDS(1);
    SET_HDR(w, stg_WEAK_info, CCCS);
637

tibbe's avatar
tibbe committed
638 639 640 641
    StgWeak_key(w)         = key;
    StgWeak_value(w)       = value;
    StgWeak_finalizer(w)   = finalizer;
    StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
642

643 644 645 646 647
    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;
    }
648

tibbe's avatar
tibbe committed
649
    IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
650

tibbe's avatar
tibbe committed
651
    return (w);
652 653
}

654
stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
655
{
tibbe's avatar
tibbe committed
656
    jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
657 658
}

659 660 661 662 663 664 665
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 )
666
{
tibbe's avatar
tibbe committed
667
    W_ c, info;
668

tibbe's avatar
tibbe committed
669
    ALLOC_PRIM (SIZEOF_StgCFinalizerList)
670

tibbe's avatar
tibbe committed
671 672
    c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
    SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
673

tibbe's avatar
tibbe committed
674 675 676 677
    StgCFinalizerList_fptr(c) = fptr;
    StgCFinalizerList_ptr(c) = ptr;
    StgCFinalizerList_eptr(c) = eptr;
    StgCFinalizerList_flag(c) = flag;
678

tibbe's avatar
tibbe committed
679
    LOCK_CLOSURE(w, info);
680

tibbe's avatar
tibbe committed
681 682 683 684 685
    if (info == stg_DEAD_WEAK_info) {
        // Already dead.
        unlockClosure(w, info);
        return (0);
    }
686

tibbe's avatar
tibbe committed
687 688
    StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
    StgWeak_cfinalizers(w) = c;
689

tibbe's avatar
tibbe committed
690
    unlockClosure(w, info);
691

tibbe's avatar
tibbe committed
692
    recordMutable(w);
693

tibbe's avatar
tibbe committed
694
    IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
695

tibbe's avatar
tibbe committed
696
    return (1);
697
}
698

699
stg_finalizzeWeakzh ( gcptr w )
700
{
tibbe's avatar
tibbe committed
701 702
    gcptr f, list;
    W_ info;
703

tibbe's avatar
tibbe committed
704
    LOCK_CLOSURE(w, info);
705

tibbe's avatar
tibbe committed
706 707 708 709 710
    // already dead?
    if (info == stg_DEAD_WEAK_info) {
        unlockClosure(w, info);
        return (0,stg_NO_FINALIZER_closure);
    }
711

tibbe's avatar
tibbe committed
712 713
    f    = StgWeak_finalizer(w);
    list = StgWeak_cfinalizers(w);
714

tibbe's avatar
tibbe committed
715
    // kill it
716
#ifdef PROFILING
tibbe's avatar
tibbe committed
717 718 719 720 721 722 723 724 725
    // @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.
726 727
#endif

tibbe's avatar
tibbe committed
728 729 730 731
    //
    // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
    //
    unlockClosure(w, stg_DEAD_WEAK_info);
732

tibbe's avatar
tibbe committed
733
    LDV_RECORD_CREATE(w);
734

tibbe's avatar
tibbe committed
735 736 737
    if (list != stg_NO_FINALIZER_closure) {
      ccall runCFinalizers(list);
    }
738

tibbe's avatar
tibbe committed
739 740 741 742 743 744
    /* return the finalizer */
    if (f == stg_NO_FINALIZER_closure) {
        return (0,stg_NO_FINALIZER_closure);
    } else {
        return (1,f);
    }
745 746
}

747
stg_deRefWeakzh ( gcptr w )
748
{
tibbe's avatar
tibbe committed
749 750
    W_ code, info;
    gcptr val;
751

tibbe's avatar
tibbe committed
752
    info = GET_INFO(w);
753

tibbe's avatar
tibbe committed
754 755 756 757
    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.
758

tibbe's avatar
tibbe committed
759 760 761
        LOCK_CLOSURE(w, info);
        unlockClosure(w, info);
    }
762

tibbe's avatar
tibbe committed
763 764 765 766 767 768 769 770
    if (info == stg_WEAK_info) {
        code = 1;
        val = StgWeak_value(w);
    } else {
        code = 0;
        val = w;
    }
    return (code,val);
771 772 773
}

/* -----------------------------------------------------------------------------
774
   Floating point operations.
775 776
   -------------------------------------------------------------------------- */

777
stg_decodeFloatzuIntzh ( F_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
778
{
779
    W_ p;
780
    W_ tmp, mp_tmp1, mp_tmp_w, r1, r2;
781

782
    STK_CHK_GEN_N (WDS(2));
783

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

tibbe's avatar
tibbe committed
786 787
        mp_tmp1  = tmp + WDS(1);
        mp_tmp_w = tmp;
788

tibbe's avatar
tibbe committed
789 790
        /* Perform the operation */
        ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
791

tibbe's avatar
tibbe committed
792 793
        r1 = W_[mp_tmp1];
        r2 = W_[mp_tmp_w];
794
    }
ian@well-typed.com's avatar
ian@well-typed.com committed
795

796
    /* returns: (Int# (mantissa), Int# (exponent)) */
797
    return (r1, r2);
798 799
}

800
stg_decodeDoublezu2Intzh ( D_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
801
{
802 803 804
    W_ p, tmp;
    W_ mp_tmp1, mp_tmp2, mp_result1, mp_result2;
    W_ r1, r2, r3, r4;
805

806
    STK_CHK_GEN_N (WDS(4));
807

808 809
    reserve 4 = tmp {

tibbe's avatar
tibbe committed
810 811 812 813
        mp_tmp1    = tmp + WDS(3);
        mp_tmp2    = tmp + WDS(2);
        mp_result1 = tmp + WDS(1);
        mp_result2 = tmp;
814

tibbe's avatar
tibbe committed
815 816 817 818 819 820 821 822 823
        /* 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];
824
    }
825 826 827

    /* returns:
       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
828
    return (r1, r2, r3, r4);
829 830
}

831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846
/* 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));
}

847 848 849 850
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

851
stg_forkzh ( gcptr closure )
852
{
tibbe's avatar
tibbe committed
853
    MAYBE_GC_P(stg_forkzh, closure);
854

tibbe's avatar
tibbe committed
855
    gcptr threadid;
856

tibbe's avatar
tibbe committed
857 858 859
    ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
                                  RtsFlags_GcFlags_initialStkSize(RtsFlags),
                                  closure "ptr");
860

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

tibbe's avatar
tibbe committed
866
    ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
867

tibbe's avatar
tibbe committed
868 869 870
    // 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
871

tibbe's avatar
tibbe committed
872
    return (threadid);
873 874
}

875
stg_forkOnzh ( W_ cpu, gcptr closure )
876
{
877
again: MAYBE_GC(again);
878

tibbe's avatar
tibbe committed
879
    gcptr threadid;
880

tibbe's avatar
tibbe committed
881 882 883 884
    ("ptr" threadid) = ccall createIOThread(
        MyCapability() "ptr",
        RtsFlags_GcFlags_initialStkSize(RtsFlags),
        closure "ptr");
885

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

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

tibbe's avatar
tibbe committed
893 894 895
    // 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
896

tibbe's avatar
tibbe committed
897
    return (threadid);
898 899
}

900
stg_yieldzh ()
901
{
tibbe's avatar
tibbe committed
902 903 904 905 906 907
    // 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();
908 909
}

910
stg_myThreadIdzh ()
911
{
tibbe's avatar
tibbe committed
912
    return (CurrentTSO);
913 914
}

915
stg_labelThreadzh ( gcptr threadid, W_ addr )
916
{
917
#if defined(DEBUG) || defined(TRACING) || defined(DTRACE)
tibbe's avatar
tibbe committed
918
    ccall labelThread(MyCapability() "ptr", threadid "ptr", addr "ptr");
919
#endif
tibbe's avatar
tibbe committed
920
    return ();
921 922
}

923
stg_isCurrentThreadBoundzh (/* no args */)
924
{
tibbe's avatar
tibbe committed
925 926 927
    W_ r;
    (r) = ccall isThreadBound(CurrentTSO);
    return (r);
928 929
}

930
stg_threadStatuszh ( gcptr tso )
931 932 933
{
    W_ why_blocked;
    W_ what_next;
934
    W_ ret, cap, locked;
935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951

    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;
        }
    }
952 953 954 955 956 957 958 959 960

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

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

961
    return (ret,cap,locked);
962
}
963 964 965 966 967

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

968 969 970
// Catch retry frame -----------------------------------------------------------

#define CATCH_RETRY_FRAME_FIELDS(w_,p_,info_ptr,        \
Simon Marlow's avatar
Simon Marlow committed
971
                                 p1, p2,                \
972 973 974 975
                                 running_alt_code,      \
                                 first_code,            \
                                 alt_code)              \
  w_ info_ptr,                                          \
Simon Marlow's avatar
Simon Marlow committed
976
  PROF_HDR_FIELDS(w_,p1,p2)                             \
977 978 979
  w_ running_alt_code,                                  \
  p_ first_code,                                        \
  p_ alt_code
980 981


982
INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
983
               CATCH_RETRY_FRAME_FIELDS(W_,P_,
Simon Marlow's avatar
Simon Marlow committed
984
                                        info_ptr, p1, p2,
985 986 987 988
                                        running_alt_code,
                                        first_code,
                                        alt_code))
    return (P_ ret)