PrimOps.cmm 72.8 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
// 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
149
   ASSERT(new_size <= StgArrBytes_bytes(mba));
150

siddhanathan's avatar
siddhanathan committed
151
   OVERWRITING_CLOSURE_OFS(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) +
152
                                 ROUNDUP_BYTES_TO_WDS(new_size)));
siddhanathan's avatar
siddhanathan committed
153
   StgArrBytes_bytes(mba) = new_size;
154 155 156 157 158 159 160 161 162 163 164
   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
165
stg_resizzeMutableByteArrayzh ( gcptr mba, W_ new_size )
166 167 168 169 170 171 172 173 174
// 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
175
      OVERWRITING_CLOSURE_OFS(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) +
176
                                    new_size_wds));
siddhanathan's avatar
siddhanathan committed
177
      StgArrBytes_bytes(mba) = new_size;
178 179 180 181 182 183 184 185 186 187 188 189 190 191
      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
192
                   StgArrBytes_bytes(mba), SIZEOF_W);
193 194 195 196 197

      return (new_mba);
   }
}

198 199 200 201 202
// 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
203
    W_ p, h;
204

siddhanathan's avatar
siddhanathan committed
205
    p = arr + SIZEOF_StgArrBytes + WDS(ind);
206 207 208 209 210
    (h) = ccall cas(p, old, new);

    return(h);
}

211

212
stg_newArrayzh ( W_ n /* words */, gcptr init )
213
{
tibbe's avatar
tibbe committed
214 215
    W_ words, size, p;
    gcptr arr;
216

217
    again: MAYBE_GC(again);
218

219 220 221 222 223
    // 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;
224
    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
tibbe's avatar
tibbe committed
225
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
226

227
    SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
228
    StgMutArrPtrs_ptrs(arr) = n;
229
    StgMutArrPtrs_size(arr) = size;
230 231 232 233

    // Initialise all elements of the the array with the value in R2
    p = arr + SIZEOF_StgMutArrPtrs;
  for:
tibbe's avatar
tibbe committed
234
    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) {
ian@well-typed.com's avatar
ian@well-typed.com committed
235 236 237
        W_[p] = init;
        p = p + WDS(1);
        goto for;
238 239
    }

240
    return (arr);
241 242
}

243
stg_unsafeThawArrayzh ( gcptr arr )
244
{
tibbe's avatar
tibbe committed
245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263
    // 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) {
264 265
        SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
        recordMutable(arr);
ian@well-typed.com's avatar
ian@well-typed.com committed
266 267
        // must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
        return (arr);
tibbe's avatar
tibbe committed
268
    } else {
ian@well-typed.com's avatar
ian@well-typed.com committed
269 270
        SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
        return (arr);
tibbe's avatar
tibbe committed
271
    }
272 273
}

274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293
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)
}

294 295
stg_cloneArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
296
    cloneArray(stg_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
297 298 299 300
}

stg_cloneMutableArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
301
    cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
302 303 304 305 306
}

// We have to escape the "z" in the name.
stg_freezzeArrayzh ( 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_thawArrayzh ( 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
// RRN: Uses the ticketed approach; see casMutVar
316
stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
317
/* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, Any a #) */
318
{
tibbe's avatar
tibbe committed
319 320
    gcptr h;
    W_ p, len;
321 322

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

325 326
    if (h != old) {
        // Failure, return what was there instead of 'old':
327
        return (1,h);
328 329
    } else {
        // Compare and Swap Succeeded:
rrnewton's avatar
rrnewton committed
330 331 332 333
        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;
334
        return (0,new);
335 336 337
    }
}

338
stg_newArrayArrayzh ( W_ n /* words */ )
339
{
tibbe's avatar
tibbe committed
340 341
    W_ words, size, p;
    gcptr arr;
342

343
    MAYBE_GC_N(stg_newArrayArrayzh, n);
344 345 346 347 348 349

    // 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;
350
    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
tibbe's avatar
tibbe committed
351
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
352 353 354 355 356 357 358 359

    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
360
    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) {
ian@well-typed.com's avatar
ian@well-typed.com committed
361 362 363
        W_[p] = arr;
        p = p + WDS(1);
        goto for;
364 365
    }

366
    return (arr);
367 368
}

pumpkin's avatar
pumpkin committed
369

370 371 372 373 374 375 376 377 378 379 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
/* -----------------------------------------------------------------------------
   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);
444
    prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
445 446 447 448 449 450 451 452 453 454 455 456 457 458

    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) {
459
        prim %memmove(dst_p, src_p, bytes, SIZEOF_W);
460
    } else {
461
        prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487
    }

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


488 489 490 491
/* -----------------------------------------------------------------------------
   MutVar primitives
   -------------------------------------------------------------------------- */

492
stg_newMutVarzh ( gcptr init )
493 494 495
{
    W_ mv;

496
    ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init);
497 498

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

502
    return (mv);
503 504
}

