Add hs_try_putmvar()
[ghc.git] / rts / PrimOps.cmm
index 9cedabd..02a7daf 100644 (file)
@@ -1,6 +1,7 @@
+/* -*- tab-width: 8 -*- */
 /* -----------------------------------------------------------------------------
  *
- * (c) The GHC Team, 1998-2011
+ * (c) The GHC Team, 1998-2012
  *
  * Out-of-line primitive operations
  *
  * this file contains code for most of those with the attribute
  * out_of_line=True.
  *
- * Entry convention: the entry convention for a primop is that all the
- * args are in Stg registers (R1, R2, etc.).  This is to make writing
- * the primops easier.  (see compiler/codeGen/CgCallConv.hs).
- *
- * Return convention: results from a primop are generally returned
- * using the ordinary unboxed tuple return convention.  The C-- parser
- * implements the RET_xxxx() macros to perform unboxed-tuple returns
- * based on the prevailing return convention.
+ * Entry convention: the entry convention for a primop is the
+ * NativeNodeCall convention, and the return convention is
+ * NativeReturn.  (see compiler/cmm/CmmCallConv.hs)
  *
  * This file is written in a subset of C--, extended with various
  * features specific to GHC.  It is compiled by GHC directly.  For the
  * ---------------------------------------------------------------------------*/
 
 #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
 
 /*-----------------------------------------------------------------------------
@@ -44,8 +45,6 @@ import sm_mutex;
 
   Basically just new*Array - the others are all inline macros.
 
-  The size arg is always passed in R1, and the result returned in R1.
-
   The slow entry point is for returning from a heap check, the saved
   size argument must be re-loaded from the stack.
   -------------------------------------------------------------------------- */
@@ -54,60 +53,62 @@ import sm_mutex;
  * round up to the nearest word for the size of the array.
  */
 
-stg_newByteArrayzh
+stg_newByteArrayzh ( W_ n )
 {
-    W_ words, payload_words, n, p;
-    MAYBE_GC(NO_PTRS,stg_newByteArrayzh);
-    n = R1;
+    W_ words, payload_words;
+    gcptr p;
+
+    MAYBE_GC_N(stg_newByteArrayzh, n);
+
     payload_words = ROUNDUP_BYTES_TO_WDS(n);
-    words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
-    ("ptr" p) = foreign "C" allocate(MyCapability() "ptr",words) [];
-    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
+    words = BYTES_TO_WDS(SIZEOF_StgArrBytes) + payload_words;
+    ("ptr" p) = ccall allocate(MyCapability() "ptr",words);
+    TICK_ALLOC_PRIM(SIZEOF_StgArrBytes,WDS(payload_words),0);
     SET_HDR(p, stg_ARR_WORDS_info, CCCS);
-    StgArrWords_bytes(p) = n;
-    RET_P(p);
+    StgArrBytes_bytes(p) = n;
+    return (p);
 }
 
 #define BA_ALIGN 16
 #define BA_MASK  (BA_ALIGN-1)
 
-stg_newPinnedByteArrayzh
+stg_newPinnedByteArrayzh ( W_ n )
 {
-    W_ words, n, bytes, payload_words, p;
+    W_ words, bytes, payload_words;
+    gcptr p;
+
+    MAYBE_GC_N(stg_newPinnedByteArrayzh, n);
 
-    MAYBE_GC(NO_PTRS,stg_newPinnedByteArrayzh);
-    n = R1;
     bytes = n;
     /* 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;
+    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;
     /* Now we convert to a number of words: */
     words = ROUNDUP_BYTES_TO_WDS(bytes);
 
-    ("ptr" p) = foreign "C" allocatePinned(MyCapability() "ptr", words) [];
-    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
+    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
+    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;
-    RET_P(p);
+    StgArrBytes_bytes(p) = n;
+    return (p);
 }
 
-stg_newAlignedPinnedByteArrayzh
+stg_newAlignedPinnedByteArrayzh ( W_ n, W_ alignment )
 {
-    W_ words, n, bytes, payload_words, p, alignment;
+    W_ words, bytes, payload_words;
+    gcptr p;
 
-    MAYBE_GC(NO_PTRS,stg_newAlignedPinnedByteArrayzh);
-    n = R1;
-    alignment = R2;
+    again: MAYBE_GC(again);
 
     /* we always supply at least word-aligned memory, so there's no
        need to allow extra space for alignment if the requirement is less
@@ -121,112 +122,251 @@ stg_newAlignedPinnedByteArrayzh
 
     /* 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;
     /* Now we convert to a number of words: */
     words = ROUNDUP_BYTES_TO_WDS(bytes);
 
-    ("ptr" p) = foreign "C" allocatePinned(MyCapability() "ptr", words) [];
-    TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
+    ("ptr" p) = ccall allocatePinned(MyCapability() "ptr", words);
+    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;
-    RET_P(p);
+    StgArrBytes_bytes(p) = n;
+    return (p);
+}
+
+stg_isByteArrayPinnedzh ( gcptr ba )
+// ByteArray# s -> Int#
+{
+    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);
+}
+
+stg_isMutableByteArrayPinnedzh ( gcptr mba )
+// MutableByteArray# s -> Int#
+{
+    jump stg_isByteArrayPinnedzh(mba);
+}
+
+// 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 ();
 }
 
-stg_newArrayzh
+// 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_ words, n, init, arr, p, size;
-    /* Args: R1 = words, R2 = initialisation value */
+   W_ new_size_wds;
 
-    n = R1;
-    MAYBE_GC(R2_PTR,stg_newArrayzh);
+   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_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# #) */
+{
+    W_ p, h;
+
+    p = arr + SIZEOF_StgArrBytes + WDS(ind);
+    (h) = prim %cmpxchgW(p, old, new);
+
+    return(h);
+}
+
+
+stg_newArrayzh ( W_ n /* words */, gcptr init )
+{
+    W_ words, size, p;
+    gcptr arr;
+
+    again: MAYBE_GC(again);
 
     // 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;
-    ("ptr" arr) = foreign "C" allocate(MyCapability() "ptr",words) [R2];
-    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);
+    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
+    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
 
     SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);
     StgMutArrPtrs_ptrs(arr) = n;
     StgMutArrPtrs_size(arr) = size;
 
     // Initialise all elements of the the array with the value in R2
-    init = R2;
     p = arr + SIZEOF_StgMutArrPtrs;
   for:
-    if (p < arr + WDS(words)) {
-       W_[p] = init;
-       p = p + WDS(1);
-       goto for;
-    }
-    // Initialise the mark bits with 0
-  for2:
-    if (p < arr + WDS(size)) {
-       W_[p] = 0;
-       p = p + WDS(1);
-       goto for2;
-    }
-
-    RET_P(arr);
-}
-
-stg_unsafeThawArrayzh
-{
-  // 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(R1) != stg_MUT_ARR_PTRS_FROZEN0_info) {
-       SET_INFO(R1,stg_MUT_ARR_PTRS_DIRTY_info);
-       recordMutable(R1, R1);
-       // must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
-       RET_P(R1);
-  } else {
-       SET_INFO(R1,stg_MUT_ARR_PTRS_DIRTY_info);
-       RET_P(R1);
-  }
-}
-
-stg_newArrayArrayzh
-{
-    W_ words, n, arr, p, size;
-    /* Args: R1 = words */
-
-    n = R1;
-    MAYBE_GC(NO_PTRS,stg_newArrayArrayzh);
+    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) {
+        W_[p] = init;
+        p = p + WDS(1);
+        goto for;
+    }
+
+    return (arr);
+}
+
+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) {
+        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 {
+        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 h;
+    W_ p, len;
+
+    p = arr + SIZEOF_StgMutArrPtrs + 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_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;
+        return (0,new);
+    }
+}
+
+stg_newArrayArrayzh ( W_ n /* words */ )
+{
+    W_ words, size, p;
+    gcptr arr;
+
+    MAYBE_GC_N(stg_newArrayArrayzh, n);
 
     // 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;
-    ("ptr" arr) = foreign "C" allocate(MyCapability() "ptr",words) [];
-    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);
+    ("ptr" arr) = ccall allocate(MyCapability() "ptr",words);
+    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);
 
     SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, W_[CCCS]);
     StgMutArrPtrs_ptrs(arr) = n;
@@ -235,20 +375,131 @@ stg_newArrayArrayzh
     // Initialise all elements of the array with a pointer to the new array
     p = arr + SIZEOF_StgMutArrPtrs;
   for:
-    if (p < arr + WDS(words)) {
-       W_[p] = arr;
-       p = p + WDS(1);
-       goto for;
+    if (p < arr + SIZEOF_StgMutArrPtrs + WDS(n)) {
+        W_[p] = arr;
+        p = p + WDS(1);
+        goto for;
     }
-    // Initialise the mark bits with 0
-  for2:
-    if (p < arr + WDS(size)) {
-       W_[p] = 0;
-       p = p + WDS(1);
-       goto for2;
+
+    return (arr);
+}
+
+
+/* -----------------------------------------------------------------------------
+   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);
     }
 
-    RET_P(arr);
+    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);
+    }
 }
 
 
@@ -256,60 +507,57 @@ stg_newArrayArrayzh
    MutVar primitives
    -------------------------------------------------------------------------- */
 
-stg_newMutVarzh
+stg_newMutVarzh ( gcptr init )
 {
     W_ mv;
-    /* Args: R1 = initialisation value */
 
-    ALLOC_PRIM( SIZEOF_StgMutVar, R1_PTR, stg_newMutVarzh);
+    ALLOC_PRIM_P (SIZEOF_StgMutVar, stg_newMutVarzh, init);
 
     mv = Hp - SIZEOF_StgMutVar + WDS(1);
     SET_HDR(mv,stg_MUT_VAR_DIRTY_info,CCCS);
-    StgMutVar_var(mv) = R1;
-    
-    RET_P(mv);
+    StgMutVar_var(mv) = init;
+
+    return (mv);
 }
 
-stg_casMutVarzh
- /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, a #) */
+// 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.
+stg_casMutVarzh ( gcptr mv, gcptr old, gcptr new )
+ /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, Any a #) */
 {
-    W_ mv, old, new, h;
-
-    mv  = R1;
-    old = R2;
-    new = R3;
+    gcptr h;
 
-    (h) = foreign "C" cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var,
-                          old, new) [];
+    (h) = prim %cmpxchgW(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, old, new);
     if (h != old) {
-        RET_NP(1,h);
+        return (1,h);
     } else {
         if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
-           foreign "C" dirty_MUT_VAR(BaseReg "ptr", mv "ptr") [];
+            ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
         }
-        RET_NP(0,h);
+        return (0,new);
     }
 }
 
