PrimOps.cmm 72.7 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 41 42 43 44 45 46 47 48 49 50 51
/*-----------------------------------------------------------------------------
  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.
 */

52
stg_newByteArrayzh ( W_ n )
53
{
54 55 56 57 58
    W_ words, payload_words;
    gcptr p;

    MAYBE_GC_N(stg_newByteArrayzh, n);

59 60
    payload_words = ROUNDUP_BYTES_TO_WDS(n);
    words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
61
    ("ptr" p) = ccall allocate(MyCapability() "ptr",words);
62
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
63
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
64
    StgArrWords_bytes(p) = n;
65
    return (p);
66 67
}

Simon Marlow's avatar
Simon Marlow committed
68 69 70
#define BA_ALIGN 16
#define BA_MASK  (BA_ALIGN-1)

71
stg_newPinnedByteArrayzh ( W_ n )
72
{
73 74 75 76
    W_ words, bytes, payload_words;
    gcptr p;

    MAYBE_GC_N(stg_newPinnedByteArrayzh, n);
77

78
    bytes = n;
79 80 81 82 83 84 85 86 87 88
    /* 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: */
    bytes = bytes + SIZEOF_StgArrWords;
    /* 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
89

90
    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
Simon Marlow's avatar
Simon Marlow committed
91 92
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);

93 94
    /* Now we need to move p forward so that the payload is aligned
       to BA_ALIGN bytes: */
Simon Marlow's avatar
Simon Marlow committed
95 96
    p = p + ((-p - SIZEOF_StgArrWords) & BA_MASK);

97
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
98
    StgArrWords_bytes(p) = n;
99
    return (p);
Simon Marlow's avatar
Simon Marlow committed
100 101
}

102
stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment )
Simon Marlow's avatar
Simon Marlow committed
103
{
104 105
    W_ words, bytes, payload_words;
    gcptr p;
Simon Marlow's avatar
Simon Marlow committed
106

107
    again: MAYBE_GC(again);
Simon Marlow's avatar
Simon Marlow committed
108

109 110 111 112 113
    /* 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; }

114 115
    bytes = n;

116 117
    /* 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
118

119 120 121 122 123 124 125 126
    /* When we actually allocate memory, we need to allow space for the
       header: */
    bytes = bytes + SIZEOF_StgArrWords;
    /* 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);
127

128
    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
129 130
    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);

131 132 133 134
    /* 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 */
    p = p + ((-p - SIZEOF_StgArrWords) & (alignment - 1));
135

136
    SET_HDR(p, stg_ARR_WORDS_info, CCCS);
137
    StgArrWords_bytes(p) = n;
138
    return (p);
139 140
}

141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
// shrink size of MutableByteArray in-place
stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size )
// MutableByteArray# s -> Int# -> State# s -> State# s
{
   ASSERT(new_size >= 0);
   ASSERT(new_size <= StgArrWords_bytes(mba));

   OVERWRITING_CLOSURE_OFS(mba, (BYTES_TO_WDS(SIZEOF_StgArrWords) +
                                 ROUNDUP_BYTES_TO_WDS(new_size)));
   StgArrWords_bytes(mba) = new_size;
   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
162
stg_resizzeMutableByteArrayzh ( gcptr mba, W_ new_size )
163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188
// 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)) {
      OVERWRITING_CLOSURE_OFS(mba, (BYTES_TO_WDS(SIZEOF_StgArrWords) +
                                    new_size_wds));
      StgArrWords_bytes(mba) = new_size;
      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),
189
                   StgArrWords_bytes(mba), SIZEOF_W);
190 191 192 193 194

      return (new_mba);
   }
}

195 196 197 198 199
// 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
200
    W_ p, h;
201 202 203 204 205 206 207

    p = arr + SIZEOF_StgArrWords + WDS(ind);
    (h) = ccall cas(p, old, new);

    return(h);
}

208

209
stg_newArrayzh ( W_ n /* words */, gcptr init )
210
{
tibbe's avatar
tibbe committed
211 212
    W_ words, size, p;
    gcptr arr;
213

214
    again: MAYBE_GC(again);
215

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

224
    SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
225
    StgMutArrPtrs_ptrs(arr) = n;
226
    StgMutArrPtrs_size(arr) = size;
227 228 229 230

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

237
    return (arr);
238 239
}

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

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

291 292
stg_cloneArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
293
    cloneArray(stg_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
294 295 296 297
}

stg_cloneMutableArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
298
    cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
299 300 301 302 303
}

// We have to escape the "z" in the name.
stg_freezzeArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
304
    cloneArray(stg_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
305 306 307 308
}

