From d308d910efa702ebf5a2f76db628d690fcf6fa51 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 9 Dec 2006 17:38:23 +0000 Subject: [PATCH] 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 --- compiler/prelude/primops.txt.pp | 10 ++++++++ includes/StgMiscClosures.h | 3 +++ rts/PrimOps.cmm | 49 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 62 insertions(+) diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index ef5dfc9..f5a98c3 100644 --- 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 --- 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 --- 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 -------------------------------------------------------------------------- */ -- 1.7.10.4