Add hs_try_putmvar()
[ghc.git] / rts / PrimOps.cmm
index 0e547be..02a7daf 100644 (file)
  * ---------------------------------------------------------------------------*/
 
 #include "Cmm.h"
+#include "MachDeps.h"
+#include "SMPClosureOps.h"
 
 #ifdef __PIC__
 import pthread_mutex_lock;
 import pthread_mutex_unlock;
 #endif
-import base_ControlziExceptionziBase_nestedAtomically_closure;
+import CLOSURE base_ControlziExceptionziBase_nestedAtomically_closure;
 import EnterCriticalSection;
 import LeaveCriticalSection;
-import ghczmprim_GHCziTypes_False_closure;
+import CLOSURE ghczmprim_GHCziTypes_False_closure;
 #if defined(USE_MINIINTERPRETER) || !defined(mingw32_HOST_OS)
-import sm_mutex;
+import CLOSURE sm_mutex;
+#endif
+#ifdef PROFILING
+import CLOSURE CCS_MAIN;
 #endif
 
 /*-----------------------------------------------------------------------------
@@ -56,11 +61,11 @@ stg_newByteArrayzh ( W_ n )
     MAYBE_GC_N(stg_newByteArrayzh, n);
 
     payload_words = ROUNDUP_BYTES_TO_WDS(n);
-    words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
+    words = BYTES_TO_WDS(SIZEOF_StgArrBytes) + payload_words;
     ("ptr" p) = ccall allocate(MyCapability() "ptr",words);
-    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
+    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
     SET_HDR(p, stg_ARR_WORDS_info, CCCS);
-    StgArrWords_bytes(p) = n;
+    StgArrBytes_bytes(p) = n;
     return (p);
 }
 
@@ -79,7 +84,7 @@ stg_newPinnedByteArrayzh ( W_ n )
     payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
     /* When we actually allocate memory, we need to allow space for the
        header: */
-    bytes = bytes + SIZEOF_StgArrWords;
+    bytes = bytes + SIZEOF_StgArrBytes;
     /* 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;
@@ -87,14 +92,14 @@ stg_newPinnedByteArrayzh ( W_ n )
     words = ROUNDUP_BYTES_TO_WDS(bytes);
 
     ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
-    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
+    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
 
     /* Now we need to move p forward so that the payload is aligned
        to BA_ALIGN bytes: */
-    p = p + ((-p - SIZEOF_StgArrWords) & BA_MASK);
+    p = p + ((-p - SIZEOF_StgArrBytes) & BA_MASK);
 
     SET_HDR(p, stg_ARR_WORDS_info, CCCS);
-    StgArrWords_bytes(p) = n;
+    StgArrBytes_bytes(p) = n;
     return (p);
 }
 
@@ -117,7 +122,7 @@ stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment )
 
     /* When we actually allocate memory, we need to allow space for the
        header: */
-    bytes = bytes + SIZEOF_StgArrWords;
+    bytes = bytes + SIZEOF_StgArrBytes;
     /* 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;
@@ -125,41 +130,98 @@ stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment )
     words = ROUNDUP_BYTES_TO_WDS(bytes);
 
     ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
-    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
+    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
 
     /* 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));
+    p = p + ((-p - SIZEOF_StgArrBytes) & (alignment - 1));
 
     SET_HDR(p, stg_ARR_WORDS_info, CCCS);
-    StgArrWords_bytes(p) = n;
+    StgArrBytes_bytes(p) = n;
     return (p);
 }
 
-// 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# #) */
+stg_isByteArrayPinnedzh ( gcptr ba )
+// ByteArray# s -> Int#
 {
-    gcptr p;
-    W_ h;
+    W_ bd, flags;
+    bd = Bdescr(ba);
+    // pinned byte arrays live in blocks with the BF_PINNED flag set.
+    // See the comment in Storage.c:allocatePinned.
+    flags = TO_W_(bdescr_flags(bd));
+    return (flags & BF_PINNED != 0);
+}
 
-    p = arr + SIZEOF_StgArrWords + WDS(ind);
-    (h) = ccall cas(p, old, new);
+stg_isMutableByteArrayPinnedzh ( gcptr mba )
+// MutableByteArray# s -> Int#
+{
+    jump stg_isByteArrayPinnedzh(mba);
+}
 
-    return(h);
+// 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 <= StgArrBytes_bytes(mba));
+
+   OVERWRITING_CLOSURE_OFS(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) +
+                                 ROUNDUP_BYTES_TO_WDS(new_size)));
+   StgArrBytes_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)
+stg_resizzeMutableByteArrayzh ( gcptr mba, W_ new_size )
+// 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);
 
-stg_fetchAddIntArrayzh( gcptr arr, W_ ind, W_ incr )
-/* MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) */
+   if (new_size_wds <= BYTE_ARR_WDS(mba)) {
+      OVERWRITING_CLOSURE_OFS(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) +
+                                    new_size_wds));
+      StgArrBytes_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),
+                   StgArrBytes_bytes(mba), SIZEOF_W);
+
+      return (new_mba);
+   }
+}
+
+// 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# #) */
 {
-    gcptr p;
-    W_ h;
+    W_ p, h;
 
-    p = arr + SIZEOF_StgArrWords + WDS(ind);
-    (h) = ccall atomic_inc(p, incr);
+    p = arr + SIZEOF_StgArrBytes + WDS(ind);
+    (h) = prim %cmpxchgW(p, old, new);
 
     return(h);
 }