stg_thawArrayzh ( gcptr src, W_ offset, W_ n )
{
tibbe's avatar
tibbe committed
309
    cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
310 311
}

312
// RRN: Uses the ticketed approach; see casMutVar
313
stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
314
/* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, Any a #) */
315
{
tibbe's avatar
tibbe committed
316 317
    gcptr h;
    W_ p, len;
318 319

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

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

335
stg_newArrayArrayzh ( W_ n /* words */ )
336
{
tibbe's avatar
tibbe committed
337 338
    W_ words, size, p;
    gcptr arr;
339

340
    MAYBE_GC_N(stg_newArrayArrayzh, n);
341 342 343 344 345 346

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

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

363
    return (arr);
364 365
}

pumpkin's avatar
pumpkin committed
366

367 368 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
/* -----------------------------------------------------------------------------
   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);
441
    prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
442 443 444 445 446 447 448 449 450 451 452 453 454 455

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

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


485 486 487 488
/* -----------------------------------------------------------------------------
   MutVar primitives
   -------------------------------------------------------------------------- */

489
stg_newMutVarzh ( gcptr init )
490 491 492
{
    W_ mv;

493
    ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init);
494 495

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

499
    return (mv);
500 501
}

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

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

523
stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
524
{
525
    W_ z, x, y, r, h;
526

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

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

532
       and the return value is
ian@well-typed.com's avatar
ian@well-typed.com committed
533 534

         (sel_1 (f x))
535 536 537 538

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

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

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

tibbe's avatar
tibbe committed
594 595 596
    if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
        ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
    }
597

tibbe's avatar
tibbe committed
598
    return (r);
599 600 601 602 603 604 605 606
}

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

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

607 608 609
stg_mkWeakzh ( gcptr key,
               gcptr value,
               gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
610
{
tibbe's avatar
tibbe committed
611
    gcptr w;
612

tibbe's avatar
tibbe committed
613
    ALLOC_PRIM (SIZEOF_StgWeak)
614

tibbe's avatar
tibbe committed
615 616
    w = Hp - SIZEOF_StgWeak + WDS(1);
    SET_HDR(w, stg_WEAK_info, CCCS);
617

tibbe's avatar
tibbe committed
618 619 620 621
    StgWeak_key(w)         = key;
    StgWeak_value(w)       = value;
    StgWeak_finalizer(w)   = finalizer;
    StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
622

623 624 625 626 627
    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;
    }
628

tibbe's avatar
tibbe committed
629
    IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
630

tibbe's avatar
tibbe committed
631
    return (w);
632 633
}

634
stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
635
{
tibbe's avatar
tibbe committed
636
    jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
637 638
}

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

tibbe's avatar
tibbe committed
649
    ALLOC_PRIM (SIZEOF_StgCFinalizerList)
650

tibbe's avatar
tibbe committed
651 652
    c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
    SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
653

tibbe's avatar
tibbe committed
654 655 656 657
    StgCFinalizerList_fptr(c) = fptr;
    StgCFinalizerList_ptr(c) = ptr;
    StgCFinalizerList_eptr(c) = eptr;
    StgCFinalizerList_flag(c) = flag;
658

tibbe's avatar
tibbe committed
659
    LOCK_CLOSURE(w, info);
660

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

tibbe's avatar
tibbe committed
667 668
    StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
    StgWeak_cfinalizers(w) = c;
669

tibbe's avatar
tibbe committed
670
    unlockClosure(w, info);
671

tibbe's avatar
tibbe committed
672
    recordMutable(w);
673

tibbe's avatar
tibbe committed
674
    IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
675

tibbe's avatar
tibbe committed
676
    return (1);
677
}
678

679
stg_finalizzeWeakzh ( gcptr w )
680
{
tibbe's avatar
tibbe committed
681 682
    gcptr f, list;
    W_ info;
683

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

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

tibbe's avatar
tibbe committed
692 693
    f    = StgWeak_finalizer(w);
    list = StgWeak_cfinalizers(w);
694

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

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

tibbe's avatar
tibbe committed
713
    LDV_RECORD_CREATE(w);
714

tibbe's avatar
tibbe committed
715 716 717
    if (list != stg_NO_FINALIZER_closure) {
      ccall runCFinalizers(list);
    }
718

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

727
stg_deRefWeakzh ( gcptr w )
728
{
tibbe's avatar
tibbe committed
729 730
    W_ code, info;
    gcptr val;
731

tibbe's avatar
tibbe committed
732
    info = GET_INFO(w);
733

tibbe's avatar
tibbe committed
734 735 736 737
    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.
738

tibbe's avatar
tibbe committed
739 740 741
        LOCK_CLOSURE(w, info);
        unlockClosure(w, info);
    }
742

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

/* -----------------------------------------------------------------------------
754
   Floating point operations.
755 756
   -------------------------------------------------------------------------- */

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

762
    STK_CHK_GEN_N (WDS(2));
763

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

tibbe's avatar
tibbe committed
766 767
        mp_tmp1  = tmp + WDS(1);
        mp_tmp_w = tmp;
768

tibbe's avatar
tibbe committed
769 770
        /* Perform the operation */
        ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
771

tibbe's avatar
tibbe committed
772 773
        r1 = W_[mp_tmp1];
        r2 = W_[mp_tmp_w];
774
    }