-
-stg_atomicModifyMutVarzh
+stg_atomicModifyMutVarzh ( gcptr mv, gcptr f )
 {
-    W_ mv, f, z, x, y, r, h;
-    /* Args: R1 :: MutVar#,  R2 :: a -> (a,b) */
+    W_ z, x, y, r, h;
 
-    /* If x is the current contents of the MutVar#, then 
+    /* If x is the current contents of the MutVar#, then
        We want to make the new contents point to
 
          (sel_0 (f x))
+
        and the return value is
-        
-        (sel_1 (f x))
+
+         (sel_1 (f x))
 
         obviously we can share (f x).
 
          z = [stg_ap_2 f x]  (max (HS + 2) MIN_UPD_SIZE)
-        y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
+         y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
          r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
     */
 
@@ -331,47 +579,44 @@ stg_atomicModifyMutVarzh
 
 #define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)
 
-   HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, stg_atomicModifyMutVarzh);
-
-   mv = R1;
-   f = R2;
-
-   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) = foreign "C" 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) {
-     foreign "C" dirty_MUT_VAR(BaseReg "ptr", mv "ptr") [];
-   }
+    if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
+        ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr");
+    }
 
-   RET_P(r);
+    return (r);
 }
 
 /* -----------------------------------------------------------------------------
@@ -380,334 +625,315 @@ stg_atomicModifyMutVarzh
 
 STRING(stg_weak_msg,"New weak pointer at %p\n")
 
-stg_mkWeakzh
+stg_mkWeakzh ( gcptr key,
+               gcptr value,
+               gcptr finalizer /* or stg_NO_FINALIZER_closure */ )
 {
-  /* R1 = key
-     R2 = value
-     R3 = finalizer (or stg_NO_FINALIZER_closure)
-  */
-  W_ w;
-
-  ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, stg_mkWeakzh );
+    gcptr w;
 
-  w = Hp - SIZEOF_StgWeak + WDS(1);
-  SET_HDR(w, stg_WEAK_info, CCCS);
+    ALLOC_PRIM (SIZEOF_StgWeak)
 
-  // We don't care about cfinalizer here.
-  // Should StgWeak_cfinalizer(w) be stg_NO_FINALIZER_closure or
-  // something else?
+    w = Hp - SIZEOF_StgWeak + WDS(1);
+    SET_HDR(w, stg_WEAK_info, CCCS);
 
-  StgWeak_key(w)        = R1;
-  StgWeak_value(w)      = R2;
-  StgWeak_finalizer(w)  = R3;
-  StgWeak_cfinalizer(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)      = W_[weak_ptr_list];
-  W_[weak_ptr_list]    = 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, foreign "C" debugBelch(stg_weak_msg,w) []);
+    IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w));
 
-  RET_P(w);
+    return (w);
 }
 
-stg_mkWeakNoFinalizzerzh
+stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value )
 {
-  /* R1 = key
-     R2 = value
-   */
-  R3 = stg_NO_FINALIZER_closure;
-
-  jump stg_mkWeakzh;
+    jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure);
 }
 
-stg_mkWeakForeignEnvzh
-{
-  /* R1 = key
-     R2 = value
-     R3 = finalizer
-     R4 = pointer
-     R5 = has environment (0 or 1)
-     R6 = environment
-  */
-  W_ w, payload_words, words, p;
-
-  W_ key, val, fptr, ptr, flag, eptr;
+STRING(stg_cfinalizer_msg,"Adding a finalizer to %p\n")
 
-  key  = R1;
-  val  = R2;
-  fptr = R3;
-  ptr  = R4;
-  flag = R5;
-  eptr = R6;
+stg_addCFinalizzerToWeakzh ( W_ fptr,   // finalizer
+                             W_ ptr,
+                             W_ flag,   // has environment (0 or 1)
+                             W_ eptr,
+                             gcptr w )
+{
+    W_ c, info;
 
-  ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR, stg_mkWeakForeignEnvzh );
+    ALLOC_PRIM (SIZEOF_StgCFinalizerList)
 
-  w = Hp - SIZEOF_StgWeak + WDS(1);
-  SET_HDR(w, stg_WEAK_info, CCCS);
+    c = Hp - SIZEOF_StgCFinalizerList + WDS(1);
+    SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS);
 
-  payload_words = 4;
-  words         = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
-  ("ptr" p)     = foreign "C" allocate(MyCapability() "ptr", words) [];
+    StgCFinalizerList_fptr(c) = fptr;
+    StgCFinalizerList_ptr(c) = ptr;
+    StgCFinalizerList_eptr(c) = eptr;
+    StgCFinalizerList_flag(c) = flag;
 
-  TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
-  SET_HDR(p, stg_ARR_WORDS_info, CCCS);
+    LOCK_CLOSURE(w, info);
 
-  StgArrWords_bytes(p)     = WDS(payload_words);
-  StgArrWords_payload(p,0) = fptr;
-  StgArrWords_payload(p,1) = ptr;
-  StgArrWords_payload(p,2) = eptr;
-  StgArrWords_payload(p,3) = flag;
+    if (info == stg_DEAD_WEAK_info) {
+        // Already dead.
+        unlockClosure(w, info);
+        return (0);
+    }
 
-  // We don't care about the value here.
-  // Should StgWeak_value(w) be stg_NO_FINALIZER_closure or something else?
+    StgCFinalizerList_link(c) = StgWeak_cfinalizers(w);
+    StgWeak_cfinalizers(w) = c;
 
-  StgWeak_key(w)        = key;
-  StgWeak_value(w)      = val;
-  StgWeak_finalizer(w)  = stg_NO_FINALIZER_closure;
-  StgWeak_cfinalizer(w) = p;
+    unlockClosure(w, info);
 
-  ACQUIRE_LOCK(sm_mutex);
-  StgWeak_link(w)   = W_[weak_ptr_list];
-  W_[weak_ptr_list] = w;
-  RELEASE_LOCK(sm_mutex);
+    recordMutable(w);
 
-  IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);
+    IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w));
 
-  RET_P(w);
+    return (1);
 }
 
-stg_finalizzeWeakzh
+stg_finalizzeWeakzh ( gcptr w )
 {
-  /* R1 = weak ptr
-   */
-  W_ w, f, arr;
+    gcptr f, list;
+    W_ info;
 
-  w = R1;
+    LOCK_CLOSURE(w, info);
 
-  // already dead?
-  if (GET_INFO(w) == stg_DEAD_WEAK_info) {
-      RET_NP(0,stg_NO_FINALIZER_closure);
-  }
+    // already dead?
+    if (info == stg_DEAD_WEAK_info) {
+        unlockClosure(w, info);
+        return (0,stg_NO_FINALIZER_closure);
+    }
 
-  // kill it
+    f    = StgWeak_finalizer(w);
+    list = StgWeak_cfinalizers(w);
+
+    // 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()?
-  //
-  SET_INFO(w,stg_DEAD_WEAK_info);
-  LDV_RECORD_CREATE(w);
-
-  f   = StgWeak_finalizer(w);
-  arr = StgWeak_cfinalizer(w);
+    //
+    // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
+    //
+    unlockClosure(w, stg_DEAD_WEAK_info);
 
-  StgDeadWeak_link(w) = StgWeak_link(w);
+    LDV_RECORD_CREATE(w);
 
-  if (arr != stg_NO_FINALIZER_closure) {
-    foreign "C" runCFinalizer(StgArrWords_payload(arr,0),
-                              StgArrWords_payload(arr,1),
-                              StgArrWords_payload(arr,2),
-                              StgArrWords_payload(arr,3)) [];
-  }
+    if (list != stg_NO_FINALIZER_closure) {
+      ccall runCFinalizers(list);
+    }
 
-  /* return the finalizer */
-  if (f == stg_NO_FINALIZER_closure) {
-      RET_NP(0,stg_NO_FINALIZER_closure);
-  } else {
-      RET_NP(1,f);
-  }
+    /* return the finalizer */
+    if (f == stg_NO_FINALIZER_closure) {
+        return (0,stg_NO_FINALIZER_closure);
+    } else {
+        return (1,f);
+    }
 }
 
-stg_deRefWeakzh
+stg_deRefWeakzh ( gcptr w )
 {
-  /* R1 = weak ptr */
-  W_ w, code, val;
+    W_ code, info;
+    gcptr val;
+
+    info = GET_INFO(w);
 
-  w = R1;
-  if (GET_INFO(w) == stg_WEAK_info) {
-    code = 1;
-    val = StgWeak_value(w);
-  } else {
-    code = 0;
-    val = w;
-  }
-  RET_NP(code,val);
+    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);
+    }
+
+    if (info == stg_WEAK_info) {
+        code = 1;
+        val = StgWeak_value(w);
+    } else {
+        code = 0;
+        val = w;
+    }
+    return (code,val);
 }
 
 /* -----------------------------------------------------------------------------
    Floating point operations.
    -------------------------------------------------------------------------- */
 
-stg_decodeFloatzuIntzh
-{ 
+stg_decodeFloatzuIntzh ( F_ arg )
+{
     W_ p;
-    F_ arg;
-    W_ mp_tmp1;
-    W_ mp_tmp_w;
-
-    STK_CHK_GEN( WDS(2), NO_PTRS, stg_decodeFloatzuIntzh );
-
-    mp_tmp1  = Sp - WDS(1);
-    mp_tmp_w = Sp - WDS(2);
-    
-    /* arguments: F1 = Float# */
-    arg = F1;
-    
-    /* Perform the operation */
-    foreign "C" __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg) [];
-    
+    W_ tmp, mp_tmp1, mp_tmp_w, r1, r2;
+
+    STK_CHK_GEN_N (WDS(2));
+
+    reserve 2 = tmp {
+
+        mp_tmp1  = tmp + WDS(1);
+        mp_tmp_w = tmp;
+
+        /* Perform the operation */
+        ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg);
+
+        r1 = W_[mp_tmp1];
+        r2 = W_[mp_tmp_w];
+    }
+
     /* returns: (Int# (mantissa), Int# (exponent)) */
-    RET_NN(W_[mp_tmp1], W_[mp_tmp_w]);
+    return (r1, r2);
 }
 