@@ -167,8 +229,8 @@ stg_fetchAddIntArrayzh( gcptr arr, W_ ind, W_ incr )
 
 stg_newArrayzh ( W_ n /* words */, gcptr init )
 {
-    W_ words, size;
-    gcptr p, arr;
+    W_ words, size, p;
+    gcptr arr;
 
     again: MAYBE_GC(again);
 
@@ -198,45 +260,86 @@ stg_newArrayzh ( W_ n /* words */, gcptr init )
 
 stg_unsafeThawArrayzh ( gcptr arr )
 {
-  // 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) {
+    // 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) {
         SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
         recordMutable(arr);
         // must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
         return (arr);
-  } else {
+    } else {
         SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info);
         return (arr);
-  }
+    }
+}
+
+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)
+}
+
+stg_cloneArrayzh ( gcptr src, W_ offset, W_ n )
+{
+    cloneArray(stg_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
+}
+
+stg_cloneMutableArrayzh ( gcptr src, W_ offset, W_ n )
+{
+    cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
+}
+
+// We have to escape the "z" in the name.
+stg_freezzeArrayzh ( gcptr src, W_ offset, W_ n )
+{
+    cloneArray(stg_MUT_ARR_PTRS_FROZEN_info, src, offset, n)
+}
+
+stg_thawArrayzh ( gcptr src, W_ offset, W_ n )
+{
+    cloneArray(stg_MUT_ARR_PTRS_DIRTY_info, src, offset, n)
 }
 
 // RRN: Uses the ticketed approach; see casMutVar
 stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
 /* MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, Any a #) */
 {
-    gcptr p, h;
-    W_ len;
+    gcptr h;
+    W_ p, len;
 
     p = arr + SIZEOF_StgMutArrPtrs + WDS(ind);
-    (h) = ccall cas(p, old, new);
-    
+    (h) = prim %cmpxchgW(p, old, new);
+
     if (h != old) {
         // Failure, return what was there instead of 'old':
         return (1,h);
@@ -252,8 +355,8 @@ stg_casArrayzh ( gcptr arr, W_ ind, gcptr old, gcptr new )
 
 stg_newArrayArrayzh ( W_ n /* words */ )
 {
-    W_ words, size;
-    gcptr p, arr;
+    W_ words, size, p;
+    gcptr arr;
 
     MAYBE_GC_N(stg_newArrayArrayzh, n);
 
@@ -283,6 +386,124 @@ stg_newArrayArrayzh ( W_ n /* words */ )
 
 
 /* -----------------------------------------------------------------------------
+   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);
+    prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
+
+    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) {
+        prim %memmove(dst_p, src_p, bytes, SIZEOF_W);
+    } else {
+        prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);
+    }
+
+    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) = prim %cmpxchgW(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);
+    }
+}
+
+
+/* -----------------------------------------------------------------------------
    MutVar primitives
    -------------------------------------------------------------------------- */
 
@@ -309,13 +530,12 @@ stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
 {
     gcptr h;
 
-    (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var,
-                          old, new);
+    (h) = prim %cmpxchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, old, new);
     if (h != old) {
         return (1,h);
     } else {
         if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
-           ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
+            ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
         }
         return (0,new);
     }
@@ -359,44 +579,44 @@ stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
 
 #define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)
 
-   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;
+    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;
 #ifdef THREADED_RTS
-   (h) = ccall cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y);
-   if (h != x) { goto retry; }
+    (h) = prim %cmpxchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y);
+    if (h != x) { goto retry; }
 #else
-   StgMutVar_var(mv) = y;
+    StgMutVar_var(mv) = y;
 #endif
 
-   if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
-     ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
-   }
+    if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
+        ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
+    }
 
-   return (r);
+    return (r);
 }
 
 /* -----------------------------------------------------------------------------
@@ -409,31 +629,32 @@ stg_mkWeakzh ( gcptr key,
                gcptr value,
                gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
 {
-  gcptr w;
+    gcptr w;
 
-  ALLOC_PRIM (SIZEOF_StgWeak)
+    ALLOC_PRIM (SIZEOF_StgWeak)
 
-  w = Hp - SIZEOF_StgWeak + WDS(1);
-  SET_HDR(w, stg_WEAK_info, CCCS);
+    w = Hp - SIZEOF_StgWeak + WDS(1);
+    SET_HDR(w, stg_WEAK_info, CCCS);
 
-  StgWeak_key(w)         = key;
-  StgWeak_value(w)       = value;
-  StgWeak_finalizer(w)   = finalizer;
-  StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
+    StgWeak_key(w)         = key;
+    StgWeak_value(w)       = value;
+    StgWeak_finalizer(w)   = finalizer;
+    StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure;
 
-  ACQUIRE_LOCK(sm_mutex);
-  StgWeak_link(w) = generation_weak_ptr_list(W_[g0]);
-  generation_weak_ptr_list(W_[g0]) = w;
-  RELEASE_LOCK(sm_mutex);
+    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;
+    }
 
-  IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
+    IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
 
-  return (w);
+    return (w);
 }
 
 stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
 {
-  jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
+    jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
 }
 
 STRING(stg_cfinalizer_msg,"Adding a finalizer to %p\n")
@@ -444,110 +665,110 @@ stg_addCFinalizzerToWeakzh ( W_ fptr,   // finalizer
                              W_ eptr,
                              gcptr w )
 {
-  W_ c, info;
+    W_ c, info;
 
-  ALLOC_PRIM (SIZEOF_StgCFinalizerList)
+    ALLOC_PRIM (SIZEOF_StgCFinalizerList)
 
-  c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
-  SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
+    c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
+    SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
 
-  StgCFinalizerList_fptr(c) = fptr;
-  StgCFinalizerList_ptr(c) = ptr;
-  StgCFinalizerList_eptr(c) = eptr;
-  StgCFinalizerList_flag(c) = flag;
+    StgCFinalizerList_fptr(c) = fptr;
+    StgCFinalizerList_ptr(c) = ptr;
+    StgCFinalizerList_eptr(c) = eptr;
+    StgCFinalizerList_flag(c) = flag;
 
-  LOCK_CLOSURE(w, info);
+    LOCK_CLOSURE(w, info);
 
-  if (info == stg_DEAD_WEAK_info) {
-    // Already dead.
-    unlockClosure(w, info);
-    return (0);
-  }
+    if (info == stg_DEAD_WEAK_info) {
+        // Already dead.
+        unlockClosure(w, info);
+        return (0);
+    }
 
-  StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
-  StgWeak_cfinalizers(w) = c;
+    StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
+    StgWeak_cfinalizers(w) = c;
 
-  unlockClosure(w, info);
+    unlockClosure(w, info);
 
-  recordMutable(w);
+    recordMutable(w);
 
-  IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
+    IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
 
-  return (1);
+    return (1);
 }
 
 stg_finalizzeWeakzh ( gcptr w )
 {
-  gcptr f, list;
-  W_ info;
+    gcptr f, list;
+    W_ info;
 
-  LOCK_CLOSURE(w, info);
+    LOCK_CLOSURE(w, info);
 
-  // already dead?
-  if (info == stg_DEAD_WEAK_info) {
-      unlockClosure(w, info);
-      return (0,stg_NO_FINALIZER_closure);
-  }
+    // already dead?
+    if (info == stg_DEAD_WEAK_info) {
+        unlockClosure(w, info);
+        return (0,stg_NO_FINALIZER_closure);
+    }
 
-  f    = StgWeak_finalizer(w);
-  list = StgWeak_cfinalizers(w);
+    f    = StgWeak_finalizer(w);
+    list = StgWeak_cfinalizers(w);
 
-  // kill it
+    // kill it
 #ifdef PROFILING
-  // @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.
+    // @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.
 #endif
 
-  //
-  // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
-  //
-  unlockClosure(w, stg_DEAD_WEAK_info);
+    //
+    // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
+    //
+    unlockClosure(w, stg_DEAD_WEAK_info);
 
-  LDV_RECORD_CREATE(w);
+    LDV_RECORD_CREATE(w);
 
-  if (list != stg_NO_FINALIZER_closure) {
-    ccall runCFinalizers(list);
-  }
+    if (list != stg_NO_FINALIZER_closure) {
+      ccall runCFinalizers(list);
+    }
 
-  /* return the finalizer */
-  if (f == stg_NO_FINALIZER_closure) {
-      return (0,stg_NO_FINALIZER_closure);
-  } else {
-      return (1,f);
-  }
+    /* return the finalizer */
+    if (f == stg_NO_FINALIZER_closure) {
+        return (0,stg_NO_FINALIZER_closure);
+    } else {
+        return (1,f);
+    }
 }
 
 stg_deRefWeakzh ( gcptr w )
 {
-  W_ code, info;
-  gcptr val;
+    W_ code, info;
+    gcptr val;
 
-  info = GET_INFO(w);
+    info = GET_INFO(w);
 
-  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.
+    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.
 
-    LOCK_CLOSURE(w, info);
-    unlockClosure(w, info);
-  }
+        LOCK_CLOSURE(w, info);
+        unlockClosure(w, info);
+    }
 
