%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CLabel.lhs,v 1.43 2000/11/20 17:42:00 sewardj Exp $
+% $Id: CLabel.lhs,v 1.44 2000/12/04 12:31:19 simonmar Exp $
%
\section[CLabel]{@CLabel@: Information to make C Labels}
, cCallConv
, defaultCallConv
, callConvAttribute
- , decorateExtName
) where
#include "HsVersions.h"
| otherwise = panic ("callConvAttribute: cannot handle" ++ showSDoc (pprCallConv cc))
\end{code}
-
-For stdcall and Win32, the linker expects to see names of the form
-
- "f@n"
-
-where n is the size (in 8-bit bytes) of the parameter area
-that is pushed onto the stack before invocation. We take
-care of mangling the function name here.
-
-This name mangler is only used by the x86 native code generator.
-
-\begin{code}
-decorateExtName :: CallConv -> FAST_STRING -> [PrimRep] -> FAST_STRING
-decorateExtName cc fs ps
- | cc /= stdCallConv = fs
- | otherwise = fs _APPEND_ (_PK_ ('@':show (size::Int)))
- where
- size = sum (map (adjustParamSize.getPrimRepSizeInBytes) ps)
-
- adjustParamSize sz = paramBoundary * ((sz + paramBoundary - 1) `div` paramBoundary)
-
- paramBoundary = 4
-
-\end{code}
import Maybes ( maybeToBool, expectJust )
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
-import CallConv ( cCallConv )
+import CallConv ( cCallConv, stdCallConv )
import Stix ( getNatLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..),
DestInfo, hasDestInfo,
let (sizes, codes) = unzip sizes_n_codes
tot_arg_size = sum sizes
code2 = concatOL codes
- call = toOL [
- CALL fn__2,
- ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
- DELTA (delta + tot_arg_size)
- ]
+ call = toOL (
+ [CALL (fn__2 tot_arg_size)]
+ ++
+ (if cconv == stdCallConv then [] else
+ [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
+ ++
+ [DELTA (delta + tot_arg_size)]
+ )
in
setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
returnNat (code2 `appOL` call)
-- internally generated names like '.mul,' which don't get an
-- underscore prefix
-- ToDo:needed (WDP 96/03) ???
- fn__2 = case (_HEAD_ fn) of
- '.' -> ImmLit (ptext fn)
- _ -> ImmLab False (ptext fn)
+ fn_u = _UNPK_ fn
+ fn__2 tot_arg_size
+ | head fn_u == '.'
+ = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
+ | otherwise
+ = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
+
+ stdcallsize tot_arg_size
+ | cconv == stdCallConv = '@':show tot_arg_size
+ | otherwise = ""
arg_size DF = 8
arg_size F = 4
rESERVED_STACK_WORDS )
import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
mkMAP_FROZEN_infoLabel, mkForeignLabel )
+import CallConv ( cCallConv )
import Outputable
import FastTypes
ToDo: saving/restoring of volatile regs around ccalls.
+JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
+rather than inheriting the calling convention of the thing which we're really
+calling.
+
\begin{code}
primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
| is_asm = error "ERROR: Native code generator can't handle casm"
id = StReg (StixTemp uniq IntRep)
suspend = StAssign IntRep id
- (StCall SLIT("suspendThread") cconv IntRep [stgBaseReg])
- resume = StCall SLIT("resumeThread") cconv VoidRep [id]
+ (StCall SLIT("suspendThread") {-no:cconv-} cCallConv
+ IntRep [stgBaseReg])
+ resume = StCall SLIT("resumeThread") {-no:cconv-} cCallConv
+ VoidRep [id]
in
returnUs (\xs -> save (suspend : ccall : resume : load xs))
-----------------------------------------------------------------------
--- $Id: primops.txt,v 1.6 2000/11/07 15:21:40 simonmar Exp $
+-- $Id: primops.txt,v 1.7 2000/12/04 12:31:19 simonmar Exp $
--
-- Primitive Operations
--
primop IndexOffClosureOp_Word "indexWordOffClosure#" GenPrimOp
a -> Int# -> Word#
+primop SetOffClosureOp_Ptr "setPtrOffClosure#" GenPrimOp
+ a -> Int# -> b -> (# a #)
+ with strictness = { \ arity -> StrictnessInfo [wwStrict, wwPrim, wwLazy] False }
+
+primop SetOffClosureOp_Word "setWordOffClosure#" GenPrimOp
+ a -> Int# -> Word# -> (# a #)
+ with strictness = { \ arity -> StrictnessInfo [wwStrict, wwPrim, wwPrim] False }
------------------------------------------------------------------------
--- Addr# ---
simplExprF (Note InlineCall e) cont
= simplExprF e (InlinePlease cont)
--- Comments about the InlineMe case
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Comments about the InlineMe case
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Don't inline in the RHS of something that has an
-- inline pragma. But be careful that the InScopeEnv that
-- we return does still have inlinings on!
-- the specialised version of g when f is inlined at some call site
-- (perhaps in some other module).
+-- It's also important not to inline a worker back into a wrapper.
+-- A wrapper looks like
+-- wraper = inline_me (\x -> ...worker... )
+-- Normally, the inline_me prevents the worker getting inlined into
+-- the wrapper (initially, the worker's only call site!). But,
+-- if the wrapper is sure to be called, the strictness analyser will
+-- mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
+-- continuation. That's why the keep_inline predicate returns True for
+-- ArgOf continuations. It shouldn't do any harm not to dissolve the
+-- inline-me note under these circumstances
+
simplExprF (Note InlineMe e) cont
- = case cont of
- Stop _ _ -> -- Totally boring continuation
- -- Don't inline inside an INLINE expression
- setBlackList noInlineBlackList (simplExpr e) `thenSmpl` \ e' ->
- rebuild (mkInlineMe e') cont
-
- other -> -- Dissolve the InlineMe note if there's
- -- an interesting context of any kind to combine with
- -- (even a type application -- anything except Stop)
- simplExprF e cont
+ | keep_inline cont -- Totally boring continuation
+ = -- Don't inline inside an INLINE expression
+ setBlackList noInlineBlackList (simplExpr e) `thenSmpl` \ e' ->
+ rebuild (mkInlineMe e') cont
+
+ | otherwise -- Dissolve the InlineMe note if there's
+ -- an interesting context of any kind to combine with
+ -- (even a type application -- anything except Stop)
+ = simplExprF e cont
+ where
+ keep_inline (Stop _ _) = True -- See notes above
+ keep_inline (ArgOf _ _ _) = True -- about this predicate
+ keep_inline other = False
-- A non-recursive let is dealt with by simplBeta
simplExprF (Let (NonRec bndr rhs) body) cont
import Var
import IdInfo ( ArityInfo(..), OccInfo(..) )
import PrimOp ( PrimOp(..), ccallMayGC )
-import TysWiredIn ( isForeignObjTy )
+import TysPrim ( foreignObjPrimTyCon )
+import Type ( splitTyConApp_maybe )
import Maybes ( maybeToBool, orElse )
import Name ( getOccName )
import OccName ( occNameUserString )
\begin{code}
findLiveArgs :: StgLiveVars -> StgArg -> StgLiveVars
findLiveArgs lvs (StgVarArg x)
- | isForeignObjTy (idType x) = extendVarSet lvs x
- | otherwise = lvs
-findLiveArgs lvs arg = lvs
+ | isForeignObjPrimTy (idType x) = extendVarSet lvs x
+ | otherwise = lvs
+findLiveArgs lvs arg = lvs
+
+isForeignObjPrimTy ty
+ = case splitTyConApp_maybe ty of
+ Just (tycon, _) -> tycon == foreignObjPrimTyCon
+ Nothing -> False
\end{code}
import Type ( Type, PredType(..),
isTyVarTy, mkDictTy, mkPredTy,
splitForAllTys, splitSigmaTy, funArgTy,
- splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
+ splitMethodTy, splitRhoTy,
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
tidyOpenType, tidyOpenTypes
)
import Subst ( emptyInScopeSet, mkSubst, mkInScopeSet,
let
(tyvars, rho) = splitForAllTys (idType id)
rho_ty = substTy (mkTyVarSubst tyvars tys) rho
- (theta, tau) = splitRhoTy rho_ty
+ (pred, tau) = splitMethodTy rho_ty
in
- newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst ->
+ newMethodWithGivenTy orig id tys [pred] tau `thenNF_Tc` \ meth_inst ->
returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
instOverloadedFun orig v arg_tys theta tau
pprInst m@(Method u id tys theta tau loc)
= hsep [ppr id, ptext SLIT("at"),
brackets (interppSP tys) {- ,
- ppr theta, ppr tau,
+ ptext SLIT("theta"), ppr theta,
+ ptext SLIT("tau"), ppr tau
show_uniq u,
ppr (instToId m) -}]
#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.46 2000/11/21 16:29:26 simonmar Exp $
+# $Id: Makefile,v 1.47 2000/12/04 12:31:20 simonmar Exp $
#
TOP=..
-
/* -----------------------------------------------------------------------------
- * $Id: Assembler.h,v 1.19 2000/11/13 14:40:36 simonmar Exp $
+ * $Id: Assembler.h,v 1.20 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team 1994-1998.
*
/* ----------------------------------------------------------------------------
- * $Id: ClosureMacros.h,v 1.28 2000/11/13 14:40:36 simonmar Exp $
+ * $Id: ClosureMacros.h,v 1.29 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#endif
/* -----------------------------------------------------------------------------
- Fixed Header Size
-
- The compiler tries to abstract away from the actual value of this
- constant.
- -------------------------------------------------------------------------- */
-
-#define _FHS sizeof(StgHeader)
-
-/* -----------------------------------------------------------------------------
Info tables are slammed up against the entry code, and the label
for the info table is at the *end* of the table itself. This
inline function adjusts an info pointer to point to the beginning
#endif
/* -----------------------------------------------------------------------------
- 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
-
-
-#ifdef TEXT_BEFORE_HEAP
-# define HEAP_ALLOCED(x) IS_USER_PTR(x)
-#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.
-
- ToDo: in the combined Hugs-GHC system, the following are but crude
- approximations. This absolutely has to be fixed.
- -------------------------------------------------------------------------- */
-
-#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
-#else
-# define IS_HUGS_CONSTR_INFO(info) 0 /* ToDo: more than mildly bogus */
-#endif
-
-#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 BCO_sizeW ( unsigned int p, unsigned int np, unsigned int is )
-{ return sizeofW(StgBCO) + p + np + (is+sizeof(StgWord)-1)/sizeof(StgWord); }
-
-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; }
-
-static __inline__ StgWord bco_sizeW( StgBCO* bco )
-{ return BCO_sizeW(bco->n_ptrs,bco->n_words,bco->n_instrs); }
-
-static __inline__ StgWord tso_sizeW ( StgTSO *tso )
-{ return TSO_STRUCT_SIZEW + tso->stack_size; }
-
-/* -----------------------------------------------------------------------------
Macros for building closures
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
- * $Id: HsFFI.h,v 1.10 2000/11/14 14:47:23 simonmar Exp $
+ * $Id: HsFFI.h,v 1.11 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team, 2000
*
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Linker.h,v 1.2 2000/12/04 12:31:20 simonmar Exp $
+ *
+ * (c) The GHC Team, 2000
+ *
+ * RTS Object Linker
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef LINKER_H
+#define LINKER_H
+
+/* initialize the object linker */
+void initLinker( void );
+
+/* lookup a symbol in the hash table */
+void *lookupSymbol( char *lbl );
+
+/* delete an object from the pool */
+HsInt unloadObj( char *path );
+
+/* add an obj (populate the global symbol table, but don't resolve yet) */
+HsInt loadObj( char *path );
+
+/* resolve all the currently unlinked objects in memory */
+HsInt resolveObjs( void );
+
+#endif /* LINKER_H */
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.h,v 1.67 2000/11/13 14:40:36 simonmar Exp $
+ * $Id: PrimOps.h,v 1.68 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
} while (again); \
} while (0)
-#define indexWordOffClosurezh(r,a,i) \
- do { StgClosure* tmp = (StgClosure*)(a); \
- CHASE_INDIRECTIONS(tmp); \
- r = ((W_ *)tmp)[i]; \
+#define indexWordOffClosurezh(r,a,i) \
+ do { StgClosure* tmp = (StgClosure*)(a); \
+ CHASE_INDIRECTIONS(tmp); \
+ r = ((P_)tmp)[i]; \
} while (0)
-#define indexPtrOffClosurezh(r,a,i) \
- do { StgClosure* tmp = (StgClosure*)(a); \
- CHASE_INDIRECTIONS(tmp); \
- r = ((P_ *)tmp)[i]; \
+#define indexDoubleOffClosurezh(r,a,i) \
+ do { StgClosure* tmp = (StgClosure*)(a); \
+ CHASE_INDIRECTIONS(tmp); \
+ r = PK_DBL(((P_)tmp + i); \
+ } while (0)
+
+#define indexPtrOffClosurezh(r,a,i) \
+ do { StgClosure* tmp = (StgClosure*)(a); \
+ CHASE_INDIRECTIONS(tmp); \
+ r = ((P_ *)tmp)[i]; \
+ } while (0) \
+
+#define setWordOffClosurezh(r,a,i,b) \
+ do { StgClosure* tmp = (StgClosure*)(a); \
+ CHASE_INDIRECTIONS(tmp); \
+ ((P_)tmp)[i] = b; \
+ r = (P_)tmp; \
} while (0)
+#define setDoubleOffClosurezh(r,a,i,b) \
+ do { StgClosure* tmp = (StgClosure*)(a); \
+ CHASE_INDIRECTIONS(tmp); \
+ ASSIGN_DBL((P_)tmp + i, b); \
+ r = (P_)tmp; \
+ } while (0)
+
+#define setPtrOffClosurezh(r,a,i,b) \
+ do { StgClosure* tmp = (StgClosure*)(a); \
+ CHASE_INDIRECTIONS(tmp); \
+ ((P_ *)tmp)[i] = b; \
+ r = (P_)tmp; \
+ } while (0)
+
+#else
+
#endif
/* -----------------------------------------------------------------------------
/* -----------------------------------------------------------------------------
- * $Id: SchedAPI.h,v 1.11 2000/11/13 14:40:36 simonmar Exp $
+ * $Id: SchedAPI.h,v 1.12 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team 1998
*
/* -----------------------------------------------------------------------------
- * $Id: Stg.h,v 1.33 2000/11/07 17:05:47 simonmar Exp $
+ * $Id: Stg.h,v 1.34 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* Runtime-system hooks */
#include "Hooks.h"
+#include "HsFFI.h"
+
/* Misc stuff without a home */
DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */
DLL_IMPORT_RTS extern int prog_argc;
/* -----------------------------------------------------------------------------
- * $Id: StgMacros.h,v 1.36 2000/11/13 14:40:36 simonmar Exp $
+ * $Id: StgMacros.h,v 1.37 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.h,v 1.22 2000/11/13 14:40:36 simonmar Exp $
+ * $Id: StgMiscClosures.h,v 1.23 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* -----------------------------------------------------------------------------
- * $Id: Updates.h,v 1.20 2000/11/13 14:40:36 simonmar Exp $
+ * $Id: Updates.h,v 1.21 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
indexPtrOffClosurezh
indexWordOffClosurezh
+ setPtrOffClosurezh
+ setWordOffClosurezh
reallyUnsafePtrEqualityzh
/* -----------------------------------------------------------------------------
- * $Id: Exception.h,v 1.3 2000/11/13 14:40:37 simonmar Exp $
+ * $Id: Exception.h,v 1.4 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
/* -----------------------------------------------------------------------------
- * $Id: Exception.hc,v 1.17 2000/11/14 12:53:29 simonmar Exp $
+ * $Id: Exception.hc,v 1.18 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.89 2000/11/20 11:19:21 simonmar Exp $
+ * $Id: GC.c,v 1.90 2000/12/04 12:31:20 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
#include "Sanity.h"
#include "GC.h"
#include "BlockAlloc.h"
+#include "MBlock.h"
#include "Main.h"
#include "ProfHeap.h"
#include "SchedAPI.h"
#if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
#endif
+#ifdef DEBUG
+ /* zero out the slop so that the sanity checker can tell
+ * where the next closure is.
+ */
+ {
+ StgInfoTable *info = get_itbl(bh);
+ nat np = info->layout.payload.ptrs, nw = info->layout.payload.nptrs, i;
+ for (i = np; i < np + nw; i++) {
+ ((StgClosure *)bh)->payload[i] = 0;
+ }
+ }
+#endif
SET_INFO(bh,&stg_BLACKHOLE_info);
}
}
/*-----------------------------------------------------------------------------
- * $Id: Hash.c,v 1.2 2000/10/06 15:34:29 simonmar Exp $
+ * $Id: Hash.c,v 1.3 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The AQUA Project, Glasgow University, 1995-1998
* (c) The GHC Team, 1999
/*-----------------------------------------------------------------------------
- * $Id: Hash.h,v 1.3 2000/10/06 15:34:29 simonmar Exp $
+ * $Id: Hash.h,v 1.4 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1999
*
/* -----------------------------------------------------------------------------
- * $Id: MBlock.c,v 1.18 2000/09/06 11:12:07 rrt Exp $
+ * $Id: MBlock.c,v 1.19 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
#include <windows.h>
#endif
-#if freebsd2_TARGET_OS || freebsd_TARGET_OS
-/* Executable is loaded from 0x0
- * Shared libraries are loaded at 0x2000000
- * Stack is at the top of the address space. The kernel probably owns
- * 0x8000000 onwards, so we'll pick 0x5000000.
- */
-#define ASK_FOR_MEM_AT 0x50000000
-
-#elif netbsd_TARGET_OS
-/* NetBSD i386 shared libs are at 0x40000000
- */
-#define ASK_FOR_MEM_AT 0x50000000
-#elif openbsd_TARGET_OS
-#define ASK_FOR_MEM_AT 0x50000000
-#elif linux_TARGET_OS
-/* Any ideas?
- */
-#define ASK_FOR_MEM_AT 0x50000000
-
-#elif solaris2_TARGET_OS
-/* guess */
-#define ASK_FOR_MEM_AT 0x50000000
-
-#elif osf3_TARGET_OS
-/* guess */
-#define ASK_FOR_MEM_AT 0x50000000
-
-#elif hpux_TARGET_OS
-/* guess */
-#define ASK_FOR_MEM_AT 0x50000000
-
-#elif _WIN32
-/* doesn't matter, we use a reserve/commit algorithm */
-
-#else
-#error Dont know where to get memory from on this architecture
-/* ToDo: memory locations on other architectures */
-#endif
-
lnat mblocks_allocated = 0;
void *
void *
getMBlocks(nat n)
{
- static caddr_t next_request = (caddr_t)ASK_FOR_MEM_AT;
+ static caddr_t next_request = (caddr_t)HEAP_BASE;
caddr_t ret;
lnat size = MBLOCK_SIZE * n;
/* -----------------------------------------------------------------------------
- * $Id: MBlock.h,v 1.6 1999/05/04 10:19:16 sof Exp $
+ * $Id: MBlock.h,v 1.7 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
extern void * getMBlock(void);
extern void * getMBlocks(nat n);
+
+#if freebsd2_TARGET_OS || freebsd_TARGET_OS
+/* Executable is loaded from 0x0
+ * Shared libraries are loaded at 0x2000000
+ * Stack is at the top of the address space. The kernel probably owns
+ * 0x8000000 onwards, so we'll pick 0x5000000.
+ */
+#define HEAP_BASE 0x50000000
+
+#elif netbsd_TARGET_OS
+/* NetBSD i386 shared libs are at 0x40000000
+ */
+#define HEAP_BASE 0x50000000
+#elif openbsd_TARGET_OS
+#define HEAP_BASE 0x50000000
+#elif linux_TARGET_OS
+/* Any ideas?
+ */
+#define HEAP_BASE 0x50000000
+
+#elif solaris2_TARGET_OS
+/* guess */
+#define HEAP_BASE 0x50000000
+
+#elif osf3_TARGET_OS
+/* guess */
+#define HEAP_BASE 0x50000000
+
+#elif hpux_TARGET_OS
+/* guess */
+#define HEAP_BASE 0x50000000
+
+#elif _WIN32
+/* doesn't matter, we use a reserve/commit algorithm */
+
+#else
+#error Dont know where to get memory from on this architecture
+/* ToDo: memory locations on other architectures */
+#endif
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.59 2000/11/16 12:49:05 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.60 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
/* -----------------------------------------------------------------------------
- * $Id: ProfHeap.c,v 1.18 2000/11/13 14:40:37 simonmar Exp $
+ * $Id: ProfHeap.c,v 1.19 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.22 2000/11/13 14:40:37 simonmar Exp $
+ * $Id: RtsAPI.c,v 1.23 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.33 2000/11/01 11:41:47 simonmar Exp $
+ * $Id: RtsFlags.c,v 1.34 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The AQUA Project, Glasgow University, 1994-1997
* (c) The GHC Team, 1998-1999
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.28 2000/11/01 11:41:47 simonmar Exp $
+ * $Id: RtsFlags.h,v 1.29 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.44 2000/11/01 11:41:47 simonmar Exp $
+ * $Id: RtsStartup.c,v 1.45 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
/* -----------------------------------------------------------------------------
- * $Id: Sanity.c,v 1.22 2000/11/13 14:40:37 simonmar Exp $
+ * $Id: Sanity.c,v 1.23 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* skip over slop */
while (p < bd->free &&
- (*p == 0 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; }
+ (*p < 0x1000 || !LOOKS_LIKE_GHC_INFO((void*)*p))) { p++; }
}
bd = bd->link;
if (bd != NULL) {
/* ---------------------------------------------------------------------------
- * $Id: Schedule.c,v 1.82 2000/11/13 14:42:16 simonmar Exp $
+ * $Id: Schedule.c,v 1.83 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
/* -----------------------------------------------------------------------------
- * $Id: Schedule.h,v 1.20 2000/11/13 14:40:37 simonmar Exp $
+ * $Id: Schedule.h,v 1.21 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
/* -----------------------------------------------------------------------------
- * $Id: Stats.c,v 1.21 2000/07/17 15:15:40 rrt Exp $
+ * $Id: Stats.c,v 1.22 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
}
fprintf(stderr,"\n");
}
+
+/* -----------------------------------------------------------------------------
+ Stats available via a programmatic interface, so eg. GHCi can time
+ each compilation and expression evaluation.
+ -------------------------------------------------------------------------- */
+
+extern HsInt getAllocations( void )
+{ return (HsInt)(total_allocated * sizeof(W_)); }
/* -----------------------------------------------------------------------------
- * $Id: Stats.h,v 1.8 1999/11/09 15:46:58 simonmar Exp $
+ * $Id: Stats.h,v 1.9 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
extern void stat_describe_gens(void);
extern double mut_user_time_during_GC(void);
extern double mut_user_time(void);
+
+extern HsInt getAllocations( void );
/* -----------------------------------------------------------------------------
- * $Id: StgCRun.c,v 1.22 2000/11/13 14:53:27 simonmar Exp $
+ * $Id: StgCRun.c,v 1.23 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
StgThreadReturnCode
StgRun(StgFunPtr f, StgRegTable *basereg) {
- StgChar space[RESERVED_C_STACK_BYTES];
+ unsigned char space[RESERVED_C_STACK_BYTES];
+#if 0
+ register void *i7 __asm__("%i7");
+ ((void **)(space))[100] = i7;
+#endif
f();
__asm__ volatile (
".align 4\n"
/* -----------------------------------------------------------------------------
- * $Id: StgMiscClosures.hc,v 1.51 2000/11/14 12:49:57 simonmar Exp $
+ * $Id: StgMiscClosures.hc,v 1.52 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
/* Since this stuff is ostensibly in some other module, we need
to supply an __init_ function.
*/
-EF_(__init_MCIzumakezuconstr);
+EXTFUN(__init_MCIzumakezuconstr);
START_MOD_INIT(__init_MCIzumakezuconstr)
END_MOD_INIT()
INFO_TABLE(mci_make_constr_info, mci_make_constr_entry, 0,0,FUN_STATIC,static,EF_,0,0);
+INFO_TABLE(mci_make_constr0_info, mci_make_constr0_entry, 0,0,FUN_STATIC,static,EF_,0,0);
INFO_TABLE(mci_make_constrI_info, mci_make_constrI_entry, 0,0,FUN_STATIC,static,EF_,0,0);
INFO_TABLE(mci_make_constrP_info, mci_make_constrP_entry, 0,0,FUN_STATIC,static,EF_,0,0);
INFO_TABLE(mci_make_constrPP_info, mci_make_constrPP_entry, 0,0,FUN_STATIC,static,EF_,0,0);
mci_make_constr_info,0,,EI_)
,{ /* payload */ }
};
+SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstr0_closure,
+ mci_make_constr0_info,0,,EI_)
+ ,{ /* payload */ }
+};
SET_STATIC_HDR(MCIzumakezuconstr_mcizumakezuconstrI_closure,
mci_make_constrI_info,0,,EI_)
,{ /* payload */ }
/* Make a constructor with no args. */
-STGFUN(mci_make_constr_entry)
+STGFUN(mci_make_constr0_entry)
{
nat size, np, nw;
StgClosure* con;
Sp = Sp +2; /* Zap the Addr# arg */
R1.cl = con;
- JMP_(ENTRY_CODE(GET_INFO(R1.cl)));
+ JMP_(GET_ENTRY(R1.cl));
FE_
}
FE_
}
-#if 0
/* It would be nice if this worked, but it doesn't. Yet. */
STGFUN(mci_make_constr_entry)
{
- nat size, np, nw_heap, nw_really, w;
+ nat size, np, nw_heap, nw_really, i;
StgClosure* con;
StgInfoTable* itbl;
- W_* r;
FB_
- itbl = ((StgInfoTable**)Sp)[0];
-STGCALL3(fprintf,stderr,"mmc: itbl = %d\n",itbl);
-
-STGCALL3(fprintf,stderr,"mmc: sp-4 = %d\n", ((W_*)Sp)[-4] );
-STGCALL3(fprintf,stderr,"mmc: sp-3 = %d\n", ((W_*)Sp)[-3] );
-STGCALL3(fprintf,stderr,"mmc: sp-2 = %d\n", ((W_*)Sp)[-2] );
-STGCALL3(fprintf,stderr,"mmc: sp-1 = %d\n", ((W_*)Sp)[-1] );
-STGCALL3(fprintf,stderr,"mmc: sp+0 = %d\n", ((W_*)Sp)[0] );
-STGCALL3(fprintf,stderr,"mmc: sp+1 = %d\n", ((W_*)Sp)[1] );
-STGCALL3(fprintf,stderr,"mmc: sp+2 = %d\n", ((W_*)Sp)[2] );
-STGCALL3(fprintf,stderr,"mmc: sp+3 = %d\n", ((W_*)Sp)[3] );
-STGCALL3(fprintf,stderr,"mmc: sp+4 = %d\n", ((W_*)Sp)[4] );
- np = itbl->layout.payload.ptrs;
- nw_really = itbl->layout.payload.nptrs;
- nw_heap = stg_max(nw_really, MIN_NONUPD_SIZE-np);
+ /* Sp[0] should be the tag for the itbl */
+ itbl = ((StgInfoTable**)Sp)[1];
+
+ np = INFO_PTR_TO_STRUCT(itbl)->layout.payload.ptrs;
+ nw_really = INFO_PTR_TO_STRUCT(itbl)->layout.payload.nptrs;
+
+ nw_heap = stg_max((int)nw_really, MIN_NONUPD_SIZE-np);
size = CONSTR_sizeW( np, nw_heap );
- /* The total number of words to copy off the stack is np + nw.
- That doesn't include tag words, tho.
- */
+#if 0
+ fprintf(stderr, "np = %d, nw_really = %d, nw_heap = %d, size = %d\n",
+ np, nw_really, nw_heap, size);
+#endif
+
HP_CHK_GEN_TICKY(size, NO_PTRS, mci_make_constr_entry, );
TICK_ALLOC_PRIM(sizeofW(StgHeader), size-sizeofW(StgHeader), 0);
CCS_ALLOC(CCCS,size); /* ccs prof */
con = (StgClosure*)(Hp + 1 - size);
SET_HDR(con, itbl,CCCS);
- /* Copy into the closure. */
- w = 0;
- r = Sp+1;
- while (1) {
- if (w == np + nw) break;
- ASSERT(w < np + nw);
- if (IS_ARG_TAG(*r)) {
- nat n = *r++;
- for (; n > 0; n--)
- con->payload[w++] = (StgClosure*)(*r++);
- } else {
- con->payload[w++] = (StgClosure*)(*r++);
- }
- ASSERT((P_)r <= (P_)Su);
+ /* set the pointer fields */
+ for (i = 0; i < np; i++) {
+ con->payload[i] = &stg_dummy_ret_closure;
}
- /* Remove all the args we've used. */
- Sp = r;
+ Sp += 2;
R1.cl = con;
- JMP_(ENTRY_CODE(R1.cl));
+ JMP_(GET_ENTRY(R1.cl));
FE_
}
-#endif
#endif /* GHCI */
/* -----------------------------------------------------------------------------
- * $Id: StgStdThunks.hc,v 1.13 2000/11/14 12:51:51 simonmar Exp $
+ * $Id: StgStdThunks.hc,v 1.14 2000/12/04 12:31:21 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
/* -----------------------------------------------------------------------------
- * $Id: Storage.c,v 1.28 2000/11/13 14:40:37 simonmar Exp $
+ * $Id: Storage.c,v 1.29 2000/12/04 12:31:22 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* -----------------------------------------------------------------------------
- * $Id: Storage.h,v 1.17 2000/11/13 14:40:37 simonmar Exp $
+ * $Id: Storage.h,v 1.18 2000/12/04 12:31:22 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
}
}
+#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); \
+ SET_INFO(p1,&stg_IND_info); \
TICK_UPD_NEW_IND(); \
} else { \
((StgIndOldGen *)p1)->indirectee = p2; \
- if (info != &stg_BLACKHOLE_BQ_info) { \
+ if (info != &stg_BLACKHOLE_BQ_info) { \
((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list; \
bd->gen->mut_once_list = (StgMutClosure *)p1; \
} \
- SET_INFO(p1,&stg_IND_OLDGEN_info); \
+ 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; \
+ } \
+ } \
+ ((StgIndOldGen *)p1)->mut_link = bd->gen->mut_once_list; \
+ bd->gen->mut_once_list = (StgMutClosure *)p1; \
+ } \
+ ((StgIndOldGen *)p1)->indirectee = p2; \
+ SET_INFO(p1,&stg_IND_OLDGEN_info); \
+ TICK_UPD_OLD_IND(); \
+ } \
+ }
+#endif
#if defined(TICKY_TICKY) || defined(PROFILING)
static inline void
/* -----------------------------------------------------------------------------
The CAF table - used to let us revert CAFs
-
-------------------------------------------------------------------------- */
#if defined(INTERPRETER)
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 BCO_sizeW ( unsigned int p, unsigned int np, unsigned int is )
+{ return sizeofW(StgBCO) + p + np + (is+sizeof(StgWord)-1)/sizeof(StgWord); }
+
+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; }
+
+static __inline__ StgWord bco_sizeW( StgBCO* bco )
+{ return BCO_sizeW(bco->n_ptrs,bco->n_words,bco->n_instrs); }
+
+static __inline__ StgWord tso_sizeW ( StgTSO *tso )
+{ return TSO_STRUCT_SIZEW + tso->stack_size; }
+
#endif STORAGE_H
/* -----------------------------------------------------------------------------
- * $Id: StoragePriv.h,v 1.12 2000/11/13 14:40:37 simonmar Exp $
+ * $Id: StoragePriv.h,v 1.13 2000/12/04 12:31:22 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
extern void checkSanity(nat N);
#endif
+/*
+ * These three are used by the garbage collector when we have
+ * dynamically-linked object modules. (see ClosureMacros.h,
+ * IS_CODE_PTR etc.).
+ * Defined in Linker.c.
+ */
+int is_dynamically_loaded_code_or_rodata_ptr ( char* p );
+int is_dynamically_loaded_rwdata_ptr ( char* p );
+int is_not_dynamically_loaded_ptr ( char* p );
+
#endif /* STORAGEPRIV_H */
/* -----------------------------------------------------------------------------
- * $Id: Updates.hc,v 1.30 2000/11/14 12:47:38 simonmar Exp $
+ * $Id: Updates.hc,v 1.31 2000/12/04 12:31:22 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
/* -----------------------------------------------------------------------------
- * $Id: Weak.c,v 1.16 2000/11/13 14:40:37 simonmar Exp $
+ * $Id: Weak.c,v 1.17 2000/12/04 12:31:22 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
projects / ghc-hetmet.git / commitdiff