/* -----------------------------------------------------------------------------
- * $Id: Storage.h,v 1.10 1999/11/02 15:06:05 simonmar Exp $
+ * $Id: Storage.h,v 1.22 2001/01/24 15:46:19 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
MarkRoot(StgClosure *p) Returns the new location of the root.
-------------------------------------------------------------------------- */
-extern void GarbageCollect(void (*get_roots)(void));
+extern void GarbageCollect(void (*get_roots)(void),rtsBool force_major_gc);
extern StgClosure *MarkRoot(StgClosure *p);
+/* Temporary measure to ensure we retain all the dynamically-loaded CAFs */
+#ifdef GHCI
+extern void markCafs( void );
+#endif
+
/* -----------------------------------------------------------------------------
Generational garbage collection support
-------------------------------------------------------------------------- */
+/* ToDo: shouldn't recordMutable and recordOldToNewPtrs acquire some
+ * kind of lock in the SMP case?
+ */
static inline void
recordMutable(StgMutClosure *p)
{
bdescr *bd;
#ifdef SMP
- ASSERT(p->header.info == &WHITEHOLE_info || closure_MUTABLE(p));
+ ASSERT(p->header.info == &stg_WHITEHOLE_info || closure_MUTABLE(p));
#else
ASSERT(closure_MUTABLE(p));
#endif
}
}
-#define updateWithIndirection(p1, p2) \
- { \
- bdescr *bd; \
- \
- bd = Bdescr((P_)p1); \
- if (bd->gen->no == 0) { \
- ((StgInd *)p1)->indirectee = p2; \
- SET_INFO(p1,&IND_info); \
- TICK_UPD_NEW_IND(); \
- } else { \
- ((StgIndOldGen *)p1)->indirectee = p2; \
- ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list; \
- bd->gen->mut_once_list = (StgMutClosure *)p1; \
- SET_INFO(p1,&IND_OLDGEN_info); \
- TICK_UPD_OLD_IND(); \
- } \
+#ifndef DEBUG
+#define updateWithIndirection(info, p1, p2) \
+ { \
+ bdescr *bd; \
+ \
+ bd = Bdescr((P_)p1); \
+ if (bd->gen->no == 0) { \
+ ((StgInd *)p1)->indirectee = p2; \
+ SET_INFO(p1,&stg_IND_info); \
+ TICK_UPD_NEW_IND(); \
+ } else { \
+ ((StgIndOldGen *)p1)->indirectee = p2; \
+ if (info != &stg_BLACKHOLE_BQ_info) { \
+ ACQUIRE_LOCK(&sm_mutex); \
+ ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list; \
+ bd->gen->mut_once_list = (StgMutClosure *)p1; \
+ RELEASE_LOCK(&sm_mutex); \
+ } \
+ SET_INFO(p1,&stg_IND_OLDGEN_info); \
+ TICK_UPD_OLD_IND(); \
+ } \
+ }
+#else
+
+/* In the DEBUG case, we also zero out the slop of the old closure,
+ * so that the sanity checker can tell where the next closure is.
+ */
+#define updateWithIndirection(info, p1, p2) \
+ { \
+ bdescr *bd; \
+ \
+ bd = Bdescr((P_)p1); \
+ if (bd->gen->no == 0) { \
+ ((StgInd *)p1)->indirectee = p2; \
+ SET_INFO(p1,&stg_IND_info); \
+ TICK_UPD_NEW_IND(); \
+ } else { \
+ if (info != &stg_BLACKHOLE_BQ_info) { \
+ { \
+ StgInfoTable *inf = get_itbl(p1); \
+ nat np = inf->layout.payload.ptrs, \
+ nw = inf->layout.payload.nptrs, i; \
+ for (i = np; i < np + nw; i++) { \
+ ((StgClosure *)p1)->payload[i] = 0; \
+ } \
+ } \
+ ACQUIRE_LOCK(&sm_mutex); \
+ ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list; \
+ bd->gen->mut_once_list = (StgMutClosure *)p1; \
+ RELEASE_LOCK(&sm_mutex); \
+ } \
+ ((StgIndOldGen *)p1)->indirectee = p2; \
+ SET_INFO(p1,&stg_IND_OLDGEN_info); \
+ TICK_UPD_OLD_IND(); \
+ } \
+ }
+#endif
+
+/* Static objects all live in the oldest generation
+ */
+#define updateWithStaticIndirection(info, p1, p2) \
+ { \
+ ASSERT( ((StgMutClosure*)p1)->mut_link == NULL ); \
+ \
+ ACQUIRE_LOCK(&sm_mutex); \
+ ((StgMutClosure *)p1)->mut_link = oldest_gen->mut_once_list; \
+ oldest_gen->mut_once_list = (StgMutClosure *)p1; \
+ RELEASE_LOCK(&sm_mutex); \
+ \
+ ((StgInd *)p1)->indirectee = p2; \
+ SET_INFO((StgInd *)p1, &stg_IND_STATIC_info); \
+ TICK_UPD_STATIC_IND(); \
}
#if defined(TICKY_TICKY) || defined(PROFILING)
static inline void
-updateWithPermIndirection(StgClosure *p1, StgClosure *p2)
+updateWithPermIndirection(const StgInfoTable *info, StgClosure *p1, StgClosure *p2)
{
bdescr *bd;
bd = Bdescr((P_)p1);
if (bd->gen->no == 0) {
((StgInd *)p1)->indirectee = p2;
- SET_INFO(p1,&IND_PERM_info);
+ SET_INFO(p1,&stg_IND_PERM_info);
TICK_UPD_NEW_PERM_IND(p1);
} else {
((StgIndOldGen *)p1)->indirectee = p2;
- ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list;
- bd->gen->mut_once_list = (StgMutClosure *)p1;
- SET_INFO(p1,&IND_OLDGEN_PERM_info);
+ if (info != &stg_BLACKHOLE_BQ_info) {
+ ACQUIRE_LOCK(&sm_mutex);
+ ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list;
+ bd->gen->mut_once_list = (StgMutClosure *)p1;
+ RELEASE_LOCK(&sm_mutex);
+ }
+ SET_INFO(p1,&stg_IND_OLDGEN_PERM_info);
TICK_UPD_OLD_PERM_IND();
}
}
#endif
/* -----------------------------------------------------------------------------
- The CAF list - used to let us revert CAFs
+ The CAF table - used to let us revert CAFs
+ -------------------------------------------------------------------------- */
+
+#if defined(INTERPRETER)
+typedef struct StgCAFTabEntry_ {
+ StgClosure* closure;
+ StgInfoTable* origItbl;
+} StgCAFTabEntry;
+
+extern void addToECafTable ( StgClosure* closure, StgInfoTable* origItbl );
+extern void clearECafTable ( void );
+
+extern StgCAF* ecafList;
+extern StgCAFTabEntry* ecafTable;
+extern StgInt usedECafTable;
+extern StgInt sizeECafTable;
+#endif
+#if defined(DEBUG)
+void printMutOnceList(generation *gen);
+void printMutableList(generation *gen);
+#endif DEBUG
+
+/* -----------------------------------------------------------------------------
+ Macros for distinguishing data pointers from code pointers
-------------------------------------------------------------------------- */
+/*
+ * We use some symbols inserted automatically by the linker to decide
+ * whether a pointer points to text, data, or user space. These tests
+ * assume that text is lower in the address space than data, which in
+ * turn is lower than user allocated memory.
+ *
+ * If this assumption is false (say on some strange architecture) then
+ * the tests IS_CODE_PTR and IS_DATA_PTR below will need to be
+ * modified (and that should be all that's necessary).
+ *
+ * _start } start of read-only text space
+ * _etext } end of read-only text space
+ * _end } end of read-write data space
+ */
+extern StgFun start;
+
+extern void* TEXT_SECTION_END_MARKER_DECL;
+extern void* DATA_SECTION_END_MARKER_DECL;
+
+#if defined(INTERPRETER) || defined(GHCI)
+/* Take into account code sections in dynamically loaded object files. */
+#define IS_CODE_PTR(p) ( ((P_)(p) < (P_)&TEXT_SECTION_END_MARKER) \
+ || is_dynamically_loaded_code_or_rodata_ptr((char *)p) )
+#define IS_DATA_PTR(p) ( ((P_)(p) >= (P_)&TEXT_SECTION_END_MARKER && \
+ (P_)(p) < (P_)&DATA_SECTION_END_MARKER) \
+ || is_dynamically_loaded_rwdata_ptr((char *)p) )
+#define IS_USER_PTR(p) ( ((P_)(p) >= (P_)&DATA_SECTION_END_MARKER) \
+ && is_not_dynamically_loaded_ptr((char *)p) )
+#else
+#define IS_CODE_PTR(p) ((P_)(p) < (P_)&TEXT_SECTION_END_MARKER)
+#define IS_DATA_PTR(p) ((P_)(p) >= (P_)&TEXT_SECTION_END_MARKER && (P_)(p) < (P_)&DATA_SECTION_END_MARKER)
+#define IS_USER_PTR(p) ((P_)(p) >= (P_)&DATA_SECTION_END_MARKER)
+#endif
+
+/* The HEAP_ALLOCED test below is called FOR EVERY SINGLE CLOSURE
+ * during GC. It needs to be FAST.
+ */
+#ifdef TEXT_BEFORE_HEAP
+# define HEAP_ALLOCED(x) ((StgPtr)(x) >= (StgPtr)(HEAP_BASE))
+#else
+extern int is_heap_alloced(const void* x);
+# define HEAP_ALLOCED(x) (is_heap_alloced(x))
+#endif
+
+/* When working with Win32 DLLs, static closures are identified by
+ being prefixed with a zero word. This is needed so that we can
+ distinguish between pointers to static closures and (reversed!)
+ info tables.
+
+ This 'scheme' breaks down for closure tables such as CHARLIKE,
+ so we catch these separately.
+
+ LOOKS_LIKE_STATIC_CLOSURE()
+ - discriminates between static closures and info tbls
+ (needed by LOOKS_LIKE_GHC_INFO() below - [Win32 DLLs only.])
+ LOOKS_LIKE_STATIC()
+ - distinguishes between static and heap allocated data.
+ */
+#if defined(ENABLE_WIN32_DLL_SUPPORT) && !defined(INTERPRETER)
+ /* definitely do not enable for mingw DietHEP */
+#define LOOKS_LIKE_STATIC(r) (!(HEAP_ALLOCED(r)))
+
+/* Tiresome predicates needed to check for pointers into the closure tables */
+#define IS_CHARLIKE_CLOSURE(p) \
+ ( (P_)(p) >= (P_)stg_CHARLIKE_closure && \
+ (char*)(p) <= ((char*)stg_CHARLIKE_closure + \
+ (MAX_CHARLIKE-MIN_CHARLIKE) * sizeof(StgIntCharlikeClosure)) )
+#define IS_INTLIKE_CLOSURE(p) \
+ ( (P_)(p) >= (P_)stg_INTLIKE_closure && \
+ (char*)(p) <= ((char*)stg_INTLIKE_closure + \
+ (MAX_INTLIKE-MIN_INTLIKE) * sizeof(StgIntCharlikeClosure)) )
+
+#define LOOKS_LIKE_STATIC_CLOSURE(r) (((*(((unsigned long *)(r))-1)) == 0) || IS_CHARLIKE_CLOSURE(r) || IS_INTLIKE_CLOSURE(r))
+#else
+#define LOOKS_LIKE_STATIC(r) IS_DATA_PTR(r)
+#define LOOKS_LIKE_STATIC_CLOSURE(r) IS_DATA_PTR(r)
+#endif
+
+
+/* -----------------------------------------------------------------------------
+ Macros for distinguishing infotables from closures.
+
+ You'd think it'd be easy to tell an info pointer from a closure pointer:
+ closures live on the heap and infotables are in read only memory. Right?
+ Wrong! Static closures live in read only memory and Hugs allocates
+ infotables for constructors on the (writable) C heap.
+ -------------------------------------------------------------------------- */
+
+#ifdef INTERPRETER
+# ifdef USE_MINIINTERPRETER
+ /* yoiks: one of the dreaded pointer equality tests */
+# define IS_HUGS_CONSTR_INFO(info) \
+ (((StgInfoTable *)(info))->entry == (StgFunPtr)&Hugs_CONSTR_entry)
+# else
+# define IS_HUGS_CONSTR_INFO(info) 0 /* ToDo: more than mildly bogus */
+# endif
+#elif GHCI
+ /* not accurate by any means, but stops the assertions failing... */
+# define IS_HUGS_CONSTR_INFO(info) IS_USER_PTR(info)
+#else
+# define IS_HUGS_CONSTR_INFO(info) 0 /* ToDo: more than mildly bogus */
+#endif
+
+/* LOOKS_LIKE_GHC_INFO is called moderately often during GC, but
+ * Certainly not as often as HEAP_ALLOCED.
+ */
+#ifdef TEXT_BEFORE_HEAP /* needed for mingw DietHEP */
+# define LOOKS_LIKE_GHC_INFO(info) IS_CODE_PTR(info)
+#else
+# define LOOKS_LIKE_GHC_INFO(info) (!HEAP_ALLOCED(info) \
+ && !LOOKS_LIKE_STATIC_CLOSURE(info))
+#endif
+
+/* -----------------------------------------------------------------------------
+ Macros for calculating how big a closure will be (used during allocation)
+ -------------------------------------------------------------------------- */
+
+/* ToDo: replace unsigned int by nat. The only fly in the ointment is that
+ * nat comes from Rts.h which many folk dont include. Sigh!
+ */
+static __inline__ StgOffset AP_sizeW ( unsigned int n_args )
+{ return sizeofW(StgAP_UPD) + n_args; }
+
+static __inline__ StgOffset PAP_sizeW ( unsigned int n_args )
+{ return sizeofW(StgPAP) + n_args; }
+
+static __inline__ StgOffset CONSTR_sizeW( unsigned int p, unsigned int np )
+{ return sizeofW(StgHeader) + p + np; }
+
+static __inline__ StgOffset THUNK_SELECTOR_sizeW ( void )
+{ return sizeofW(StgHeader) + MIN_UPD_SIZE; }
+
+static __inline__ StgOffset BLACKHOLE_sizeW ( void )
+{ return sizeofW(StgHeader) + MIN_UPD_SIZE; }
+
+static __inline__ StgOffset CAF_sizeW ( void )
+{ return sizeofW(StgCAF); }
+
+/* --------------------------------------------------------------------------
+ * Sizes of closures
+ * ------------------------------------------------------------------------*/
+
+static __inline__ StgOffset sizeW_fromITBL( const StgInfoTable* itbl )
+{ return sizeofW(StgClosure)
+ + sizeofW(StgPtr) * itbl->layout.payload.ptrs
+ + sizeofW(StgWord) * itbl->layout.payload.nptrs; }
+
+static __inline__ StgOffset pap_sizeW( StgPAP* x )
+{ return PAP_sizeW(x->n_args); }
+
+static __inline__ StgOffset arr_words_sizeW( StgArrWords* x )
+{ return sizeofW(StgArrWords) + x->words; }
+
+static __inline__ StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x )
+{ return sizeofW(StgMutArrPtrs) + x->ptrs; }
-extern StgCAF* enteredCAFs;
+static __inline__ StgWord tso_sizeW ( StgTSO *tso )
+{ return TSO_STRUCT_SIZEW + tso->stack_size; }
#endif STORAGE_H
projects / ghc-hetmet.git / blobdiff