-  if (info == stg_WEAK_info) {
-    code = 1;
-    val = StgWeak_value(w);
-  } else {
-    code = 0;
-    val = w;
-  }
-  return (code,val);
+    if (info == stg_WEAK_info) {
+        code = 1;
+        val = StgWeak_value(w);
+    } else {
+        code = 0;
+        val = w;
+    }
+    return (code,val);
 }
 
 /* -----------------------------------------------------------------------------
@@ -563,14 +784,14 @@ stg_decodeFloatzuIntzh ( F_ arg )
 
     reserve 2 = tmp {
 
-      mp_tmp1  = tmp + WDS(1);
-      mp_tmp_w = tmp;
+        mp_tmp1  = tmp + WDS(1);
+        mp_tmp_w = tmp;
 
-      /* Perform the operation */
-      ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
+        /* Perform the operation */
+        ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
 
-      r1 = W_[mp_tmp1];
-      r2 = W_[mp_tmp_w];
+        r1 = W_[mp_tmp1];
+        r2 = W_[mp_tmp_w];
     }
 
     /* returns: (Int# (mantissa), Int# (exponent)) */
@@ -587,20 +808,20 @@ stg_decodeDoublezu2Intzh ( D_ arg )
 
     reserve 4 = tmp {
 
-      mp_tmp1    = tmp + WDS(3);
-      mp_tmp2    = tmp + WDS(2);
-      mp_result1 = tmp + WDS(1);
-      mp_result2 = tmp;
-  
-      /* Perform the operation */
-      ccall __decodeDouble_2Int(mp_tmp1 "ptr", mp_tmp2 "ptr",
-                                      mp_result1 "ptr", mp_result2 "ptr",
-                                      arg);
+        mp_tmp1    = tmp + WDS(3);
+        mp_tmp2    = tmp + WDS(2);
+        mp_result1 = tmp + WDS(1);
+        mp_result2 = tmp;
+
+        /* 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];
+        r1 = W_[mp_tmp1];
+        r2 = W_[mp_tmp2];
+        r3 = W_[mp_result1];
+        r4 = W_[mp_result2];
     }
 
     /* returns:
@@ -608,86 +829,103 @@ stg_decodeDoublezu2Intzh ( D_ arg )
     return (r1, r2, r3, r4);
 }
 
+/* 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));
+}
+
 /* -----------------------------------------------------------------------------
  * Concurrency primitives
  * -------------------------------------------------------------------------- */
 
 stg_forkzh ( gcptr closure )
 {
-  MAYBE_GC_P(stg_forkzh, closure);
+    MAYBE_GC_P(stg_forkzh, closure);
 
-  gcptr threadid;
+    gcptr threadid;
 
-  ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
-                                RtsFlags_GcFlags_initialStkSize(RtsFlags),
-                                closure "ptr");
+    ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
+                                  RtsFlags_GcFlags_initialStkSize(RtsFlags),
+                                  closure "ptr");
 
-  /* 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));
+    /* 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));
 
-  ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
+    ccall scheduleThread(MyCapability() "ptr", threadid "ptr");
 
-  // context switch soon, but not immediately: we don't want every
-  // forkIO to force a context-switch.
-  Capability_context_switch(MyCapability()) = 1 :: CInt;
+    // context switch soon, but not immediately: we don't want every
+    // forkIO to force a context-switch.
+    Capability_context_switch(MyCapability()) = 1 :: CInt;
 
-  return (threadid);
+    return (threadid);
 }
 
 stg_forkOnzh ( W_ cpu, gcptr closure )
 {
 again: MAYBE_GC(again);
 
-  gcptr threadid;
+    gcptr threadid;
 
-  ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
-                                RtsFlags_GcFlags_initialStkSize(RtsFlags),
-                                closure "ptr");
+    ("ptr" threadid) = ccall createIOThread(
+        MyCapability() "ptr",
+        RtsFlags_GcFlags_initialStkSize(RtsFlags),
+        closure "ptr");
 
-  /* 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));
+    /* 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));
 
-  ccall scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr");
+    ccall scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr");
 
-  // context switch soon, but not immediately: we don't want every
-  // forkIO to force a context-switch.
-  Capability_context_switch(MyCapability()) = 1 :: CInt;
+    // context switch soon, but not immediately: we don't want every
+    // forkIO to force a context-switch.
+    Capability_context_switch(MyCapability()) = 1 :: CInt;
 
-  return (threadid);
+    return (threadid);
 }
 
 stg_yieldzh ()
 {
-  // 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();
+    // 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();
 }
 
 stg_myThreadIdzh ()
 {
-  return (CurrentTSO);
+    return (CurrentTSO);
 }
 
 stg_labelThreadzh ( gcptr threadid, W_ addr )
 {
 #if defined(DEBUG) || defined(TRACING) || defined(DTRACE)
-  ccall labelThread(MyCapability() "ptr", threadid "ptr", addr "ptr");
+    ccall labelThread(MyCapability() "ptr", threadid "ptr", addr "ptr");
 #endif
-  return ();
+    return ();
 }
 
 stg_isCurrentThreadBoundzh (/* no args */)
 {
-  W_ r;
-  (r) = ccall isThreadBound(CurrentTSO);
-  return (r);
+    W_ r;
+    (r) = ccall isThreadBound(CurrentTSO);
+    return (r);
 }
 
 stg_threadStatuszh ( gcptr tso )