ian@well-typed.com's avatar
ian@well-typed.com committed
775

776
    /* returns: (Int# (mantissa), Int# (exponent)) */
777
    return (r1, r2);
778 779
}

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

786
    STK_CHK_GEN_N (WDS(4));
787

788 789
    reserve 4 = tmp {

tibbe's avatar
tibbe committed
790 791 792 793
        mp_tmp1    = tmp + WDS(3);
        mp_tmp2    = tmp + WDS(2);
        mp_result1 = tmp + WDS(1);
        mp_result2 = tmp;
794

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

    /* returns:
       (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
808
    return (r1, r2, r3, r4);
809 810
}

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

827 828 829 830
/* -----------------------------------------------------------------------------
 * Concurrency primitives
 * -------------------------------------------------------------------------- */

831
stg_forkzh ( gcptr closure )
832
{
tibbe's avatar
tibbe committed
833
    MAYBE_GC_P(stg_forkzh, closure);
834

tibbe's avatar
tibbe committed
835
    gcptr threadid;
836

tibbe's avatar
tibbe committed
837 838 839
    ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
                                  RtsFlags_GcFlags_initialStkSize(RtsFlags),
                                  closure "ptr");
840

tibbe's avatar
tibbe committed
841 842 843 844
    /* 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));
845

tibbe's avatar
tibbe committed
846
    ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
847

tibbe's avatar
tibbe committed
848 849 850
    // 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
851

tibbe's avatar
tibbe committed
852
    return (threadid);
853 854
}

855
stg_forkOnzh ( W_ cpu, gcptr closure )
856
{
857
again: MAYBE_GC(again);
858

tibbe's avatar
tibbe committed
859
    gcptr threadid;
860

tibbe's avatar
tibbe committed
861 862 863 864
    ("ptr" threadid) = ccall createIOThread(
        MyCapability() "ptr",
        RtsFlags_GcFlags_initialStkSize(RtsFlags),
        closure "ptr");
865

tibbe's avatar
tibbe committed
866 867 868 869
    /* 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));
870

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

tibbe's avatar
tibbe committed
873 874 875
    // 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
876

tibbe's avatar
tibbe committed
877
    return (threadid);
878 879
}

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

890
stg_myThreadIdzh ()
891
{
tibbe's avatar
tibbe committed
892
    return (CurrentTSO);
893 894
}

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

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

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

    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;
        }
    }
932 933 934 935 936 937 938 939 940

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

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

941
    return (ret,cap,locked);
942
}
943 944 945 946 947

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

948 949 950
// Catch retry frame -----------------------------------------------------------

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


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

973 974 975 976 977 978 979 980 981 982 983 984 985 986 987
    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
Simon Marlow's avatar
Simon Marlow committed
988
                (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
989 990 991 992 993 994
                                          running_alt_code,
                                          first_code,
                                          alt_code))
                (alt_code);
        } else {
            jump stg_ap_v_fast
Simon Marlow's avatar
Simon Marlow committed
995
                (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
996 997 998 999 1000 1001 1002
                                          running_alt_code,
                                          first_code,
                                          alt_code))
                (first_code);
        }
    }
}
1003

Simon Marlow's avatar
Simon Marlow committed
1004
// Atomically frame ------------------------------------------------------------
1005

1006
// This must match StgAtomicallyFrame in Closures.h
Simon Marlow's avatar
Simon Marlow committed
1007
#define ATOMICALLY_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,code,next,result)  \
tibbe's avatar
tibbe committed
1008 1009 1010 1011 1012
    w_ info_ptr,                                                        \
    PROF_HDR_FIELDS(w_,p1,p2)                                           \
    p_ code,                                                            \
    p_ next,                                                            \
    p_ result
1013 1014


1015
INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
1016 1017
               // layout of the frame, and bind the field names
               ATOMICALLY_FRAME_FIELDS(W_,P_,
Simon Marlow's avatar
Simon Marlow committed
1018
                                       info_ptr, p1, p2,