-stg_decodeDoublezu2Intzh
-{ 
-    D_ arg;
-    W_ p;
-    W_ mp_tmp1;
-    W_ mp_tmp2;
-    W_ mp_result1;
-    W_ mp_result2;
+stg_decodeDoublezu2Intzh ( D_ arg )
+{
+    W_ p, tmp;
+    W_ mp_tmp1, mp_tmp2, mp_result1, mp_result2;
+    W_ r1, r2, r3, r4;
+
+    STK_CHK_GEN_N (WDS(4));
 
-    STK_CHK_GEN( WDS(4), NO_PTRS, stg_decodeDoublezu2Intzh );
+    reserve 4 = tmp {
 
-    mp_tmp1    = Sp - WDS(1);
-    mp_tmp2    = Sp - WDS(2);
-    mp_result1 = Sp - WDS(3);
-    mp_result2 = Sp - WDS(4);
+        mp_tmp1    = tmp + WDS(3);
+        mp_tmp2    = tmp + WDS(2);
+        mp_result1 = tmp + WDS(1);
+        mp_result2 = tmp;
 
-    /* arguments: D1 = Double# */
-    arg = D1;
+        /* Perform the operation */
+        ccall __decodeDouble_2Int(mp_tmp1 "ptr", mp_tmp2 "ptr",
+                                  mp_result1 "ptr", mp_result2 "ptr",
+                                  arg);
 
-    /* Perform the operation */
-    foreign "C" __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];
+    }
 
     /* returns:
        (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
-    RET_NNNN(W_[mp_tmp1], W_[mp_tmp2], W_[mp_result1], W_[mp_result2]);
+    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
+stg_forkzh ( gcptr closure )
 {
-  /* args: R1 = closure to spark */
+    MAYBE_GC_P(stg_forkzh, closure);
 
-  MAYBE_GC(R1_PTR, stg_forkzh);
+    gcptr threadid;
 
-  W_ closure;
-  W_ threadid;
-  closure = R1;
+    ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr",
+                                  RtsFlags_GcFlags_initialStkSize(RtsFlags),
+                                  closure "ptr");
 
-  ("ptr" threadid) = foreign "C" 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");
 
-  foreign "C" 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;
-  
-  RET_P(threadid);
+    return (threadid);
 }
 
-stg_forkOnzh
+stg_forkOnzh ( W_ cpu, gcptr closure )
 {
-  /* args: R1 = cpu, R2 = closure to spark */
+again: MAYBE_GC(again);
 
-  MAYBE_GC(R2_PTR, stg_forkOnzh);
+    gcptr threadid;
 
-  W_ cpu;
-  W_ closure;
-  W_ threadid;
-  cpu = R1;
-  closure = R2;
+    ("ptr" threadid) = ccall createIOThread(
+        MyCapability() "ptr",
+        RtsFlags_GcFlags_initialStkSize(RtsFlags),
+        closure "ptr");
 
-  ("ptr" threadid) = foreign "C" 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");
 
-  foreign "C" 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;
-  
-  RET_P(threadid);
+    return (threadid);
 }
 
-stg_yieldzh
+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
+stg_myThreadIdzh ()
 {
-  /* no args. */
-  RET_P(CurrentTSO);
+    return (CurrentTSO);
 }
 
-stg_labelThreadzh
+stg_labelThreadzh ( gcptr threadid, W_ addr )
 {
-  /* args: 
-       R1 = ThreadId#
-       R2 = Addr# */
 #if defined(DEBUG) || defined(TRACING) || defined(DTRACE)
-  foreign "C" labelThread(MyCapability() "ptr", R1 "ptr", R2 "ptr") [];
+    ccall labelThread(MyCapability() "ptr", threadid "ptr", addr "ptr");
 #endif
-  jump %ENTRY_CODE(Sp(0));
+    return ();
 }
 
-stg_isCurrentThreadBoundzh
+stg_isCurrentThreadBoundzh (/* no args */)
 {
-  /* no args */
-  W_ r;
-  (r) = foreign "C" isThreadBound(CurrentTSO) [];
-  RET_N(r);
+    W_ r;
+    (r) = ccall isThreadBound(CurrentTSO);
+    return (r);
 }
 
-stg_threadStatuszh
+stg_threadStatuszh ( gcptr tso )
 {
-    /* args: R1 :: ThreadId# */
-    W_ tso;
     W_ why_blocked;
     W_ what_next;
     W_ ret, cap, locked;
 
-    tso = R1;
-
     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
@@ -733,214 +959,254 @@ stg_threadStatuszh
         locked = 0;
     }
 
-    RET_NNN(ret,cap,locked);
+    return (ret,cap,locked);
 }
 
 /* -----------------------------------------------------------------------------
  * TVar primitives
  * -------------------------------------------------------------------------- */
 
-#define SP_OFF 0
+// Catch retry frame -----------------------------------------------------------
+
+#define CATCH_RETRY_FRAME_FIELDS(w_,p_,info_ptr,        \
+                                 p1, p2,                \
+                                 running_alt_code,      \
+                                 first_code,            \
+                                 alt_code)              \
+  w_ info_ptr,                                          \
+  PROF_HDR_FIELDS(w_,p1,p2)                             \
+  w_ running_alt_code,                                  \
+  p_ first_code,                                        \
+  p_ alt_code
 
-// Catch retry frame ------------------------------------------------------------
 
 INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
-#if defined(PROFILING)
-  W_ unused1, W_ unused2,
-#endif
-  W_ unused3, P_ unused4, P_ unused5)
-{
-   W_ r, frame, trec, outer;
-
-   frame = Sp;
-   trec = StgTSO_trec(CurrentTSO);
-   outer  = StgTRecHeader_enclosing_trec(trec);
-   (r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
-   if (r != 0) {
-     /* Succeeded (either first branch or second branch) */
-     StgTSO_trec(CurrentTSO) = outer;
-     Sp = Sp + SIZEOF_StgCatchRetryFrame;
-     jump %ENTRY_CODE(Sp(SP_OFF));
-   } else {
-     /* Did not commit: re-execute */
-     W_ new_trec;
-     ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
-     StgTSO_trec(CurrentTSO) = new_trec;
-     if (StgCatchRetryFrame_running_alt_code(frame) != 0::I32) {
-       R1 = StgCatchRetryFrame_alt_code(frame);
-     } else {
-       R1 = StgCatchRetryFrame_first_code(frame);
-     }
-     jump stg_ap_v_fast;
-   }
-}
+               CATCH_RETRY_FRAME_FIELDS(W_,P_,
+                                        info_ptr, p1, p2,
+                                        running_alt_code,
+                                        first_code,
+                                        alt_code))
+    return (P_ ret)
+{
+    W_ r;
+    gcptr trec, outer, arg;
 
+    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
+                (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
+                                          running_alt_code,
+                                          first_code,
+                                          alt_code))
+                (alt_code);
+        } else {
+            jump stg_ap_v_fast
+                (CATCH_RETRY_FRAME_FIELDS(,,info_ptr, p1, p2,
+                                          running_alt_code,
+                                          first_code,
+                                          alt_code))
+                (first_code);
+        }
+    }
+}
 
 // Atomically 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
+
+
 INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