505 506 507 508 509
// 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.
510
stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
511
 /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, Any a #) */
Simon Marlow's avatar
Simon Marlow committed
512
{
513
    gcptr h;
Simon Marlow's avatar
Simon Marlow committed
514

tibbe's avatar
tibbe committed
515
    (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, old, new);
Simon Marlow's avatar
Simon Marlow committed
516
    if (h != old) {
517
        return (1,h);
Simon Marlow's avatar
Simon Marlow committed
518
    } else {
519
        if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
tibbe's avatar
tibbe committed
520
            ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
521
        }
522
        return (0,new);
Simon Marlow's avatar
Simon Marlow committed
523 524 525
    }
}

526
stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
527
{
528
    W_ z, x, y, r, h;
529

ian@well-typed.com's avatar
ian@well-typed.com committed
530
    /* If x is the current contents of the MutVar#, then
531 532 533
       We want to make the new contents point to

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

535
       and the return value is
ian@well-typed.com's avatar
ian@well-typed.com committed
536 537

         (sel_1 (f x))
538 539 540 541

        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
542
         y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
543 544 545 546
         r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
    */

#if MIN_UPD_SIZE > 1
547
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
548 549
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
#else
550
#define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
551 552 553 554
#define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
#endif

#if MIN_UPD_SIZE > 2
555
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
556 557
#define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
#else
558
#define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(2))
559 560 561 562 563
#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
564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589
    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;
590
#ifdef THREADED_RTS
tibbe's avatar
tibbe committed
591 592
    (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y);
    if (h != x) { goto retry; }
593
#else
tibbe's avatar
tibbe committed
594
    StgMutVar_var(mv) = y;
595
#endif
596

tibbe's avatar
tibbe committed
597 598 599
    if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
        ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
    }
600

tibbe's avatar
tibbe committed
601
    return (r);
602 603 604 605 606 607 608 609
}

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

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

610 611 612
stg_mkWeakzh ( gcptr key,
               gcptr value,
               gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
613
{
tibbe's avatar
tibbe committed
614
    gcptr w;
615

tibbe's avatar
tibbe committed
616
    ALLOC_PRIM (SIZEOF_StgWeak)
617

tibbe's avatar
tibbe committed
618 619
    w = Hp - SIZEOF_StgWeak + WDS(1);
    SET_HDR(w, stg_WEAK_info, CCCS);
620

tibbe's avatar
tibbe committed
621 622 623 624
    StgWeak_key(w)         = key;
    StgWeak_value(w)       = value;
    StgWeak_finalizer(w)   = finalizer;
    StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
625

626 627 628 629 630
    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;
    }
631

tibbe's avatar
tibbe committed
632
    IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
633

tibbe's avatar
tibbe committed
634
    return (w);
635 636
}

637
stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
638
{
tibbe's avatar
tibbe committed
639
    jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
640 641
}

642 643 644 645 646 647 648
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 )
649
{
tibbe's avatar
tibbe committed
650
    W_ c, info;
651

tibbe's avatar
tibbe committed
652
    ALLOC_PRIM (SIZEOF_StgCFinalizerList)
653

tibbe's avatar
tibbe committed
654 655
    c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
    SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
656

tibbe's avatar
tibbe committed
657 658 659 660
    StgCFinalizerList_fptr(c) = fptr;
    StgCFinalizerList_ptr(c) = ptr;
    StgCFinalizerList_eptr(c) = eptr;
    StgCFinalizerList_flag(c) = flag;
661

tibbe's avatar
tibbe committed
662
    LOCK_CLOSURE(w, info);
663

tibbe's avatar
tibbe committed
664 665 666 667 668
    if (info == stg_DEAD_WEAK_info) {
        // Already dead.
        unlockClosure(w, info);
        return (0);
    }
669

tibbe's avatar
tibbe committed
670 671
    StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
    StgWeak_cfinalizers(w) = c;
672

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

tibbe's avatar
tibbe committed
675
    recordMutable(w);
676

tibbe's avatar
tibbe committed
677
    IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
678

tibbe's avatar
tibbe committed
679
    return (1);
680
}
681