@@ -788,11 +1026,11 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
 
 // This must match StgAtomicallyFrame in Closures.h
 #define ATOMICALLY_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,code,next,result)  \
-  w_ info_ptr,                                                          \
-  PROF_HDR_FIELDS(w_,p1,p2)                                             \
-  p_ code,                                                              \
-  p_ next,                                                              \
-  p_ result
+    w_ info_ptr,                                                        \
+    PROF_HDR_FIELDS(w_,p1,p2)                                           \
+    p_ code,                                                            \
+    p_ next,                                                            \
+    p_ result
 
 
 INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
@@ -804,63 +1042,64 @@ INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
                                        frame_result))
     return (P_ result) // value returned to the frame
 {
-  W_ valid;
-  gcptr trec, outer, next_invariant, q;
-
-  trec   = StgTSO_trec(CurrentTSO);
-  outer  = StgTRecHeader_enclosing_trec(trec);
-
-  if (outer == NO_TREC) {
-    /* First time back at the atomically frame -- pick up invariants */
-    ("ptr" next_invariant) =
-        ccall stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr");
-    frame_result = result;
-
-  } else {
-    /* Second/subsequent time back at the atomically frame -- abort the
-     * tx that's checking the invariant and move on to the next one */
-    StgTSO_trec(CurrentTSO) = outer;
-    StgInvariantCheckQueue_my_execution(next_invariant) = trec;
-    ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
-    /* Don't free trec -- it's linked from q and will be stashed in the
-     * invariant if we eventually commit. */
-    next_invariant =
-       StgInvariantCheckQueue_next_queue_entry(next_invariant);
-    trec = outer;
-  }
-
-  if (next_invariant != END_INVARIANT_CHECK_QUEUE) {
-    /* We can't commit yet: another invariant to check */
-    ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", trec "ptr");
-    StgTSO_trec(CurrentTSO) = trec;
-    q = StgInvariantCheckQueue_invariant(next_invariant);
-    jump stg_ap_v_fast
-        (ATOMICALLY_FRAME_FIELDS(,,info_ptr,p1,p2,
-                                 code,next_invariant,frame_result))
-        (StgAtomicInvariant_code(q));
+    W_ valid;
+    gcptr trec, outer, next_invariant, q;
+
+    trec   = StgTSO_trec(CurrentTSO);
+    outer  = StgTRecHeader_enclosing_trec(trec);
 
-  } else {
+    if (outer == NO_TREC) {
+        /* First time back at the atomically frame -- pick up invariants */
+        ("ptr" next_invariant) =
+            ccall stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr");
+        frame_result = result;
 
-    /* We've got no more invariants to check, try to commit */
-    (valid) = ccall stmCommitTransaction(MyCapability() "ptr", trec "ptr");
-    if (valid != 0) {
-      /* Transaction was valid: commit succeeded */
-      StgTSO_trec(CurrentTSO) = NO_TREC;
-      return (frame_result);
     } else {
-      /* Transaction was not valid: try again */
-      ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
-      StgTSO_trec(CurrentTSO) = trec;
-      next_invariant = END_INVARIANT_CHECK_QUEUE;
+        /* Second/subsequent time back at the atomically frame -- abort the
+         * tx that's checking the invariant and move on to the next one */
+        StgTSO_trec(CurrentTSO) = outer;
+        StgInvariantCheckQueue_my_execution(next_invariant) = trec;
+        ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
+        /* Don't free trec -- it's linked from q and will be stashed in the
+         * invariant if we eventually commit. */
+        next_invariant =
+           StgInvariantCheckQueue_next_queue_entry(next_invariant);
+        trec = outer;
+    }
 
-      jump stg_ap_v_fast
-          // push the StgAtomicallyFrame again: the code generator is
-          // clever enough to only assign the fields that have changed.
-          (ATOMICALLY_FRAME_FIELDS(,,info_ptr,p1,p2,
-                                   code,next_invariant,frame_result))
-          (code);
+    if (next_invariant != END_INVARIANT_CHECK_QUEUE) {
+        /* We can't commit yet: another invariant to check */
+        ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", trec "ptr");
+        StgTSO_trec(CurrentTSO) = trec;
+        q = StgInvariantCheckQueue_invariant(next_invariant);
+        jump stg_ap_v_fast
+            (ATOMICALLY_FRAME_FIELDS(,,info_ptr,p1,p2,
+                                     code,next_invariant,frame_result))
+            (StgAtomicInvariant_code(q));
+
+    } else {
+
+        /* We've got no more invariants to check, try to commit */
+        (valid) = ccall stmCommitTransaction(MyCapability() "ptr", trec "ptr");
+        if (valid != 0) {
+            /* Transaction was valid: commit succeeded */
+            StgTSO_trec(CurrentTSO) = NO_TREC;
+            return (frame_result);
+        } else {
+            /* Transaction was not valid: try again */
+            ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr",
+                                                     NO_TREC "ptr");
+            StgTSO_trec(CurrentTSO) = trec;
+            next_invariant = END_INVARIANT_CHECK_QUEUE;
+
+            jump stg_ap_v_fast
+                // push the StgAtomicallyFrame again: the code generator is
+                // clever enough to only assign the fields that have changed.
+                (ATOMICALLY_FRAME_FIELDS(,,info_ptr,p1,p2,
+                                         code,next_invariant,frame_result))
+                (code);
+        }
     }
-  }
 }
 
 