-#if defined(PROFILING)
-  W_ unused1, W_ unused2,
-#endif
-  P_ code, P_ next_invariant_to_check, P_ result)
-{
-  W_ frame, trec, valid, next_invariant, q, outer;
-
-  frame  = Sp;
-  trec   = StgTSO_trec(CurrentTSO);
-  result = R1;
-  outer  = StgTRecHeader_enclosing_trec(trec);
-
-  if (outer == NO_TREC) {
-    /* First time back at the atomically frame -- pick up invariants */
-    ("ptr" q) = foreign "C" stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr") [];
-    StgAtomicallyFrame_next_invariant_to_check(frame) = q;
-    StgAtomicallyFrame_result(frame) = 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;
-    q = StgAtomicallyFrame_next_invariant_to_check(frame);
-    StgInvariantCheckQueue_my_execution(q) = trec;
-    foreign "C" 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. */
-    q = StgInvariantCheckQueue_next_queue_entry(q);
-    StgAtomicallyFrame_next_invariant_to_check(frame) = q;
-    trec = outer;
-  }
-
-  q = StgAtomicallyFrame_next_invariant_to_check(frame);
-
-  if (q != END_INVARIANT_CHECK_QUEUE) {
-    /* We can't commit yet: another invariant to check */
-    ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [];
-    StgTSO_trec(CurrentTSO) = trec;
-
-    next_invariant = StgInvariantCheckQueue_invariant(q);
-    R1 = StgAtomicInvariant_code(next_invariant);
-    jump stg_ap_v_fast;
-
-  } else {
-
-    /* We've got no more invariants to check, try to commit */
-    (valid) = foreign "C" stmCommitTransaction(MyCapability() "ptr", trec "ptr") [];
-    if (valid != 0) {
-      /* Transaction was valid: commit succeeded */
-      StgTSO_trec(CurrentTSO) = NO_TREC;
-      R1 = StgAtomicallyFrame_result(frame);
-      Sp = Sp + SIZEOF_StgAtomicallyFrame;
-      jump %ENTRY_CODE(Sp(SP_OFF));
+               // layout of the frame, and bind the field names
+               ATOMICALLY_FRAME_FIELDS(W_,P_,
+                                       info_ptr, p1, p2,
+                                       code,
+                                       next_invariant,
+                                       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 {
-      /* Transaction was not valid: try again */
-      ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
-      StgTSO_trec(CurrentTSO) = trec;
-      StgAtomicallyFrame_next_invariant_to_check(frame) = END_INVARIANT_CHECK_QUEUE;
-      R1 = StgAtomicallyFrame_code(frame);
-      jump stg_ap_v_fast;
+        /* 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));
+
+    } 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);
+        }
     }
-  }
 }
 
+
 INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME,
-#if defined(PROFILING)
-  W_ unused1, W_ unused2,
-#endif
-  P_ code, P_ next_invariant_to_check, P_ result)
+               // layout of the frame, and bind the field names
+               ATOMICALLY_FRAME_FIELDS(W_,P_,
+                                       info_ptr, p1, p2,
+                                       code,
+                                       next_invariant,
+                                       frame_result))
+    return (/* no return values */)
 {
-  W_ frame, trec, valid;
-
-  frame = Sp;
+    W_ trec, valid;
 
-  /* The TSO is currently waiting: should we stop waiting? */
-  (valid) = foreign "C" stmReWait(MyCapability() "ptr", CurrentTSO "ptr") [];
-  if (valid != 0) {
-    /* Previous attempt is still valid: no point trying again yet */
-    jump stg_block_noregs;
-  } else {
-    /* Previous attempt is no longer valid: try again */
-    ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
-    StgTSO_trec(CurrentTSO) = trec;
-    StgHeader_info(frame) = stg_atomically_frame_info;
-    R1 = StgAtomicallyFrame_code(frame);
-    jump stg_ap_v_fast;
-  }
+    /* 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 --------------------------------------------------------------
-
-#define SP_OFF 0
+// STM catch frame -------------------------------------------------------------
 
 /* Catch frames are very similar to update frames, but when entering
  * one we just pop the frame off the stack and perform the correct
  * kind of return to the activation record underneath us on the stack.
  */
 
+#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
+
 INFO_TABLE_RET(stg_catch_stm_frame, CATCH_STM_FRAME,
-#if defined(PROFILING)
-  W_ unused1, W_ unused2,
-#endif
-  P_ unused3, P_ unused4)
-   {
-      W_ r, frame, trec, outer;
-      frame = Sp;
-      trec = StgTSO_trec(CurrentTSO);
-      outer  = StgTRecHeader_enclosing_trec(trec);
-      (r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
-      if (r != 0) {
+               // layout of the frame, and bind the field names
+               CATCH_STM_FRAME_FIELDS(W_,P_,info_ptr,p1,p2,code,handler))
+    return (P_ ret)
+{
+    W_ r, trec, outer;
+
+    trec = StgTSO_trec(CurrentTSO);
+    outer  = StgTRecHeader_enclosing_trec(trec);
+    (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
+    if (r != 0) {
         /* Commit succeeded */
         StgTSO_trec(CurrentTSO) = outer;
-        Sp = Sp + SIZEOF_StgCatchSTMFrame;
-        jump %ENTRY_CODE(Sp(SP_OFF));
-      } else {
+        return (ret);
+    } else {
         /* Commit failed */
         W_ new_trec;
-        ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
+        ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
         StgTSO_trec(CurrentTSO) = new_trec;
-        R1 = StgCatchSTMFrame_code(frame);
-        jump stg_ap_v_fast;
-      }
-   }
 
+        jump stg_ap_v_fast
+            (CATCH_STM_FRAME_FIELDS(,,info_ptr,p1,p2,code,handler))
+            (code);
+    }
+}
 
-// Primop definition ------------------------------------------------------------
 
-stg_atomicallyzh
+// Primop definition -----------------------------------------------------------
+
+stg_atomicallyzh (P_ stm)
 {
-  W_ frame;
-  W_ old_trec;
-  W_ new_trec;
-  
-  // stmStartTransaction may allocate
-  MAYBE_GC (R1_PTR, stg_atomicallyzh); 
+    P_ old_trec;
+    P_ new_trec;
+    P_ code, next_invariant, frame_result;
 
-  /* Args: R1 = m :: STM a */
-  STK_CHK_GEN(SIZEOF_StgAtomicallyFrame + WDS(1), R1_PTR, stg_atomicallyzh);
+    // stmStartTransaction may allocate
+    MAYBE_GC_P(stg_atomicallyzh, stm);
 
-  old_trec = StgTSO_trec(CurrentTSO);
+    STK_CHK_GEN();
 
-  /* Nested transactions are not allowed; raise an exception */
-  if (old_trec != NO_TREC) {
-     R1 = base_ControlziExceptionziBase_nestedAtomically_closure;
-     jump stg_raisezh;
-  }
+    old_trec = StgTSO_trec(CurrentTSO);
 
-  /* Set up the atomically frame */
-  Sp = Sp - SIZEOF_StgAtomicallyFrame;
-  frame = Sp;
+    /* Nested transactions are not allowed; raise an exception */
+    if (old_trec != NO_TREC) {
+        jump stg_raisezh(base_ControlziExceptionziBase_nestedAtomically_closure);
+    }
 
-  SET_HDR(frame,stg_atomically_frame_info, CCCS);
-  StgAtomicallyFrame_code(frame) = R1;
-  StgAtomicallyFrame_result(frame) = NO_TREC;
-  StgAtomicallyFrame_next_invariant_to_check(frame) = END_INVARIANT_CHECK_QUEUE;
+    code = stm;
+    next_invariant = END_INVARIANT_CHECK_QUEUE;
+    frame_result = NO_TREC;
 
-  /* Start the memory transcation */
-  ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", old_trec "ptr") [R1];
-  StgTSO_trec(CurrentTSO) = new_trec;
+    /* Start the memory transcation */
+    ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr", old_trec "ptr");
+    StgTSO_trec(CurrentTSO) = new_trec;
 
-  /* Apply R1 to the realworld token */
-  jump stg_ap_v_fast;
+    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
@@ -948,220 +1214,198 @@ stg_atomicallyzh
 // It is somewhat similar to the stg_raise closure.
 //
 INFO_TABLE(stg_atomically,1,0,THUNK_1_0,"atomically","atomically")
+    (P_ thunk)
 {
-  R1 = StgThunk_payload(R1,0);
-  jump stg_atomicallyzh;
+    jump stg_atomicallyzh(StgThunk_payload(thunk,0));
 }
 
 
-stg_catchSTMzh
+stg_catchSTMzh (P_ code    /* :: STM a */,
+                P_ handler /* :: Exception -> STM a */)
 {
-  W_ frame;
-  
-  /* Args: R1 :: STM a */
-  /* Args: R2 :: Exception -> STM a */
-  STK_CHK_GEN(SIZEOF_StgCatchSTMFrame + WDS(1), R1_PTR & R2_PTR, stg_catchSTMzh);
-
-  /* Set up the catch frame */
-  Sp = Sp - SIZEOF_StgCatchSTMFrame;
-  frame = Sp;
-
-  SET_HDR(frame, stg_catch_stm_frame_info, CCCS);
-  StgCatchSTMFrame_handler(frame) = R2;
-  StgCatchSTMFrame_code(frame) = R1;
-
-  /* Start a nested transaction to run the body of the try block in */
-  W_ cur_trec;  
-  W_ new_trec;
-  cur_trec = StgTSO_trec(CurrentTSO);
-  ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", cur_trec "ptr");
-  StgTSO_trec(CurrentTSO) = new_trec;
-
-  /* Apply R1 to the realworld token */
-  jump stg_ap_v_fast;
+    STK_CHK_GEN();
+
+    /* Start a nested transaction to run the body of the try block in */
+    W_ cur_trec;
+    W_ new_trec;
+    cur_trec = StgTSO_trec(CurrentTSO);
+    ("ptr" new_trec) = ccall stmStartTransaction(MyCapability() "ptr",
+                                                 cur_trec "ptr");
+    StgTSO_trec(CurrentTSO) = new_trec;
+
+    jump stg_ap_v_fast
+        (CATCH_STM_FRAME_FIELDS(,,stg_catch_stm_frame_info, CCCS, 0,
+                                code, handler))
+        (code);
 }
 
 
-stg_catchRetryzh
+stg_catchRetryzh (P_ first_code, /* :: STM a */
+                  P_ alt_code    /* :: STM a */)
 {
-  W_ frame;
-  W_ new_trec;
-  W_ trec;
-
-  // stmStartTransaction may allocate
-  MAYBE_GC (R1_PTR & R2_PTR, stg_catchRetryzh); 
+    W_ new_trec;
 
-  /* Args: R1 :: STM a */
-  /* Args: R2 :: STM a */
-  STK_CHK_GEN(SIZEOF_StgCatchRetryFrame + WDS(1), R1_PTR & R2_PTR, stg_catchRetryzh);
+    // stmStartTransaction may allocate
+    MAYBE_GC_PP (stg_catchRetryzh, first_code, alt_code);
 
-  /* Start a nested transaction within which to run the first code */
-  trec = StgTSO_trec(CurrentTSO);
-  ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [R1,R2];
-  StgTSO_trec(CurrentTSO) = new_trec;
+    STK_CHK_GEN();
 
-  /* Set up the catch-retry frame */
-  Sp = Sp - SIZEOF_StgCatchRetryFrame;
-  frame = Sp;
-  
-  SET_HDR(frame, stg_catch_retry_frame_info, CCCS);
-  StgCatchRetryFrame_running_alt_code(frame) = 0 :: CInt; // false;
-  StgCatchRetryFrame_first_code(frame) = R1;
-  StgCatchRetryFrame_alt_code(frame) = R2;
+    /* 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;
 
-  /* Apply R1 to the realworld token */
-  jump stg_ap_v_fast;
+    // 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
+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;
 
-  MAYBE_GC (NO_PTRS, stg_retryzh); // STM operations may allocate
+    // 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) = foreign "C" 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
-    foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
-    foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
-    if (!StgCatchRetryFrame_running_alt_code(frame) != 0::I32) {
-      // Retry in the first branch: try the alternative
-      ("ptr" trec) = foreign "C" 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;
-    } 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)
-    foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
-    foreign "C" 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) = foreign "C" 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;
-    // Fix up the stack in the unregisterised case: the return convention is different.
-    R3 = trec; // passing to stmWaitUnblock()
-    jump stg_block_stmwait;
-  } else {
-    // Transaction was not valid: retry immediately
-    ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
-    StgTSO_trec(CurrentTSO) = trec;
-    R1 = StgAtomicallyFrame_code(frame);
-    Sp = frame;
-    jump stg_ap_v_fast;
-  }
-}
+    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
+stg_checkzh (P_ closure /* STM a */)
 {
-  W_ trec, closure;
+    W_ trec;
 
-  /* Args: R1 = invariant closure */
-  MAYBE_GC (R1_PTR, stg_checkzh); 
+    MAYBE_GC_P (stg_checkzh, closure);
 
-  trec = StgTSO_trec(CurrentTSO);
-  closure = R1;
-  foreign "C" stmAddInvariantToCheck(MyCapability() "ptr", 
-                                     trec "ptr",
-                                     closure "ptr") [];
-
-  jump %ENTRY_CODE(Sp(0));
+    trec = StgTSO_trec(CurrentTSO);
+    ccall stmAddInvariantToCheck(MyCapability() "ptr",
+                                 trec "ptr",
+                                 closure "ptr");
+    return ();
 }
 
 
-stg_newTVarzh
+stg_newTVarzh (P_ init)
 {
-  W_ tv;
-  W_ new_value;
+    W_ tv;
+
+    ALLOC_PRIM_P (SIZEOF_StgTVar, stg_newTVarzh, init);
 
-  /* Args: R1 = initialisation value */
+    tv = Hp - SIZEOF_StgTVar + WDS(1);
+    SET_HDR (tv, stg_TVAR_DIRTY_info, CCCS);
 
-  MAYBE_GC (R1_PTR, stg_newTVarzh); 
-  new_value = R1;
-  ("ptr" tv) = foreign "C" stmNewTVar(MyCapability() "ptr", new_value "ptr") [];
-  RET_P(tv);
+    StgTVar_current_value(tv) = init;
+    StgTVar_first_watch_queue_entry(tv) = stg_END_STM_WATCH_QUEUE_closure;
+    StgTVar_num_updates(tv) = 0;
+
+    return (tv);
 }
 
 
-stg_readTVarzh
+stg_readTVarzh (P_ tvar)
 {
-  W_ trec;
-  W_ tvar;
-  W_ result;
-
-  /* Args: R1 = TVar closure */
+    P_ trec;
+    P_ result;
 
-  MAYBE_GC (R1_PTR, stg_readTVarzh); // Call to stmReadTVar may allocate
-  trec = StgTSO_trec(CurrentTSO);
-  tvar = R1;
-  ("ptr" result) = foreign "C" stmReadTVar(MyCapability() "ptr", trec "ptr", tvar "ptr") [];
+    // Call to stmReadTVar may allocate
+    MAYBE_GC_P (stg_readTVarzh, tvar);
 
-  RET_P(result);
+    trec = StgTSO_trec(CurrentTSO);
+    ("ptr" result) = ccall stmReadTVar(MyCapability() "ptr", trec "ptr",
+                                       tvar "ptr");
+    return (result);
 }
 
-stg_readTVarIOzh
+stg_readTVarIOzh ( P_ tvar /* :: TVar a */ )
 {
     W_ result;
 
 again:
-    result = StgTVar_current_value(R1);
+    result = StgTVar_current_value(tvar);
     if (%INFO_PTR(result) == stg_TREC_HEADER_info) {
         goto again;
     }
-    RET_P(result);
+    return (result);
 }
 
-stg_writeTVarzh
+stg_writeTVarzh (P_ tvar,     /* :: TVar a */
+                 P_ new_value /* :: a      */)
 {
-  W_ trec;
-  W_ tvar;
-  W_ new_value;
-  
-  /* Args: R1 = TVar closure */
-  /*       R2 = New value    */
+    W_ trec;
 
-  MAYBE_GC (R1_PTR & R2_PTR, stg_writeTVarzh); // Call to stmWriteTVar may allocate
-  trec = StgTSO_trec(CurrentTSO);
-  tvar = R1;
-  new_value = R2;
-  foreign "C" stmWriteTVar(MyCapability() "ptr", trec "ptr", tvar "ptr", new_value "ptr") [];
+    // Call to stmWriteTVar may allocate
+    MAYBE_GC_PP (stg_writeTVarzh, tvar, new_value);
 
-  jump %ENTRY_CODE(Sp(0));
+    trec = StgTSO_trec(CurrentTSO);
+    ccall stmWriteTVar(MyCapability() "ptr", trec "ptr", tvar "ptr",
+                       new_value "ptr");
+    return ();
 }
 
 
@@ -1197,31 +1441,28 @@ stg_writeTVarzh
  *
  * -------------------------------------------------------------------------- */
 
-stg_isEmptyMVarzh
+stg_isEmptyMVarzh ( P_ mvar /* :: MVar a */ )
 {
-    /* args: R1 = MVar closure */
-
-    if (StgMVar_value(R1) == stg_END_TSO_QUEUE_closure) {
-       RET_N(1);
+    if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
+        return (1);
     } else {
-       RET_N(0);
+        return (0);
     }
 }
 
-stg_newMVarzh
+stg_newMVarzh ()
 {
-    /* args: none */
     W_ mvar;
 
-    ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, stg_newMVarzh );
-  
+    ALLOC_PRIM_ (SIZEOF_StgMVar, stg_newMVarzh);
+
     mvar = Hp - SIZEOF_StgMVar + WDS(1);
     SET_HDR(mvar,stg_MVAR_DIRTY_info,CCCS);
         // MVARs start dirty: generation 0 has no mutable list
     StgMVar_head(mvar)  = stg_END_TSO_QUEUE_closure;
     StgMVar_tail(mvar)  = stg_END_TSO_QUEUE_closure;
     StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
-    RET_P(mvar);
+    return (mvar);
 }
 
 
@@ -1229,7 +1470,7 @@ stg_newMVarzh
     W_ sp;                                      \
     sp = StgStack_sp(stack);                    \
     W_[sp + WDS(1)] = value;                    \
-    W_[sp + WDS(0)] = stg_gc_unpt_r1_info;
+    W_[sp + WDS(0)] = stg_ret_p_info;
 
 #define PerformPut(stack,lval)                  \
     W_ sp;                                      \
@@ -1237,38 +1478,28 @@ stg_newMVarzh
     StgStack_sp(stack) = sp;                    \
     lval = W_[sp - WDS(1)];
 
-stg_takeMVarzh
-{
-    W_ mvar, val, info, tso, q;
 
-    /* args: R1 = MVar closure */
-    mvar = R1;
+stg_takeMVarzh ( P_ mvar /* :: MVar a */ )
+{
+    W_ val, info, tso, q;
 
-#if defined(THREADED_RTS)
-    ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
-#else
-    info = GET_INFO(mvar);
-#endif
-        
-    if (info == stg_MVAR_CLEAN_info) {
-        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr") [];
-    }
+    LOCK_CLOSURE(mvar, info);
 
     /* If the MVar is empty, put ourselves on its blocking queue,
      * and wait until we're woken up.
      */
     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
-        
-        // Note [mvar-heap-check] We want to do the heap check in the
-        // branch here, to avoid the conditional in the common case.
-        // However, we've already locked the MVar above, so we better
-        // be careful to unlock it again if the the heap check fails.
-        // Unfortunately we don't have an easy way to inject any code
-        // into the heap check generated by the code generator, so we
-        // have to do it in stg_gc_gen (see HeapStackCheck.cmm).
-        HP_CHK_GEN_TICKY(SIZEOF_StgMVarTSOQueue, R1_PTR, stg_takeMVarzh);
-        TICK_ALLOC_PRIM(SIZEOF_StgMVarTSOQueue, 0, 0);
-        CCCS_ALLOC(SIZEOF_StgMVarTSOQueue);
+        if (info == stg_MVAR_CLEAN_info) {
+            ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
+        }
+
+        // We want to put the heap check down here in the slow path,
+        // but be careful to unlock the closure before returning to
+        // the RTS if the check fails.
+        ALLOC_PRIM_WITH_CUSTOM_FAILURE
+            (SIZEOF_StgMVarTSOQueue,
+             unlockClosure(mvar, stg_MVAR_DIRTY_info);
+             GC_PRIM_P(stg_takeMVarzh, mvar));
 
         q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
 
@@ -1276,41 +1507,46 @@ stg_takeMVarzh
         StgMVarTSOQueue_link(q) = END_TSO_QUEUE;
         StgMVarTSOQueue_tso(q)  = CurrentTSO;
 
-       if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-           StgMVar_head(mvar) = q;
-       } else {
+        if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+            StgMVar_head(mvar) = q;
+        } else {
             StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
-            foreign "C" recordClosureMutated(MyCapability() "ptr",
-                                             StgMVar_tail(mvar)) [];
-       }
-       StgTSO__link(CurrentTSO)       = q;
-       StgTSO_block_info(CurrentTSO)  = mvar;
-       StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
-       StgMVar_tail(mvar)             = q;
-       
-        R1 = mvar;
-       jump stg_block_takemvar;
-    }
-    
+            ccall recordClosureMutated(MyCapability() "ptr",
+                                             StgMVar_tail(mvar));
+        }
+        StgTSO__link(CurrentTSO)       = q;
+        StgTSO_block_info(CurrentTSO)  = mvar;
+        StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
+        StgMVar_tail(mvar)             = q;
+
+        jump stg_block_takemvar(mvar);
+    }
+
     /* we got the value... */
     val = StgMVar_value(mvar);
-    
+
     q = StgMVar_head(mvar);
 loop:
     if (q == stg_END_TSO_QUEUE_closure) {
         /* No further putMVars, MVar is now empty */
         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
-        unlockClosure(mvar, stg_MVAR_DIRTY_info);
-        RET_P(val);
+        // If the MVar is not already dirty, then we don't need to make
+        // it dirty, as it is empty with nothing blocking on it.
+        unlockClosure(mvar, info);
+        return (val);
     }
     if (StgHeader_info(q) == stg_IND_info ||
         StgHeader_info(q) == stg_MSG_NULL_info) {
         q = StgInd_indirectee(q);
         goto loop;
     }
-    
+
     // There are putMVar(s) waiting... wake up the first thread on the queue
-    
+
+    if (info == stg_MVAR_CLEAN_info) {
+        ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
+    }
+
     tso = StgMVarTSOQueue_tso(q);
     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
@@ -1327,65 +1563,56 @@ loop:
 
     // indicate that the MVar operation has now completed.
     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
-    
+
     // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
 
-    foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
-    
+    ccall tryWakeupThread(MyCapability() "ptr", tso);
+
     unlockClosure(mvar, stg_MVAR_DIRTY_info);
-    RET_P(val);
+    return (val);
 }
 