682
stg_finalizzeWeakzh ( gcptr w )
683
{
tibbe's avatar
tibbe committed
684 685
    gcptr f, list;
    W_ info;
686

tibbe's avatar
tibbe committed
687
    LOCK_CLOSURE(w, info);
688

tibbe's avatar
tibbe committed
689 690 691 692 693
    // already dead?
    if (info == stg_DEAD_WEAK_info) {
        unlockClosure(w, info);
        return (0,stg_NO_FINALIZER_closure);
    }
694

tibbe's avatar
tibbe committed
695 696
    f    = StgWeak_finalizer(w);
    list = StgWeak_cfinalizers(w);
697

tibbe's avatar
tibbe committed
698
    // kill it
699
#ifdef PROFILING
tibbe's avatar
tibbe committed
700 701 702 703 704 705 706 707 708
    // @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.
709 710
#endif

tibbe's avatar
tibbe committed
711 712 713 714
    //
    // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
    //
    unlockClosure(w, stg_DEAD_WEAK_info);
715

tibbe's avatar
tibbe committed
716
    LDV_RECORD_CREATE(w);
717

tibbe's avatar
tibbe committed
718 719 720
    if (list != stg_NO_FINALIZER_closure) {
      ccall runCFinalizers(list);
    }
721

tibbe's avatar
tibbe committed
722 723 724 725 726 727
    /* return the finalizer */
    if (f == stg_NO_FINALIZER_closure) {
        return (0,stg_NO_FINALIZER_closure);
    } else {
        return (1,f);
    }
728 729
}

730
stg_deRefWeakzh ( gcptr w )
731
{
tibbe's avatar
tibbe committed
732 733
    W_ code, info;
    gcptr val;
734

tibbe's avatar
tibbe committed
735
    info = GET_INFO(w);
736

tibbe's avatar
tibbe committed
737 738 739 740
    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.
741

tibbe's avatar
tibbe committed
742 743 744
        LOCK_CLOSURE(w, info);
        unlockClosure(w, info);
    }
745

tibbe's avatar
tibbe committed
746 747 748 749 750 751 752 753
    if (info == stg_WEAK_info) {
        code = 1;
        val = StgWeak_value(w);
    } else {
        code = 0;
        val = w;
    }
    return (code,val);
754 755 756
}

/* -----------------------------------------------------------------------------
757
   Floating point operations.
758 759
   -------------------------------------------------------------------------- */

760
stg_decodeFloatzuIntzh ( F_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
761
{
762
    W_ p;
763
    W_ tmp, mp_tmp1, mp_tmp_w, r1, r2;
764

765
    STK_CHK_GEN_N (WDS(2));
766

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

tibbe's avatar
tibbe committed
769 770
        mp_tmp1  = tmp + WDS(1);
        mp_tmp_w = tmp;
771

tibbe's avatar
tibbe committed
772 773
        /* Perform the operation */
        ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
774

tibbe's avatar
tibbe committed
775 776
        r1 = W_[mp_tmp1];
        r2 = W_[mp_tmp_w];
777
    }
ian@well-typed.com's avatar
ian@well-typed.com committed
778

779
    /* returns: (Int# (mantissa), Int# (exponent)) */
780
    return (r1, r2);
781 782
}