@@ -873,27 +1112,27 @@ INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME,
                                        frame_result))
     return (/* no return values */)
 {
-  W_ trec, valid;
-
-  /* The TSO is currently waiting: should we stop waiting? */
-  (valid) = ccall stmReWait(MyCapability() "ptr", CurrentTSO "ptr");
-  if (valid != 0) {
-      /* Previous attempt is still valid: no point trying again yet */
-      jump stg_block_noregs
-          (ATOMICALLY_FRAME_FIELDS(,,info_ptr, p1, p2,
-                                   code,next_invariant,frame_result))
-          ();
-  } else {
-    /* Previous attempt is no longer valid: try again */
-    ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
-    StgTSO_trec(CurrentTSO) = trec;
-
-    // change the frame header to stg_atomically_frame_info
-    jump stg_ap_v_fast
-        (ATOMICALLY_FRAME_FIELDS(,,stg_atomically_frame_info, p1, p2,
-                                 code,next_invariant,frame_result))
-        (code);
-  }
+    W_ trec, valid;
+
+    /* The TSO is currently waiting: should we stop waiting? */
+    (valid) = ccall stmReWait(MyCapability() "ptr", CurrentTSO "ptr");
+    if (valid != 0) {
+        /* Previous attempt is still valid: no point trying again yet */
+        jump stg_block_noregs
+            (ATOMICALLY_FRAME_FIELDS(,,info_ptr, p1, p2,
+                                     code,next_invariant,frame_result))
+            ();
+    } else {
+        /* Previous attempt is no longer valid: try again */
+        ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
+        StgTSO_trec(CurrentTSO) = trec;
+
+        // change the frame header to stg_atomically_frame_info
+        jump stg_ap_v_fast
+            (ATOMICALLY_FRAME_FIELDS(,,stg_atomically_frame_info, p1, p2,
+                                     code,next_invariant,frame_result))
+            (code);
+    }
 }
 
 // STM catch frame -------------------------------------------------------------
@@ -904,10 +1143,10 @@ INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME,
  */
 
 #define CATCH_STM_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,code,handler) \