-
-stg_tryTakeMVarzh
+stg_tryTakeMVarzh ( P_ mvar /* :: MVar a */ )
 {
-    W_ mvar, val, info, tso, q;
+    W_ val, info, tso, q;
 
-    /* args: R1 = MVar closure */
-    mvar = R1;
+    LOCK_CLOSURE(mvar, info);
 
-#if defined(THREADED_RTS)
-    ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
-#else
-    info = GET_INFO(mvar);
-#endif
-        
-    /* If the MVar is empty, put ourselves on its blocking queue,
-     * and wait until we're woken up.
-     */
+    /* If the MVar is empty, return 0. */
     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
 #if defined(THREADED_RTS)
         unlockClosure(mvar, info);
 #endif
-       /* HACK: we need a pointer to pass back, 
-        * so we abuse NO_FINALIZER_closure
-        */
-       RET_NP(0, stg_NO_FINALIZER_closure);
-    }
-    
-    if (info == stg_MVAR_CLEAN_info) {
-        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr") [];
+        /* HACK: we need a pointer to pass back,
+         * so we abuse NO_FINALIZER_closure
+         */
+        return (0, stg_NO_FINALIZER_closure);
     }
 
     /* we got the value... */
     val = StgMVar_value(mvar);
-    
+
     q = StgMVar_head(mvar);
 loop:
     if (q == stg_END_TSO_QUEUE_closure) {
         /* No further putMVars, MVar is now empty */
         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
-        unlockClosure(mvar, stg_MVAR_DIRTY_info);
-        RET_NP(1, val);
+        unlockClosure(mvar, info);
+        return (1, val);
     }
+
     if (StgHeader_info(q) == stg_IND_info ||
         StgHeader_info(q) == stg_MSG_NULL_info) {
         q = StgInd_indirectee(q);
         goto loop;
     }
-    
+
     // There are putMVar(s) waiting... wake up the first thread on the queue