783
stg_decodeDoublezu2Intzh ( D_ arg )
ian@well-typed.com's avatar
ian@well-typed.com committed
784
{
785 786 787
    W_ p, tmp;
    W_ mp_tmp1, mp_tmp2, mp_result1, mp_result2;
    W_ r1, r2, r3, r4;
788

789
    STK_CHK_GEN_N (WDS(4));
790

791 792
    reserve 4 = tmp {

tibbe's avatar
tibbe committed
793 794 795 796
        mp_tmp1    = tmp + WDS(3);
        mp_tmp2    = tmp + WDS(2);
        mp_result1 = tmp + WDS(1);
        mp_result2 = tmp;
797

tibbe's avatar
tibbe committed
798 799 800 801 802 803 804 805 806
        /* 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];
807
    }
808 809 810

    /* returns:
       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
811
    return (r1, r2, r3, r4);
812 813
}

814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829
/* 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));
}

830 831 832 833
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

834
stg_forkzh ( gcptr closure )
835
{
tibbe's avatar
tibbe committed
836
    MAYBE_GC_P(stg_forkzh, closure);
837

tibbe's avatar
tibbe committed
838
    gcptr threadid;
839

tibbe's avatar
tibbe committed
840 841 842
    ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
                                  RtsFlags_GcFlags_initialStkSize(RtsFlags),
                                  closure "ptr");
843

tibbe's avatar
tibbe committed
844 845 846 847
    /* 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));
848

tibbe's avatar
tibbe committed
849
    ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
850

tibbe's avatar
tibbe committed
851 852 853
    // 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
854

tibbe's avatar
tibbe committed
855
    return (threadid);
856 857
}

858
stg_forkOnzh ( W_ cpu, gcptr closure )
859
{
860
again: MAYBE_GC(again);
861

tibbe's avatar
tibbe committed
862
    gcptr threadid;
863

tibbe's avatar
tibbe committed
864 865 866 867
    ("ptr" threadid) = ccall createIOThread(
        MyCapability() "ptr",
        RtsFlags_GcFlags_initialStkSize(RtsFlags),
        closure "ptr");
868

tibbe's avatar
tibbe committed
869 870 871 872
    /* 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));
873

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

tibbe's avatar
tibbe committed
876 877 878
    // 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
879

tibbe's avatar
tibbe committed
880
    return (threadid);
881 882
}

883
stg_yieldzh ()
884
{
tibbe's avatar
tibbe committed
885 886 887 888 889 890
    // 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();
891 892
}

893
stg_myThreadIdzh ()
894
{
tibbe's avatar
tibbe committed
895
    return (CurrentTSO);
896 897
}

898
stg_labelThreadzh ( gcptr threadid, W_ addr )
899
{
900
#if defined(DEBUG) || defined(TRACING) || defined(DTRACE)
tibbe's avatar
tibbe committed
901
    ccall labelThread(MyCapability() "ptr", threadid "ptr", addr "ptr");
902
#endif
tibbe's avatar
tibbe committed
903
    return ();
904 905
}

906
stg_isCurrentThreadBoundzh (/* no args */)
907
{
tibbe's avatar
tibbe committed
908 909 910
    W_ r;
    (r) = ccall isThreadBound(CurrentTSO);
    return (r);
911 912
}

913
stg_threadStatuszh ( gcptr tso )
914 915 916
{
    W_ why_blocked;
    W_ what_next;
917
    W_ ret, cap, locked;
918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934

    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;
        }
    }
935 936 937 938 939 940 941 942 943

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

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

944
    return (ret,cap,locked);
945
}
946 947 948 949 950

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

951 952 953
// Catch retry frame -----------------------------------------------------------

#define CATCH_RETRY_FRAME_FIELDS(w_,p_,info_ptr,        \
Simon Marlow's avatar
Simon Marlow committed
954
                                 p1, p2,                \
955 956 957 958
                                 running_alt_code,      \
                                 first_code,            \
                                 alt_code)              \
  w_ info_ptr,                                          \
Simon Marlow's avatar
Simon Marlow committed
959
  PROF_HDR_FIELDS(w_,p1,p2)                             \
960 961 962
  w_ running_alt_code,                                  \
  p_ first_code,                                        \
  p_ alt_code
963 964


965
INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
966
               CATCH_RETRY_FRAME_FIELDS(W_,P_,
Simon Marlow's avatar
Simon Marlow committed
967
                                        info_ptr, p1, p2,
968 969 970 971
                                        running_alt_code,
                                        first_code,
                                        alt_code))
    return (P_ ret)
972
{
973 974
    W_ r;
    gcptr trec, outer, arg;
975

976 977 978 979 980 981 982 983 984 985 986 987 988 989 990
    trec = StgTSO_trec(CurrentTSO);
    outer  = StgTRecHeader_enclosing_trec(trec);
    (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
    if (r != 0) {
        // Succeeded (either first branch or second branch)
        StgTSO_trec(CurrentTSO) = outer;
        return (ret);
    } else {
        // Did not commit: re-execute
        P_ new_trec;
        ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr",
                                                           outer "ptr");
        StgTSO_trec(CurrentTSO) = new_trec;
        if (running_alt_code != 0) {
            jump stg_ap_v_fast