PrimOps.cmm 74.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"
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 34
import EnterCriticalSection;
import LeaveCriticalSection;
35
import CLOSURE ghczmprim_GHCziTypes_False_closure;
36
#if defined(USE_MINIINTERPRETER) || !defined(mingw32_HOST_OS)
37
import CLOSURE sm_mutex;
38
#endif
Ben Gamari's avatar
Ben Gamari committed
39
#if defined(PROFILING)
40 41
import CLOSURE CCS_MAIN;
#endif
42

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

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

    MAYBE_GC_N(stg_newByteArrayzh, n);

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

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

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

    MAYBE_GC_N(stg_newPinnedByteArrayzh, n);
81

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

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

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

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

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

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

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

118 119
    bytes = n;

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

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

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

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

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

145 146
stg_isByteArrayPinnedzh ( gcptr ba )
// ByteArray# s -> Int#
147 148
{
    W_ bd, flags;
149
    bd = Bdescr(ba);
150
    // Pinned byte arrays live in blocks with the BF_PINNED flag set.
Gabor Greif's avatar
Gabor Greif committed
151
    // We also consider BF_LARGE objects to be immovable. See #13894.
152 153
    // See the comment in Storage.c:allocatePinned.
    flags = TO_W_(bdescr_flags(bd));
154
    return (flags & (BF_PINNED | BF_LARGE) != 0);
155 156
}

157 158 159 160 161 162
stg_isMutableByteArrayPinnedzh ( gcptr mba )
// MutableByteArray# s -> Int#
{
    jump stg_isByteArrayPinnedzh(mba);
}

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

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

      return (new_mba);
   }
}

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

siddhanathan's avatar
siddhanathan committed
224
    p = arr + SIZEOF_StgArrBytes + WDS(ind);
225
    (h) = prim %cmpxchgW(p, old, new);
226 227 228 229

    return(h);
}

230

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

236
    again: MAYBE_GC(again);
237

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

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

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

259
    return (arr);
260 261
}

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

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

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

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

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

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

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

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

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

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

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

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

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

385
    return (arr);
386 387
}

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

    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) {
478
        prim %memmove(dst_p, src_p, bytes, SIZEOF_W);
479
    } else {
480
        prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
481 482 483 484 485 486 487 488 489 490 491 492 493
    }

    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);
494
    (h) = prim %cmpxchgW(p, old, new);
495 496 497 498 499 500 501 502 503 504 505 506

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


507 508 509 510
/* -----------------------------------------------------------------------------
   MutVar primitives
   -------------------------------------------------------------------------- */

511
stg_newMutVarzh ( gcptr init )
512 513 514
{
    W_ mv;

515
    ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init);
516 517

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

521
    return (mv);
522 523
}

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

535
    (h) = prim %cmpxchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, old, new);
Simon Marlow's avatar
Simon Marlow committed
536
    if (h != old) {
537
        return (1,h);
Simon Marlow's avatar
Simon Marlow committed
538
    } else {
539
        if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
tibbe's avatar
tibbe committed
540
            ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
541
        }
542
        return (0,new);
Simon Marlow's avatar
Simon Marlow committed
543
    }
544 545 546 547 548 549 550 551 552 553 554 555 556 557
#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
558 559
}

560
stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
561
{
562
    W_ z, x, y, r, h;
563

ian@well-typed.com's avatar
ian@well-typed.com committed
564
    /* If x is the current contents of the MutVar#, then
565 566 567
       We want to make the new contents point to

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

569
       and the return value is
ian@well-typed.com's avatar
ian@well-typed.com committed
570 571

         (sel_1 (f x))
572 573 574 575

        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
576
         y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
577 578 579
         r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
    */

580
#if defined(MIN_UPD_SIZE) && MIN_UPD_SIZE > 1
581
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
582 583
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
#else
584
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
585 586 587
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
#endif

588
#if defined(MIN_UPD_SIZE) && MIN_UPD_SIZE > 2
589
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
590 591
#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
#else
592
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(2))
593 594 595 596 597
#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
598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623
    HP_CHK_GEN_TICKY(SIZE);

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

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

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

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

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

tibbe's avatar
tibbe committed
635
    return (r);
636 637 638 639 640 641 642 643
}

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

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

644 645 646
stg_mkWeakzh ( gcptr key,
               gcptr value,
               gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
647
{
tibbe's avatar
tibbe committed
648
    gcptr w;
649

tibbe's avatar
tibbe committed
650
    ALLOC_PRIM (SIZEOF_StgWeak)
651

tibbe's avatar
tibbe committed
652 653
    w = Hp - SIZEOF_StgWeak + WDS(1);
    SET_HDR(w, stg_WEAK_info, CCCS);
654

tibbe's avatar
tibbe committed
655 656 657 658
    StgWeak_key(w)         = key;
    StgWeak_value(w)       = value;
    StgWeak_finalizer(w)   = finalizer;
    StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
659

660 661 662 663 664
    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;
    }
665

tibbe's avatar
tibbe committed
666
    IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
667

tibbe's avatar
tibbe committed
668
    return (w);
669 670
}

671
stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
672
{
tibbe's avatar
tibbe committed
673
    jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
674 675
}