-  w_ info_ptr,                                                  \
-  PROF_HDR_FIELDS(w_,p1,p2)                                     \
-  p_ code,                                                      \
-  p_ handler
+    w_ info_ptr,                                                  \
+    PROF_HDR_FIELDS(w_,p1,p2)                                     \
+    p_ code,                                                      \
+    p_ handler
 
 INFO_TABLE_RET(stg_catch_stm_frame, CATCH_STM_FRAME,
                // layout of the frame, and bind the field names
@@ -940,34 +1179,34 @@ INFO_TABLE_RET(stg_catch_stm_frame, CATCH_STM_FRAME,
 
 stg_atomicallyzh (P_ stm)
 {
-  P_ old_trec;
-  P_ new_trec;
-  P_ code, next_invariant, frame_result;
+    P_ old_trec;
+    P_ new_trec;
+    P_ code, next_invariant, frame_result;
 
-  // stmStartTransaction may allocate
-  MAYBE_GC_P(stg_atomicallyzh, stm);
+    // stmStartTransaction may allocate
+    MAYBE_GC_P(stg_atomicallyzh, stm);
 
-  STK_CHK_GEN();
+    STK_CHK_GEN();
 
-  old_trec = StgTSO_trec(CurrentTSO);
+    old_trec = StgTSO_trec(CurrentTSO);
 
-  /* Nested transactions are not allowed; raise an exception */
-  if (old_trec != NO_TREC) {
-     jump stg_raisezh(base_ControlziExceptionziBase_nestedAtomically_closure);
-  }
+    /* Nested transactions are not allowed; raise an exception */
+    if (old_trec != NO_TREC) {
+        jump stg_raisezh(base_ControlziExceptionziBase_nestedAtomically_closure);
+    }
 
-  code = stm;
-  next_invariant = END_INVARIANT_CHECK_QUEUE;
-  frame_result = NO_TREC;
+    code = stm;
+    next_invariant = END_INVARIANT_CHECK_QUEUE;
+    frame_result = NO_TREC;
 
-  /* Start the memory transcation */
-  ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr", old_trec "ptr");
-  StgTSO_trec(CurrentTSO) = new_trec;
+    /* Start the memory transcation */
+    ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr", old_trec "ptr");
+    StgTSO_trec(CurrentTSO) = new_trec;
 
-  jump stg_ap_v_fast
-      (ATOMICALLY_FRAME_FIELDS(,,stg_atomically_frame_info, CCCS, 0,
-                               code,next_invariant,frame_result))
-      (stm);
+    jump stg_ap_v_fast
+        (ATOMICALLY_FRAME_FIELDS(,,stg_atomically_frame_info, CCCS, 0,
+                                 code,next_invariant,frame_result))
+        (stm);
 }
 
 // A closure representing "atomically x".  This is used when a thread
@@ -1004,99 +1243,98 @@ stg_catchSTMzh (P_ code    /* :: STM a */,
 stg_catchRetryzh (P_ first_code, /* :: STM a */
                   P_ alt_code    /* :: STM a */)
 {
-  W_ new_trec;
+    W_ new_trec;
 
-  // stmStartTransaction may allocate
-  MAYBE_GC_PP (stg_catchRetryzh, first_code, alt_code);
+    // stmStartTransaction may allocate
+    MAYBE_GC_PP (stg_catchRetryzh, first_code, alt_code);
 
-  STK_CHK_GEN();
+    STK_CHK_GEN();
 
-  /* Start a nested transaction within which to run the first code */
-  ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr",
-                                               StgTSO_trec(CurrentTSO) "ptr");
-  StgTSO_trec(CurrentTSO) = new_trec;
+    /* Start a nested transaction within which to run the first code */
+    ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr",
+                                                 StgTSO_trec(CurrentTSO) "ptr");
+    StgTSO_trec(CurrentTSO) = new_trec;
 
-  // push the CATCH_RETRY stack frame, and apply first_code to realWorld#
-  jump stg_ap_v_fast
-      (CATCH_RETRY_FRAME_FIELDS(,, stg_catch_retry_frame_info, CCCS, 0,
-                                0, /* not running_alt_code */
-                                first_code,
-                                alt_code))
-      (first_code);
+    // push the CATCH_RETRY stack frame, and apply first_code to realWorld#
+    jump stg_ap_v_fast
+        (CATCH_RETRY_FRAME_FIELDS(,, stg_catch_retry_frame_info, CCCS, 0,
+                                  0, /* not running_alt_code */
+                                  first_code,
+                                  alt_code))
+        (first_code);
 }
 
-
 stg_retryzh /* no arg list: explicit stack layout */
 {
-  W_ frame_type;
-  W_ frame;
-  W_ trec;
-  W_ outer;
-  W_ r;
+    W_ frame_type;
+    W_ frame;
+    W_ trec;
+    W_ outer;
+    W_ r;
 
-  // STM operations may allocate
-  MAYBE_GC_ (stg_retryzh); // NB. not MAYBE_GC(), we cannot make a
-                           // function call in an explicit-stack proc
+    // STM operations may allocate
+    MAYBE_GC_ (stg_retryzh); // NB. not MAYBE_GC(), we cannot make a
+                             // function call in an explicit-stack proc
 
-  // Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME
+    // Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME
 retry_pop_stack:
-  SAVE_THREAD_STATE();
-  (frame_type) = ccall findRetryFrameHelper(MyCapability(), CurrentTSO "ptr");
-  LOAD_THREAD_STATE();
-  frame = Sp;
-  trec = StgTSO_trec(CurrentTSO);
-  outer  = StgTRecHeader_enclosing_trec(trec);
-
-  if (frame_type == CATCH_RETRY_FRAME) {
-    // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
-    ASSERT(outer != NO_TREC);
-    // Abort the transaction attempting the current branch
-    ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
-    ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
-    if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
-      // Retry in the first branch: try the alternative
-      ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
-      StgTSO_trec(CurrentTSO) = trec;
-      StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
-      R1 = StgCatchRetryFrame_alt_code(frame);
-      jump stg_ap_v_fast [R1];
-    } else {
-      // Retry in the alternative code: propagate the retry
-      StgTSO_trec(CurrentTSO) = outer;
-      Sp = Sp + SIZEOF_StgCatchRetryFrame;
-      goto retry_pop_stack;
-    }
-  }
-
-  // We've reached the ATOMICALLY_FRAME: attempt to wait
-  ASSERT(frame_type == ATOMICALLY_FRAME);
-  if (outer != NO_TREC) {
-    // We called retry while checking invariants, so abort the current
-    // invariant check (merging its TVar accesses into the parents read
-    // set so we'll wait on them)
-    ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
-    ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
-    trec = outer;
-    StgTSO_trec(CurrentTSO) = trec;
+    SAVE_THREAD_STATE();
+    (frame_type) = ccall findRetryFrameHelper(MyCapability(), CurrentTSO "ptr");
+    LOAD_THREAD_STATE();
+    frame = Sp;
+    trec = StgTSO_trec(CurrentTSO);
     outer  = StgTRecHeader_enclosing_trec(trec);
-  }
-  ASSERT(outer == NO_TREC);
-
-  (r) = ccall stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr");
-  if (r != 0) {
-    // Transaction was valid: stmWait put us on the TVars' queues, we now block
-    StgHeader_info(frame) = stg_atomically_waiting_frame_info;
-    Sp = frame;
-    R3 = trec; // passing to stmWaitUnblock()
-    jump stg_block_stmwait [R3];
-  } else {
-    // Transaction was not valid: retry immediately
-    ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
-    StgTSO_trec(CurrentTSO) = trec;
-    Sp = frame;
-    R1 = StgAtomicallyFrame_code(frame);
-    jump stg_ap_v_fast [R1];
-  }
+
+    if (frame_type == CATCH_RETRY_FRAME) {
+        // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
+        ASSERT(outer != NO_TREC);
+        // Abort the transaction attempting the current branch
+        ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
+        ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
+        if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
+            // Retry in the first branch: try the alternative
+            ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
+            StgTSO_trec(CurrentTSO) = trec;
+            StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
+            R1 = StgCatchRetryFrame_alt_code(frame);
+            jump stg_ap_v_fast [R1];
+        } else {
+            // Retry in the alternative code: propagate the retry
+            StgTSO_trec(CurrentTSO) = outer;
+            Sp = Sp + SIZEOF_StgCatchRetryFrame;
+            goto retry_pop_stack;
+        }
+    }
+
+    // We've reached the ATOMICALLY_FRAME: attempt to wait
+    ASSERT(frame_type == ATOMICALLY_FRAME);
+    if (outer != NO_TREC) {
+        // We called retry while checking invariants, so abort the current
+        // invariant check (merging its TVar accesses into the parents read
+        // set so we'll wait on them)
+        ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
+        ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
+        trec = outer;
+        StgTSO_trec(CurrentTSO) = trec;
+        outer  = StgTRecHeader_enclosing_trec(trec);
+    }
+    ASSERT(outer == NO_TREC);
+
+    (r) = ccall stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr");
+    if (r != 0) {
+        // Transaction was valid: stmWait put us on the TVars' queues, we now block
+        StgHeader_info(frame) = stg_atomically_waiting_frame_info;
+        Sp = frame;
+        R3 = trec; // passing to stmWaitUnblock()
+        jump stg_block_stmwait [R3];
+    } else {
+        // Transaction was not valid: retry immediately
+        ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
+        StgTSO_trec(CurrentTSO) = trec;
+        Sp = frame;
+        R1 = StgAtomicallyFrame_code(frame);
+        jump stg_ap_v_fast [R1];
+    }
 }
 
 stg_checkzh (P_ closure /* STM a */)
@@ -1132,16 +1370,16 @@ stg_newTVarzh (P_ init)
 
 stg_readTVarzh (P_ tvar)
 {
-  P_ trec;
-  P_ result;
+    P_ trec;
+    P_ result;
 
-  // Call to stmReadTVar may allocate
-  MAYBE_GC_P (stg_readTVarzh, tvar);
+    // Call to stmReadTVar may allocate
+    MAYBE_GC_P (stg_readTVarzh, tvar);
 
-  trec = StgTSO_trec(CurrentTSO);
-  ("ptr" result) = ccall stmReadTVar(MyCapability() "ptr", trec "ptr",
-                                     tvar "ptr");
-  return (result);
+    trec = StgTSO_trec(CurrentTSO);
+    ("ptr" result) = ccall stmReadTVar(MyCapability() "ptr", trec "ptr",
+                                       tvar "ptr");
+    return (result);
 }
 
 stg_readTVarIOzh ( P_ tvar /* :: TVar a */ )
@@ -1501,6 +1739,13 @@ loop:
 }
 
 
+// NOTE: there is another implementation of this function in
+// Threads.c:performTryPutMVar().  Keep them in sync!  It was
+// measurably slower to call the C function from here (70% for a
+// tight loop doing tryPutMVar#).
+//
+// TODO: we could kill the duplication by making tryPutMVar# into an
+// inline primop that expands into a C call to performTryPutMVar().
 stg_tryPutMVarzh ( P_ mvar, /* :: MVar a */
                    P_ val,  /* :: a */ )
 {
@@ -1574,6 +1819,7 @@ loop:
     return (1);
 }
 