-    
+
+    if (info == stg_MVAR_CLEAN_info) {
+        ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
+    }
+
     tso = StgMVarTSOQueue_tso(q);
     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
@@ -1402,40 +1629,35 @@ loop:
 
     // indicate that the MVar operation has now completed.
     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
-    
+
     // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
 
-    foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
-    
+    ccall tryWakeupThread(MyCapability() "ptr", tso);
+
     unlockClosure(mvar, stg_MVAR_DIRTY_info);
-    RET_NP(1,val);
+    return (1,val);
 }
 
-
-stg_putMVarzh
+stg_putMVarzh ( P_ mvar, /* :: MVar a */
+                P_ val,  /* :: a */ )
 {
-    W_ mvar, val, info, tso, q;
-
-    /* args: R1 = MVar, R2 = value */
-    mvar = R1;
-    val  = R2;
+    W_ info, tso, q;
 
-#if defined(THREADED_RTS)
-    ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
-#else
-    info = GET_INFO(mvar);
-#endif
-
-    if (info == stg_MVAR_CLEAN_info) {
-        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
-    }
+    LOCK_CLOSURE(mvar, info);
 
     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
 
-        // see Note [mvar-heap-check] above
-        HP_CHK_GEN_TICKY(SIZEOF_StgMVarTSOQueue, R1_PTR & R2_PTR, stg_putMVarzh);
-        TICK_ALLOC_PRIM(SIZEOF_StgMVarTSOQueue, 0, 0);
-        CCCS_ALLOC(SIZEOF_StgMVarTSOQueue);
+        if (info == stg_MVAR_CLEAN_info) {
+            ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
+        }
+
+        // We want to put the heap check down here in the slow path,
+        // but be careful to unlock the closure before returning to
+        // the RTS if the check fails.
+        ALLOC_PRIM_WITH_CUSTOM_FAILURE
+            (SIZEOF_StgMVarTSOQueue,
+             unlockClosure(mvar, stg_MVAR_DIRTY_info);
+             GC_PRIM_PP(stg_putMVarzh, mvar, val));
 
         q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
 
@@ -1443,30 +1665,31 @@ stg_putMVarzh
         StgMVarTSOQueue_link(q) = END_TSO_QUEUE;
         StgMVarTSOQueue_tso(q)  = CurrentTSO;
 
-       if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
-           StgMVar_head(mvar) = q;
-       } else {
+        if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
+            StgMVar_head(mvar) = q;
+        } else {
             StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
-            foreign "C" recordClosureMutated(MyCapability() "ptr",
-                                             StgMVar_tail(mvar)) [];
-       }
-       StgTSO__link(CurrentTSO)       = q;
-       StgTSO_block_info(CurrentTSO)  = mvar;
-       StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
-       StgMVar_tail(mvar)             = q;
-
-        R1 = mvar;
-        R2 = val;
-       jump stg_block_putmvar;
-    }
-  
+            ccall recordClosureMutated(MyCapability() "ptr",
+                                             StgMVar_tail(mvar));
+        }
+        StgTSO__link(CurrentTSO)       = q;
+        StgTSO_block_info(CurrentTSO)  = mvar;
+        StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
+        StgMVar_tail(mvar)             = q;
+
+        jump stg_block_putmvar(mvar,val);
+    }
+
     q = StgMVar_head(mvar);
 loop:
     if (q == stg_END_TSO_QUEUE_closure) {
-       /* No further takes, the MVar is now full. */
-       StgMVar_value(mvar) = val;
-       unlockClosure(mvar, stg_MVAR_DIRTY_info);
-       jump %ENTRY_CODE(Sp(0));
+        /* No further takes, the MVar is now full. */
+        if (info == stg_MVAR_CLEAN_info) {
+            ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
+        }
+        StgMVar_value(mvar) = val;
+        unlockClosure(mvar, stg_MVAR_DIRTY_info);
+        return ();
     }
     if (StgHeader_info(q) == stg_IND_info ||
         StgHeader_info(q) == stg_MSG_NULL_info) {
@@ -1474,16 +1697,19 @@ loop:
         goto loop;
     }
 
-    // There are takeMVar(s) waiting: wake up the first one
-    
+    // There are readMVar/takeMVar(s) waiting: wake up the first one
+
     tso = StgMVarTSOQueue_tso(q);
     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
     }
 
-    ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
     ASSERT(StgTSO_block_info(tso) == mvar);
+    // save why_blocked here, because waking up the thread destroys
+    // this information
+    W_ why_blocked;
+    why_blocked = TO_W_(StgTSO_why_blocked(tso));
 
     // actually perform the takeMVar
     W_ stack;
@@ -1494,48 +1720,57 @@ loop:
     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
 
     if (TO_W_(StgStack_dirty(stack)) == 0) {
-        foreign "C" dirty_STACK(MyCapability() "ptr", stack "ptr") [];
+        ccall dirty_STACK(MyCapability() "ptr", stack "ptr");
     }
-    
-    foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
 
-    unlockClosure(mvar, stg_MVAR_DIRTY_info);
-    jump %ENTRY_CODE(Sp(0));
+    ccall tryWakeupThread(MyCapability() "ptr", tso);
+
+    // If it was an readMVar, then we can still do work,
+    // so loop back. (XXX: This could take a while)
+    if (why_blocked == BlockedOnMVarRead) {
+        q = StgMVarTSOQueue_link(q);
+        goto loop;
+    }
+
+    ASSERT(why_blocked == BlockedOnMVar);
+
+    unlockClosure(mvar, info);
+    return ();
 }
 
 
-stg_tryPutMVarzh
+// 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 */ )
 {
-    W_ mvar, val, info, tso, q;
+    W_ info, tso, q;
 
-    /* args: R1 = MVar, R2 = value */
-    mvar = R1;
-    val  = R2;
-
-#if defined(THREADED_RTS)
-    ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
-#else
-    info = GET_INFO(mvar);
-#endif
+    LOCK_CLOSURE(mvar, info);
 
     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
 #if defined(THREADED_RTS)
-       unlockClosure(mvar, info);
+        unlockClosure(mvar, info);
 #endif
-       RET_N(0);
-    }
-  
-    if (info == stg_MVAR_CLEAN_info) {
-        foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
+        return (0);
     }
 
     q = StgMVar_head(mvar);
 loop:
     if (q == stg_END_TSO_QUEUE_closure) {
-       /* No further takes, the MVar is now full. */
-       StgMVar_value(mvar) = val;
-       unlockClosure(mvar, stg_MVAR_DIRTY_info);
-        RET_N(1);
+        /* No further takes, the MVar is now full. */
+        if (info == stg_MVAR_CLEAN_info) {
+            ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
+        }
+
+        StgMVar_value(mvar) = val;
+        unlockClosure(mvar, stg_MVAR_DIRTY_info);
+        return (1);
     }
     if (StgHeader_info(q) == stg_IND_info ||
         StgHeader_info(q) == stg_MSG_NULL_info) {
@@ -1544,15 +1779,18 @@ loop:
     }
 
     // There are takeMVar(s) waiting: wake up the first one
-    
+
     tso = StgMVarTSOQueue_tso(q);
     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
     }
 
-    ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
     ASSERT(StgTSO_block_info(tso) == mvar);
+    // save why_blocked here, because waking up the thread destroys
+    // this information
+    W_ why_blocked;
+    why_blocked = TO_W_(StgTSO_why_blocked(tso));
 
     // actually perform the takeMVar
     W_ stack;
@@ -1561,140 +1799,328 @@ loop:
 
     // indicate that the MVar operation has now completed.
     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
-    
+
     if (TO_W_(StgStack_dirty(stack)) == 0) {
-        foreign "C" dirty_STACK(MyCapability() "ptr", stack "ptr") [];
+        ccall dirty_STACK(MyCapability() "ptr", stack "ptr");
     }
-    
-    foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
 
-    unlockClosure(mvar, stg_MVAR_DIRTY_info);
-    RET_N(1);
+    ccall tryWakeupThread(MyCapability() "ptr", tso);
+
+    // If it was an readMVar, then we can still do work,
+    // so loop back. (XXX: This could take a while)
+    if (why_blocked == BlockedOnMVarRead) {
+        q = StgMVarTSOQueue_link(q);
+        goto loop;
+    }
+
+    ASSERT(why_blocked == BlockedOnMVar);
+
+    unlockClosure(mvar, info);
+    return (1);
+}
+
+
+stg_readMVarzh ( P_ mvar, /* :: MVar a */ )
+{
+    W_ val, info, tso, q;
+
+    LOCK_CLOSURE(mvar, info);
+
+    /* If the MVar is empty, put ourselves on the blocked readers
+     * list and wait until we're woken up.
+     */
+    if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
+
+        if (info == stg_MVAR_CLEAN_info) {
+            ccall dirty_MVAR(BaseReg "ptr", mvar "ptr");
+        }
+
+        ALLOC_PRIM_WITH_CUSTOM_FAILURE
+            (SIZEOF_StgMVarTSOQueue,
+             unlockClosure(mvar, stg_MVAR_DIRTY_info);
+             GC_PRIM_P(stg_readMVarzh, mvar));
+
+        q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
+
+        // readMVars are pushed to the front of the queue, so
+        // they get handled immediately
+        SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
+        StgMVarTSOQueue_link(q) = StgMVar_head(mvar);
+        StgMVarTSOQueue_tso(q)  = CurrentTSO;
+
+        StgTSO__link(CurrentTSO)       = q;
+        StgTSO_block_info(CurrentTSO)  = mvar;
+        StgTSO_why_blocked(CurrentTSO) = BlockedOnMVarRead::I16;
+        StgMVar_head(mvar) = q;
+
+        if (StgMVar_tail(mvar) == stg_END_TSO_QUEUE_closure) {
+            StgMVar_tail(mvar) = q;
+        }
+
+        jump stg_block_readmvar(mvar);
+    }
+
+    val = StgMVar_value(mvar);
+
+    unlockClosure(mvar, info);
+    return (val);
 }
 
+stg_tryReadMVarzh ( P_ mvar, /* :: MVar a */ )
+{
+    W_ val, info, tso, q;
+
+    LOCK_CLOSURE(mvar, info);
+
+    if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
+        unlockClosure(mvar, info);
+        return (0, stg_NO_FINALIZER_closure);
+    }
+
+    val = StgMVar_value(mvar);
+
+    unlockClosure(mvar, info);
+    return (1, val);
+}
 
 /* -----------------------------------------------------------------------------
    Stable pointer primitives
    -------------------------------------------------------------------------  */
 