676 677 678 679 680 681 682
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 )
683
{
tibbe's avatar
tibbe committed
684
    W_ c, info;
685

tibbe's avatar
tibbe committed
686
    ALLOC_PRIM (SIZEOF_StgCFinalizerList)
687

tibbe's avatar
tibbe committed
688 689
    c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
    SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
690

tibbe's avatar
tibbe committed
691 692 693 694
    StgCFinalizerList_fptr(c) = fptr;
    StgCFinalizerList_ptr(c) = ptr;
    StgCFinalizerList_eptr(c) = eptr;
    StgCFinalizerList_flag(c) = flag;
695

tibbe's avatar
tibbe committed
696
    LOCK_CLOSURE(w, info);
697

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

tibbe's avatar
tibbe committed
704 705
    StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
    StgWeak_cfinalizers(w) = c;
706

tibbe's avatar
tibbe committed
707
    unlockClosure(w, info);
708

tibbe's avatar
tibbe committed
709
    recordMutable(w);
710

tibbe's avatar
tibbe committed
711
    IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
712

tibbe's avatar
tibbe committed
713
    return (1);
714
}
715

716
stg_finalizzeWeakzh ( gcptr w )
717
{
tibbe's avatar
tibbe committed
718 719
    gcptr f, list;
    W_ info;
720

tibbe's avatar
tibbe committed
721
    LOCK_CLOSURE(w, info);
722

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

tibbe's avatar
tibbe committed
729 730
    f    = StgWeak_finalizer(w);
    list = StgWeak_cfinalizers(w);
731

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

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

tibbe's avatar
tibbe committed
750
    LDV_RECORD_CREATE(w);
751

tibbe's avatar
tibbe committed
752 753 754
    if (list != stg_NO_FINALIZER_closure) {
      ccall runCFinalizers(list);
    }
755

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

764
stg_deRefWeakzh ( gcptr w )
765
{
tibbe's avatar
tibbe committed
766 767
    W_ code, info;
    gcptr val;
768

tibbe's avatar
tibbe committed
769
    info = GET_INFO(w);
770

tibbe's avatar
tibbe committed
771 772 773 774
    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.
775

tibbe's avatar
tibbe committed
776 777 778
        LOCK_CLOSURE(w, info);
        unlockClosure(w, info);
    }
779

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

/* -----------------------------------------------------------------------------
791
   Floating point operations.
792 793
   -------------------------------------------------------------------------- */

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

799
    STK_CHK_GEN_N (WDS(2));
800

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

tibbe's avatar
tibbe committed
803 804
        mp_tmp1  = tmp + WDS(1);
        mp_tmp_w = tmp;
805

tibbe's avatar
tibbe committed
806 807
        /* Perform the operation */
        ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
808

tibbe's avatar
tibbe committed
809 810
        r1 = W_[mp_tmp1];
        r2 = W_[mp_tmp_w];
811
    }
ian@well-typed.com's avatar
ian@well-typed.com committed
812

813
    /* returns: (Int# (mantissa), Int# (exponent)) */
814
    return (r1, r2);
815 816
}

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

823
    STK_CHK_GEN_N (WDS(4));
824

825 826
    reserve 4 = tmp {

tibbe's avatar
tibbe committed
827 828 829 830
        mp_tmp1    = tmp + WDS(3);
        mp_tmp2    = tmp + WDS(2);
        mp_result1 = tmp + WDS(1);
        mp_result2 = tmp;
831

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

    /* returns:
       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
845
    return (r1, r2, r3, r4);
846 847
}

848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863
/* 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));
}

864 865 866 867
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

868
stg_forkzh ( gcptr closure )
869
{
tibbe's avatar
tibbe committed
870
    MAYBE_GC_P(stg_forkzh, closure);
871

tibbe's avatar
tibbe committed
872
    gcptr threadid;
873

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

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

tibbe's avatar
tibbe committed
883
    ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
884

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

tibbe's avatar
tibbe committed
889
    return (threadid);
890 891
}

892
stg_forkOnzh ( W_ cpu, gcptr closure )
893
{
894
again: MAYBE_GC(again);
895

tibbe's avatar
tibbe committed
896
    gcptr threadid;
897

tibbe's avatar
tibbe committed
898 899 900 901
    ("ptr" threadid) = ccall createIOThread(
        MyCapability() "ptr",
        RtsFlags_GcFlags_initialStkSize(RtsFlags),
        closure "ptr");
902

tibbe's avatar
tibbe committed
903 904 905 906
    /* 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));
907

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

tibbe's avatar
tibbe committed
910 911 912
    // 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
913

tibbe's avatar
tibbe committed
914
    return (threadid);
915 916
}

917
stg_yieldzh ()
918
{
tibbe's avatar
tibbe committed
919 920 921 922 923 924
    // 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();
925 926
}

927
stg_myThreadIdzh ()
928
{
tibbe's avatar
tibbe committed
929
    return (CurrentTSO);
930 931
}

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

940
stg_isCurrentThreadBoundzh (/* no args */)
941
{
tibbe's avatar
tibbe committed
942 943 944
    W_ r;
    (r) = ccall isThreadBound(CurrentTSO);
    return (r);
945 946
}

947
stg_threadStatuszh ( gcptr tso )
948 949 950
{
    W_ why_blocked;
    W_ what_next;
951
    W_ ret, cap, locked;
952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968

    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;
        }
    }
969 970 971 972 973 974 975 976 977

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

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