+
 stg_readMVarzh ( P_ mvar, /* :: MVar a */ )
 {
     W_ val, info, tso, q;
@@ -1627,6 +1873,7 @@ stg_tryReadMVarzh ( P_ mvar, /* :: MVar a */ )
     LOCK_CLOSURE(mvar, info);
 
     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
+        unlockClosure(mvar, info);
         return (0, stg_NO_FINALIZER_closure);
     }
 
@@ -1678,6 +1925,137 @@ stg_deRefStablePtrzh ( P_ sp )
 }
 
 /* -----------------------------------------------------------------------------
+   CompactNFData primitives
+
+   See Note [Compact Normal Forms]
+   -------------------------------------------------------------------------  */
+
+stg_compactNewzh ( W_ size )
+{
+    P_ str;
+
+    again: MAYBE_GC(again);
+
+    ("ptr" str) = ccall compactNew(MyCapability() "ptr", size);
+    return (str);
+}
+
+stg_compactAppendzh ( P_ str, P_ val , W_ share)
+{
+    P_ root;
+
+    again: MAYBE_GC(again);
+
+     ("ptr" root) = ccall compactAppend(MyCapability() "ptr", str "ptr", val "ptr", share);
+    return (root);
+}
+
+stg_compactResizzezh ( P_ str, W_ new_size )
+{
+    again: MAYBE_GC(again);
+
+    ccall compactResize(MyCapability() "ptr", str "ptr", new_size);
+    return ();
+}
+
+stg_compactContainszh ( P_ str, P_ val )
+{
+    W_ rval;
+
+    (rval) = ccall compactContains(str "ptr", val "ptr");
+    return (rval);
+}
+
+stg_compactContainsAnyzh ( P_ val )
+{
+    W_ rval;
+
+    (rval) = ccall compactContains(0 "ptr", val "ptr");
+    return (rval);
+}
+
+stg_compactGetFirstBlockzh ( P_ str )
+{
+    /* W_, not P_, because it is not a gc pointer */
+    W_ block;
+    W_ bd;
+    W_ size;
+
+    block = str - SIZEOF_StgCompactNFDataBlock::W_;
+    ASSERT (StgCompactNFDataBlock_owner(block) == str);
+
+    bd = Bdescr(str);
+    size = bdescr_free(bd) - bdescr_start(bd);
+    ASSERT (size <= TO_W_(bdescr_blocks(bd)) * BLOCK_SIZE);
+
+    return (block, size);
+}
+
+stg_compactGetNextBlockzh ( P_ str, W_ block )
+{
+    /* str is a pointer to the closure holding the Compact#
+       it is there primarily to keep everything reachable from
+       the GC: by having it on the stack of type P_, the GC will
+       see all the blocks as live (any pointer in the Compact#
+       keeps it alive), and will not collect the block
+       We don't run a GC inside this primop, but it could
+       happen right after, or we could be preempted.
+
+       str is also useful for debugging, as it can be casted
+       to a useful C struct from the gdb command line and all
+       blocks can be inspected
+    */
+    W_ bd;
+    W_ next_block;
+    W_ size;
+
+    next_block = StgCompactNFDataBlock_next(block);
+
+    if (next_block == 0::W_) {
+        return (0::W_, 0::W_);
+    }
+
+    ASSERT (StgCompactNFDataBlock_owner(next_block) == str ||
+            StgCompactNFDataBlock_owner(next_block) == NULL);
+
+    bd = Bdescr(next_block);
+    size = bdescr_free(bd) - bdescr_start(bd);
+    ASSERT (size <= TO_W_(bdescr_blocks(bd)) * BLOCK_SIZE);
+
+    return (next_block, size);
+}
+
+stg_compactAllocateBlockzh ( W_ size, W_ previous )
+{
+    W_ actual_block;
+
+    again: MAYBE_GC(again);
+
+    ("ptr" actual_block) = ccall compactAllocateBlock(MyCapability(),
+                                                      size,
+                                                      previous "ptr");
+
+    return (actual_block);
+}
+
+stg_compactFixupPointerszh ( W_ first_block, W_ root )
+{
+    W_ str;
+    P_ gcstr;
+    W_ ok;
+
+    str = first_block + SIZEOF_StgCompactNFDataBlock::W_;
+    (ok) = ccall compactFixupPointers (str "ptr", root "ptr");
+
+    // Now we can let the GC know about str, because it was linked
+    // into the generation list and the book-keeping pointers are
+    // guaranteed to be valid
+    // (this is true even if the fixup phase failed)
+    gcstr = str;
+    return (gcstr, ok);
+}
+
+/* -----------------------------------------------------------------------------
    Bytecode object primitives
    -------------------------------------------------------------------------  */
 