-stg_makeStableNamezh
+stg_makeStableNamezh ( P_ obj )
 {
     W_ index, sn_obj;
 
-    ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, stg_makeStableNamezh );
-  
-    (index) = foreign "C" lookupStableName(R1 "ptr") [];
+    (index) = ccall lookupStableName(obj "ptr");
 
     /* Is there already a StableName for this heap object?
-     *  stable_ptr_table is a pointer to an array of snEntry structs.
+     *  stable_name_table is a pointer to an array of snEntry structs.
      */
-    if ( snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) == NULL ) {
-       sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
-       SET_HDR(sn_obj, stg_STABLE_NAME_info, CCCS);
-       StgStableName_sn(sn_obj) = index;
-       snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) = sn_obj;
+    if ( snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry) == NULL ) {
+        ALLOC_PRIM (SIZEOF_StgStableName);
+        sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
+        SET_HDR(sn_obj, stg_STABLE_NAME_info, CCCS);
+        StgStableName_sn(sn_obj) = index;
+        snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry) = sn_obj;
     } else {
-       sn_obj = snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry);
+        sn_obj = snEntry_sn_obj(W_[stable_name_table] + index*SIZEOF_snEntry);
     }
-    
-    RET_P(sn_obj);
-}
 
+    return (sn_obj);
+}
 
-stg_makeStablePtrzh
+stg_makeStablePtrzh ( P_ obj )
 {
-    /* Args: R1 = a */
     W_ sp;
-    MAYBE_GC(R1_PTR, stg_makeStablePtrzh);
-    ("ptr" sp) = foreign "C" getStablePtr(R1 "ptr") [];
-    RET_N(sp);
+
+    ("ptr" sp) = ccall getStablePtr(obj "ptr");
+    return (sp);
 }
 
-stg_deRefStablePtrzh
+stg_deRefStablePtrzh ( P_ sp )
 {
-    /* Args: R1 = the stable ptr */
-    W_ r, sp;
-    sp = R1;
-    r = snEntry_addr(W_[stable_ptr_table] + sp*SIZEOF_snEntry);
-    RET_P(r);
+    W_ r;
+    r = spEntry_addr(W_[stable_ptr_table] + sp*SIZEOF_spEntry);
+    return (r);
 }
 
 /* -----------------------------------------------------------------------------
-   Bytecode object primitives
+   CompactNFData primitives
+
+   See Note [Compact Normal Forms]
    -------------------------------------------------------------------------  */
 
-stg_newBCOzh
+stg_compactNewzh ( W_ size )
 {
-    /* R1 = instrs
-       R2 = literals
-       R3 = ptrs
-       R4 = arity
-       R5 = bitmap array
+    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_ bco, bitmap_arr, bytes, words;
-    
-    bitmap_arr = R5;
+    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
+   -------------------------------------------------------------------------  */
+
+stg_newBCOzh ( P_ instrs,
+               P_ literals,
+               P_ ptrs,
+               W_ arity,
+               P_ bitmap_arr )
+{
+    W_ bco, bytes, words;
 
     words = BYTES_TO_WDS(SIZEOF_StgBCO) + BYTE_ARR_WDS(bitmap_arr);
     bytes = WDS(words);
 
-    ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R5_PTR, stg_newBCOzh );
+    ALLOC_PRIM (bytes);
 
     bco = Hp - bytes + WDS(1);
-    SET_HDR(bco, stg_BCO_info, CCCS);
-    
-    StgBCO_instrs(bco)     = R1;
-    StgBCO_literals(bco)   = R2;
-    StgBCO_ptrs(bco)       = R3;
-    StgBCO_arity(bco)      = HALF_W_(R4);
+    SET_HDR(bco, stg_BCO_info, CCS_MAIN);
+
+    StgBCO_instrs(bco)     = instrs;
+    StgBCO_literals(bco)   = literals;
+    StgBCO_ptrs(bco)       = ptrs;
+    StgBCO_arity(bco)      = HALF_W_(arity);
     StgBCO_size(bco)       = HALF_W_(words);
-    
+
     // Copy the arity/bitmap info into the BCO
     W_ i;
     i = 0;
 for:
     if (i < BYTE_ARR_WDS(bitmap_arr)) {
-       StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
-       i = i + 1;
-       goto for;
+        StgBCO_bitmap(bco,i) = StgArrBytes_payload(bitmap_arr,i);
+        i = i + 1;
+        goto for;
     }
-    
-    RET_P(bco);
-}
 
+    return (bco);
+}
 
-stg_mkApUpd0zh
+stg_mkApUpd0zh ( P_ bco )
 {
-    // R1 = the BCO# for the AP
-    // 
     W_ ap;
 
     // This function is *only* used to wrap zero-arity BCOs in an
     // updatable wrapper (see ByteCodeLink.lhs).  An AP thunk is always
     // saturated and always points directly to a FUN or BCO.
-    ASSERT(%INFO_TYPE(%GET_STD_INFO(R1)) == HALF_W_(BCO) &&
-          StgBCO_arity(R1) == HALF_W_(0));
+    ASSERT(%INFO_TYPE(%GET_STD_INFO(bco)) == HALF_W_(BCO) &&
+           StgBCO_arity(bco) == HALF_W_(0));
 
-    HP_CHK_GEN_TICKY(SIZEOF_StgAP, R1_PTR, stg_mkApUpd0zh);
+    HP_CHK_P(SIZEOF_StgAP, stg_mkApUpd0zh, bco);
     TICK_ALLOC_UP_THK(0, 0);
     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) = R1;
-    
-    RET_P(ap);
+    StgAP_fun(ap) = bco;
+
+    return (ap);
 }
 
-stg_unpackClosurezh
+stg_unpackClosurezh ( P_ closure )
 {
-/* args: R1 = closure to analyze */
-// 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(R1));
+    info  = %GET_STD_INFO(UNTAG(closure));
 
     // Some closures have non-standard layout, so we omit those here.
     W_ type;
@@ -1705,28 +2131,28 @@ stg_unpackClosurezh
         nptrs = 0;
         goto out;
     }
-    case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, 
+    case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1,
          THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : {
         ptrs = 0;
         nptrs = 0;
         goto out;
     }
     default: {
-        ptrs  = TO_W_(%INFO_PTRS(info)); 
+        ptrs  = TO_W_(%INFO_PTRS(info));
         nptrs = TO_W_(%INFO_NPTRS(info));
         goto out;
     }}
 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);
 
-    ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, stg_unpackClosurezh);
+    ALLOC_PRIM_P (ptrs_arr_sz + nptrs_arr_sz, stg_unpackClosurezh, closure);
 
     W_ clos;
-    clos = UNTAG(R1);
+    clos = UNTAG(closure);
 
     ptrs_arr  = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
     nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
@@ -1738,24 +2164,24 @@ out:
     p = 0;
 for:
     if(p < ptrs) {
-        W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);
-        p = p + 1;
-        goto for;
+         W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);
+         p = p + 1;
+         goto for;
     }
     /* We can leave the card table uninitialised, since the array is
        allocated in the nursery.  The GC will fill it in if/when the array
        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) {
-        W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);
-        p = p + 1;
-        goto for2;
+         W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);
+         p = p + 1;
+         goto for2;
     }
-    RET_NPP(info, ptrs_arr, nptrs_arr);
+    return (info, ptrs_arr, nptrs_arr);
 }
 
 /* -----------------------------------------------------------------------------
@@ -1765,52 +2191,50 @@ for2:
 /* Add a thread to the end of the blocked queue. (C-- version of the C
  * macro in Schedule.h).
  */
-#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;                      \
-    } else {                                           \
-      foreign "C" setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso) []; \
-    }                                                  \
+#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;                     \
+    } else {                                            \
+        ccall setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso); \
+    }                                                   \
     W_[blocked_queue_tl] = tso;
 
-stg_waitReadzh
+stg_waitReadzh ( W_ fd )
 {
-    /* args: R1 */
 #ifdef THREADED_RTS
-    foreign "C" barf("waitRead# on threaded RTS") never returns;
+    ccall barf("waitRead# on threaded RTS") never returns;
 #else
 
     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
-    StgTSO_block_info(CurrentTSO) = R1;
+    StgTSO_block_info(CurrentTSO) = fd;
     // No locking - we're not going to use this interface in the
     // threaded RTS anyway.
     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
-    jump stg_block_noregs;
+    jump stg_block_noregs();
 #endif
 }
 
-stg_waitWritezh
+stg_waitWritezh ( W_ fd )
 {
-    /* args: R1 */
 #ifdef THREADED_RTS
-    foreign "C" barf("waitWrite# on threaded RTS") never returns;
+    ccall barf("waitWrite# on threaded RTS") never returns;
 #else
 
     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
-    StgTSO_block_info(CurrentTSO) = R1;
+    StgTSO_block_info(CurrentTSO) = fd;
     // No locking - we're not going to use this interface in the
     // threaded RTS anyway.
     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
-    jump stg_block_noregs;
+    jump stg_block_noregs();
 #endif
 }
 
 
 STRING(stg_delayzh_malloc_str, "stg_delayzh")
-stg_delayzh
+stg_delayzh ( W_ us_delay )
 {
 #ifdef mingw32_HOST_OS
     W_ ares;
@@ -1820,19 +2244,18 @@ stg_delayzh
 #endif
 
 #ifdef THREADED_RTS
-    foreign "C" barf("delay# on threaded RTS") never returns;
+    ccall barf("delay# on threaded RTS") never returns;
 #else
 
-    /* args: R1 (microsecond delay amount) */
     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
     StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
 
 #ifdef mingw32_HOST_OS
 
     /* could probably allocate this on the heap instead */
-    ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
-                                           stg_delayzh_malloc_str);
-    (reqID) = foreign "C" addDelayRequest(R1);
+    ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
+                                        stg_delayzh_malloc_str);
+    (reqID) = ccall addDelayRequest(us_delay);
     StgAsyncIOResult_reqID(ares)   = reqID;
     StgAsyncIOResult_len(ares)     = 0;
     StgAsyncIOResult_errCode(ares) = 0;
@@ -1844,12 +2267,12 @@ stg_delayzh
      */
     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
-    jump stg_block_async_void;
+    jump stg_block_async_void();
 
 #else
 
 
-    (target) = foreign "C" getDelayTarget(R1) [R1];
+    (target) = ccall getDelayTarget(us_delay);
 
     StgTSO_block_info(CurrentTSO) = target;
 
@@ -1858,18 +2281,18 @@ stg_delayzh
     t = W_[sleeping_queue];
 while:
     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
