Two new prim ops to access the Info Table and Payload of a closure:

- infoPtr# :: a -> Addr#
- closurePayload# :: a -> (# Array b, ByteArr# #)

These prim ops provide the magic behind the ':print' command

diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index ef5dfc9..f5a98c3 100644 (file)
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -1677,6 +1677,16 @@ primop  NewBCOOp "newBCO#" GenPrimOp
    has_side_effects = True
    out_of_line      = True
 
+primop  InfoPtrOp "infoPtr#" GenPrimOp
+   a -> Addr#
+   with
+   out_of_line = True
+
+primop  ClosurePayloadOp "closurePayload#" GenPrimOp
+   a -> (# Array# b, ByteArr# #)
+   with
+   out_of_line = True
+
 ------------------------------------------------------------------------
 section "Coercion" 
        {{\tt unsafeCoerce\# :: a -> b} is not a primop, but is defined in MkId.lhs.}

diff --git a/includes/StgMiscClosures.h b/includes/StgMiscClosures.h
index 4f638ea..d989561 100644 (file)
--- a/includes/StgMiscClosures.h
+++ b/includes/StgMiscClosures.h
@@ -614,4 +614,7 @@ RTS_FUN(readTVarzh_fast);
 RTS_FUN(writeTVarzh_fast);
 RTS_FUN(checkzh_fast);
 
+RTS_FUN(infoPtrzh_fast);
+RTS_FUN(closurePayloadzh_fast);
+
 #endif /* STGMISCCLOSURES_H */

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index bfb0b86..e0823e4 100644 (file)
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -1961,6 +1961,55 @@ mkApUpd0zh_fast
     RET_P(ap);
 }
 
+infoPtrzh_fast
+{
+/* args: R1 = closure to analyze */
+   
+  MAYBE_GC(R1_PTR, infoPtrzh_fast);
+
+  W_ info;
+  info = %GET_STD_INFO(R1);
+  RET_N(info);
+}
+
+closurePayloadzh_fast
+{
+/* args: R1 = closure to analyze */
+// TODO: Consider the absence of ptrs or nonptrs as a special case ?
+
+    MAYBE_GC(R1_PTR, closurePayloadzh_fast);
+
+    W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
+    info  = %GET_STD_INFO(R1);
+    ptrs  = TO_W_(%INFO_PTRS(info)); 
+    nptrs = TO_W_(%INFO_NPTRS(info));
+    p = 0;
+
+    ALLOC_PRIM (SIZEOF_StgMutArrPtrs + WDS(ptrs), R1_PTR, closurePayloadzh_fast);
+    ptrs_arr = Hp - SIZEOF_StgMutArrPtrs - WDS(ptrs) + WDS(1);
+    SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, W_[CCCS]);
+    StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
+for:
+    if(p < ptrs) {
+        W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(R1,p);
+        p = p + 1;
+        goto for;
+    }
+    
+    ALLOC_PRIM (SIZEOF_StgArrWords + WDS(nptrs), R1_PTR, closurePayloadzh_fast);
+    nptrs_arr = Hp - SIZEOF_StgArrWords - WDS(nptrs) + WDS(1);
+    SET_HDR(nptrs_arr, stg_ARR_WORDS_info, W_[CCCS]);
+    StgArrWords_words(nptrs_arr) = nptrs;
+    p = 0;
+for2:
+    if(p < nptrs) {
+        W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(R1, p+ptrs);
+        p = p + 1;
+        goto for2;
+    }
+    RET_PP(ptrs_arr, nptrs_arr);
+}
+
 /* -----------------------------------------------------------------------------
    Thread I/O blocking primitives
    -------------------------------------------------------------------------- */