@@ -1695,7 +2073,7 @@ stg_newBCOzh ( P_ instrs,
     ALLOC_PRIM (bytes);
 
     bco = Hp - bytes + WDS(1);
-    SET_HDR(bco, stg_BCO_info, CCCS);
+    SET_HDR(bco, stg_BCO_info, CCS_MAIN);
 
     StgBCO_instrs(bco)     = instrs;
     StgBCO_literals(bco)   = literals;
@@ -1708,7 +2086,7 @@ stg_newBCOzh ( P_ instrs,
     i = 0;
 for:
     if (i < BYTE_ARR_WDS(bitmap_arr)) {
-        StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
+        StgBCO_bitmap(bco,i) = StgArrBytes_payload(bitmap_arr,i);
         i = i + 1;
         goto for;
     }
@@ -1731,7 +2109,7 @@ stg_mkApUpd0zh ( P_ bco )
     CCCS_ALLOC(SIZEOF_StgAP);
 
     ap = Hp - SIZEOF_StgAP + WDS(1);
-    SET_HDR(ap, stg_AP_info, CCCS);
+    SET_HDR(ap, stg_AP_info, CCS_MAIN);
 
     StgAP_n_args(ap) = HALF_W_(0);
     StgAP_fun(ap) = bco;
@@ -1741,8 +2119,6 @@ stg_mkApUpd0zh ( P_ bco )
 
 stg_unpackClosurezh ( P_ closure )
 {
-// TODO: Consider the absence of ptrs or nonptrs as a special case ?
-
     W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
     info  = %GET_STD_INFO(UNTAG(closure));
 
@@ -1769,7 +2145,7 @@ stg_unpackClosurezh ( P_ closure )
 out:
 
     W_ ptrs_arr_sz, ptrs_arr_cards, nptrs_arr_sz;
-    nptrs_arr_sz = SIZEOF_StgArrWords   + WDS(nptrs);
+    nptrs_arr_sz = SIZEOF_StgArrBytes   + WDS(nptrs);
     ptrs_arr_cards = mutArrPtrsCardWords(ptrs);
     ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs) + WDS(ptrs_arr_cards);
 
@@ -1797,7 +2173,7 @@ for:
        is promoted. */
 
     SET_HDR(nptrs_arr, stg_ARR_WORDS_info, CCCS);
-    StgArrWords_bytes(nptrs_arr) = WDS(nptrs);
+    StgArrBytes_bytes(nptrs_arr) = WDS(nptrs);
     p = 0;
 for2:
     if(p < nptrs) {
@@ -1818,9 +2194,9 @@ for2:
 #define APPEND_TO_BLOCKED_QUEUE(tso)                    \
     ASSERT(StgTSO__link(tso) == END_TSO_QUEUE);         \
     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {        \
-      W_[blocked_queue_hd] = tso;                       \
+        W_[blocked_queue_hd] = tso;                     \
     } else {                                            \
-      ccall setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso); \
+        ccall setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso); \
     }                                                   \
     W_[blocked_queue_tl] = tso;
 
@@ -2120,64 +2496,72 @@ stg_traceCcszh ( P_ obj, P_ ret )
 
 stg_getSparkzh ()
 {
-   W_ spark;
+    W_ spark;
 
 #ifndef THREADED_RTS
-   return (0,ghczmprim_GHCziTypes_False_closure);
+    return (0,ghczmprim_GHCziTypes_False_closure);
 #else
-   (spark) = ccall findSpark(MyCapability());
-   if (spark != 0) {
-      return (1,spark);
-   } else {
-      return (0,ghczmprim_GHCziTypes_False_closure);
-   }
+    ("ptr" spark) = ccall findSpark(MyCapability() "ptr");
+    if (spark != 0) {
+        return (1,spark);
+    } else {
+        return (0,ghczmprim_GHCziTypes_False_closure);
+    }
+#endif
+}
+
+stg_clearCCSzh (P_ arg)
+{
+#ifdef PROFILING
+    CCCS = CCS_MAIN;
 #endif
+    jump stg_ap_v_fast(arg);
 }
 
 stg_numSparkszh ()
 {
-  W_ n;
+    W_ n;
 #ifdef THREADED_RTS
-  (n) = ccall dequeElements(Capability_sparks(MyCapability()));
+    (n) = ccall dequeElements(Capability_sparks(MyCapability()));
 #else
-  n = 0;
+    n = 0;
 #endif
-  return (n);
+    return (n);
 }
 
 stg_traceEventzh ( W_ msg )
 {
 #if defined(TRACING) || defined(DEBUG)
 
-   ccall traceUserMsg(MyCapability() "ptr", msg "ptr");
+    ccall traceUserMsg(MyCapability() "ptr", msg "ptr");
 
 #elif defined(DTRACE)
 
-   W_ enabled;
+    W_ enabled;
 
-   // We should go through the macro HASKELLEVENT_USER_MSG_ENABLED from
-   // RtsProbes.h, but that header file includes unistd.h, which doesn't
-   // work in Cmm
+    // We should go through the macro HASKELLEVENT_USER_MSG_ENABLED from
+    // RtsProbes.h, but that header file includes unistd.h, which doesn't
+    // work in Cmm
 #if !defined(solaris2_TARGET_OS)
    (enabled) = ccall __dtrace_isenabled$HaskellEvent$user__msg$v1();
 #else
-   // Solaris' DTrace can't handle the
-   //     __dtrace_isenabled$HaskellEvent$user__msg$v1
-   // call above. This call is just for testing whether the user__msg
-   // probe is enabled, and is here for just performance optimization.
-   // Since preparation for the probe is not that complex I disable usage of
-   // this test above for Solaris and enable the probe usage manually
-   // here. Please note that this does not mean that the probe will be
-   // used during the runtime! You still need to enable it by consumption
-   // in your dtrace script as you do with any other probe.
-   enabled = 1;
+    // Solaris' DTrace can't handle the
+    //     __dtrace_isenabled$HaskellEvent$user__msg$v1
+    // call above. This call is just for testing whether the user__msg
+    // probe is enabled, and is here for just performance optimization.
+    // Since preparation for the probe is not that complex I disable usage of
+    // this test above for Solaris and enable the probe usage manually
+    // here. Please note that this does not mean that the probe will be
+    // used during the runtime! You still need to enable it by consumption
+    // in your dtrace script as you do with any other probe.
+    enabled = 1;
 #endif
-   if (enabled != 0) {
-     ccall dtraceUserMsgWrapper(MyCapability() "ptr", msg "ptr");
-   }
+    if (enabled != 0) {
+      ccall dtraceUserMsgWrapper(MyCapability() "ptr", msg "ptr");
+    }
 
 #endif
-   return ();
+    return ();
 }
 
 // Same code as stg_traceEventzh above but a different kind of event
@@ -2186,22 +2570,22 @@ stg_traceMarkerzh ( W_ msg )
 {
 #if defined(TRACING) || defined(DEBUG)
 
-   ccall traceUserMarker(MyCapability() "ptr", msg "ptr");
+    ccall traceUserMarker(MyCapability() "ptr", msg "ptr");
 
 #elif defined(DTRACE)
 
-   W_ enabled;
+    W_ enabled;
 
 #if !defined(solaris2_TARGET_OS)
-   (enabled) = ccall __dtrace_isenabled$HaskellEvent$user__marker$v1();
+    (enabled) = ccall __dtrace_isenabled$HaskellEvent$user__marker$v1();
 #else
-   enabled = 1;
+    enabled = 1;
 #endif
-   if (enabled != 0) {
-     ccall dtraceUserMarkerWrapper(MyCapability() "ptr", msg "ptr");
-   }
+    if (enabled != 0) {
+        ccall dtraceUserMarkerWrapper(MyCapability() "ptr", msg "ptr");
+    }
 
 #endif
-   return ();
+    return ();
 }