-       prev = t;
-       t = StgTSO__link(t);
-       goto while;
+        prev = t;
+        t = StgTSO__link(t);
+        goto while;
     }
 
     StgTSO__link(CurrentTSO) = t;
     if (prev == NULL) {
-       W_[sleeping_queue] = CurrentTSO;
+        W_[sleeping_queue] = CurrentTSO;
     } else {
-        foreign "C" setTSOLink(MyCapability() "ptr", prev "ptr", CurrentTSO) [];
+        ccall setTSOLink(MyCapability() "ptr", prev "ptr", CurrentTSO);
     }
-    jump stg_block_noregs;
+    jump stg_block_noregs();
 #endif
 #endif /* !THREADED_RTS */
 }
@@ -1877,86 +2300,80 @@ while:
 
 #ifdef mingw32_HOST_OS
 STRING(stg_asyncReadzh_malloc_str, "stg_asyncReadzh")
-stg_asyncReadzh
+stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf )
 {
     W_ ares;
     CInt reqID;
 
 #ifdef THREADED_RTS
-    foreign "C" barf("asyncRead# on threaded RTS") never returns;
+    ccall barf("asyncRead# on threaded RTS") never returns;
 #else
 
-    /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
 
     /* could probably allocate this on the heap instead */
-    ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
-                                           stg_asyncReadzh_malloc_str)
-                       [R1,R2,R3,R4];
-    (reqID) = foreign "C" addIORequest(R1, 0/*FALSE*/,R2,R3,R4 "ptr") [];
+    ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
+                                        stg_asyncReadzh_malloc_str);
+    (reqID) = ccall addIORequest(fd, 0/*FALSE*/,is_sock,len,buf "ptr");
     StgAsyncIOResult_reqID(ares)   = reqID;
     StgAsyncIOResult_len(ares)     = 0;
     StgAsyncIOResult_errCode(ares) = 0;
     StgTSO_block_info(CurrentTSO)  = ares;
     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
-    jump stg_block_async;
+    jump stg_block_async();
 #endif
 }
 
 STRING(stg_asyncWritezh_malloc_str, "stg_asyncWritezh")
-stg_asyncWritezh
+stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf )
 {
     W_ ares;
     CInt reqID;
 
 #ifdef THREADED_RTS
-    foreign "C" barf("asyncWrite# on threaded RTS") never returns;
+    ccall barf("asyncWrite# on threaded RTS") never returns;
 #else
 
-    /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
 
-    ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
-                                           stg_asyncWritezh_malloc_str)
-                       [R1,R2,R3,R4];
-    (reqID) = foreign "C" addIORequest(R1, 1/*TRUE*/,R2,R3,R4 "ptr") [];
+    ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
+                                        stg_asyncWritezh_malloc_str);
+    (reqID) = ccall addIORequest(fd, 1/*TRUE*/,is_sock,len,buf "ptr");
 
     StgAsyncIOResult_reqID(ares)   = reqID;
     StgAsyncIOResult_len(ares)     = 0;
     StgAsyncIOResult_errCode(ares) = 0;
     StgTSO_block_info(CurrentTSO)  = ares;
     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
-    jump stg_block_async;
+    jump stg_block_async();
 #endif
 }
 
 STRING(stg_asyncDoProczh_malloc_str, "stg_asyncDoProczh")
-stg_asyncDoProczh
+stg_asyncDoProczh ( W_ proc, W_ param )
 {
     W_ ares;
     CInt reqID;
 
 #ifdef THREADED_RTS
-    foreign "C" barf("asyncDoProc# on threaded RTS") never returns;
+    ccall barf("asyncDoProc# on threaded RTS") never returns;
 #else
 
-    /* args: R1 = proc, R2 = param */
     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
 
     /* could probably allocate this on the heap instead */
-    ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
-                                           stg_asyncDoProczh_malloc_str) 
-                               [R1,R2];
-    (reqID) = foreign "C" addDoProcRequest(R1 "ptr",R2 "ptr") [];
+    ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult,
+                                        stg_asyncDoProczh_malloc_str);
+    (reqID) = ccall addDoProcRequest(proc "ptr",param "ptr");
     StgAsyncIOResult_reqID(ares)   = reqID;
     StgAsyncIOResult_len(ares)     = 0;
     StgAsyncIOResult_errCode(ares) = 0;
     StgTSO_block_info(CurrentTSO) = ares;
     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
-    jump stg_block_async;
+    jump stg_block_async();
 #endif
 }
 #endif
@@ -1985,7 +2402,7 @@ stg_asyncDoProczh
  *   |    -------+-----> A <-------+-------        |
  *   |  update   |   BLACKHOLE     | marked_update |
  *   +-----------+                 +---------------+
- *   |           |                 |               | 
+ *   |           |                 |               |
  *        ...                             ...
  *   |           |                 +---------------+
  *   +-----------+
@@ -2012,15 +2429,21 @@ stg_asyncDoProczh
  * only manifests occasionally (once very 10 runs or so).
  * -------------------------------------------------------------------------- */
 
-INFO_TABLE_RET(stg_noDuplicate, RET_SMALL)
+INFO_TABLE_RET(stg_noDuplicate, RET_SMALL, W_ info_ptr)
+    return (/* no return values */)
 {
-    Sp_adj(1);
-    jump stg_noDuplicatezh;
+    jump stg_noDuplicatezh();
 }
 
-stg_noDuplicatezh
+stg_noDuplicatezh /* no arg list: explicit stack layout */
 {
-    STK_CHK_GEN( WDS(1), NO_PTRS, stg_noDuplicatezh );
+    // With a single capability there's no chance of work duplication.
+    if (CInt[n_capabilities] == 1 :: CInt) {
+        jump %ENTRY_CODE(Sp(0)) [];
+    }
+
+    STK_CHK_LL (WDS(1), stg_noDuplicatezh);
+
     // leave noDuplicate frame in case the current
     // computation is suspended and restarted (see above).
     Sp_adj(-1);
@@ -2028,10 +2451,10 @@ stg_noDuplicatezh
 
     SAVE_THREAD_STATE();
     ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
-    foreign "C" threadPaused (MyCapability() "ptr", CurrentTSO "ptr") [];
-    
+    ccall threadPaused (MyCapability() "ptr", CurrentTSO "ptr");
+
     if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
-        jump stg_threadFinished;
+        jump stg_threadFinished [];
     } else {
         LOAD_THREAD_STATE();
         ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
@@ -2039,7 +2462,7 @@ stg_noDuplicatezh
         if (Sp(0) == stg_noDuplicate_info) {
             Sp_adj(1);
         }
-        jump %ENTRY_CODE(Sp(0));
+        jump %ENTRY_CODE(Sp(0)) [];
     }
 }
 
@@ -2047,101 +2470,122 @@ stg_noDuplicatezh
    Misc. primitives
    -------------------------------------------------------------------------- */
 
-stg_getApStackValzh
+stg_getApStackValzh ( P_ ap_stack, W_ offset )
 {
-   W_ ap_stack, offset, val, ok;
-
-   /* args: R1 = AP_STACK, R2 = offset */
-   ap_stack = R1;
-   offset   = R2;
-
    if (%INFO_PTR(ap_stack) == stg_AP_STACK_info) {
-        ok = 1;
-        val = StgAP_STACK_payload(ap_stack,offset); 
+       return (1,StgAP_STACK_payload(ap_stack,offset));
    } else {
-        ok = 0;
-        val = R1;
+       return (0,ap_stack);
    }
-   RET_NP(ok,val);
 }
 
 // Write the cost center stack of the first argument on stderr; return
 // the second.  Possibly only makes sense for already evaluated
 // things?
-stg_traceCcszh
+stg_traceCcszh ( P_ obj, P_ ret )
 {
     W_ ccs;
 
 #ifdef PROFILING
-    ccs = StgHeader_ccs(UNTAG(R1));
-    foreign "C" fprintCCS_stderr(ccs "ptr") [R2];
+    ccs = StgHeader_ccs(UNTAG(obj));
+    ccall fprintCCS_stderr(ccs "ptr");
 #endif
 
-    R1 = R2;
-    ENTER();
+    jump stg_ap_0_fast(ret);
 }
 
-stg_getSparkzh
+stg_getSparkzh ()
 {
-   W_ spark;
+    W_ spark;
 
 #ifndef THREADED_RTS
-   RET_NP(0,ghczmprim_GHCziTypes_False_closure);
+    return (0,ghczmprim_GHCziTypes_False_closure);
 #else
-   (spark) = foreign "C" findSpark(MyCapability());
-   if (spark != 0) {
-      RET_NP(1,spark);
-   } else {
-      RET_NP(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_numSparkszh
+stg_clearCCSzh (P_ arg)
 {
-  W_ n;
+#ifdef PROFILING
+    CCCS = CCS_MAIN;
+#endif
+    jump stg_ap_v_fast(arg);
+}
+
+stg_numSparkszh ()
+{
+    W_ n;
 #ifdef THREADED_RTS
-  (n) = foreign "C" dequeElements(Capability_sparks(MyCapability()));
+    (n) = ccall dequeElements(Capability_sparks(MyCapability()));
 #else
-  n = 0;
+    n = 0;
 #endif
-  RET_N(n);
+    return (n);
 }
 
-stg_traceEventzh
+stg_traceEventzh ( W_ msg )
 {
-   W_ msg;
-   msg = R1;
+#if defined(TRACING) || defined(DEBUG)
+
+    ccall traceUserMsg(MyCapability() "ptr", msg "ptr");
 
+#elif defined(DTRACE)
+
+    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
+#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;
+#endif
+    if (enabled != 0) {
+      ccall dtraceUserMsgWrapper(MyCapability() "ptr", msg "ptr");
+    }
+
+#endif
+    return ();
+}
+
+// Same code as stg_traceEventzh above but a different kind of event
+// Before changing this code, read the comments in the impl above
+stg_traceMarkerzh ( W_ msg )
+{
 #if defined(TRACING) || defined(DEBUG)
 
-   foreign "C" traceUserMsg(MyCapability() "ptr", msg "ptr") [];
+    ccall traceUserMarker(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
 #if !defined(solaris2_TARGET_OS)
-   (enabled) = foreign "C" __dtrace_isenabled$HaskellEvent$user__msg$v1() [];
+    (enabled) = ccall __dtrace_isenabled$HaskellEvent$user__marker$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;
+    enabled = 1;
 #endif
-   if (enabled != 0) {
-     foreign "C" dtraceUserMsgWrapper(MyCapability() "ptr", msg "ptr") [];
-   }
+    if (enabled != 0) {
+        ccall dtraceUserMarkerWrapper(MyCapability() "ptr", msg "ptr");
+    }
 
 #endif
-   jump %ENTRY_CODE(Sp(0));
+    return ();
 }
+