From 723545930025a24708a8a0923435c95cc7f058c9 Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Tue, 26 Jan 1999 16:16:35 +0000
Subject: [PATCH] [project @ 1999-01-26 16:16:19 by simonm] - Add specialised
closure types (CONSTR_p_n, THUNK_p_n, FUN_p_n) - Add -T<n> RTS flag to
specify the number of steps in younger generations.
---
ghc/compiler/absCSyn/PprAbsC.lhs | 4 +-
ghc/compiler/codeGen/CgHeapery.lhs | 6 +-
ghc/compiler/codeGen/ClosureInfo.lhs | 44 ++++++--
ghc/compiler/codeGen/SMRep.lhs | 33 +++---
ghc/compiler/main/Constants.lhs | 8 ++
ghc/includes/ClosureTypes.h | 109 ++++++++++---------
ghc/includes/Constants.h | 8 +-
ghc/includes/InfoTables.h | 35 +++++-
ghc/rts/GC.c | 155 ++++++++++++++++++++++-----
ghc/rts/PrimOps.hc | 3 +-
ghc/rts/RtsFlags.c | 13 ++-
ghc/rts/RtsFlags.h | 3 +-
ghc/rts/Storage.c | 19 ++--
13 files changed, 317 insertions(+), 123 deletions(-)
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index d0b396eeec1a..63646ce9185b 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -43,7 +43,7 @@ import Const ( Literal(..) )
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
-import SMRep ( getSMRepStr )
+import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
addOneToUniqSet, UniqSet
@@ -450,7 +450,7 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _
else empty,
type_str ]
- type_str = text (getSMRepStr (closureSMRep cl_info))
+ type_str = pprSMRep (closureSMRep cl_info)
pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index f1a0ef25c979..c3839985dcde 100644
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.12 1999/01/21 10:31:56 simonm Exp $
+% $Id: CgHeapery.lhs,v 1.13 1999/01/26 16:16:33 simonm Exp $
%
\section[CgHeapery]{Heap management functions}
@@ -21,7 +21,7 @@ import CLabel
import CgMonad
import CgStackery ( getFinalStackHW, mkTaggedStkAmodes, mkTagAssts )
-import SMRep ( fixedHdrSize, getSMRepStr )
+import SMRep ( fixedHdrSize )
import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgUsages ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
initHeapUsage
@@ -446,7 +446,6 @@ allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
-- GENERATE CC PROFILING MESSAGES
costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
- -- CLitLit (_PK_ type_str) IntRep] -- not necessary? --SDM
`thenC`
-- BUMP THE VIRTUAL HEAP POINTER
@@ -457,7 +456,6 @@ allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
where
closure_size = closureSize closure_info
slop_size = slopSize closure_info
- type_str = getSMRepStr (closureSMRep closure_info)
-- Avoid hanging on to anything in the CC field when we're not profiling.
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 9e99002671de..f64b8dccc9ee 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.32 1998/12/18 17:40:54 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.33 1999/01/26 16:16:33 simonm Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
@@ -59,7 +59,8 @@ import AbsCSyn ( MagicId, node, VirtualHeapOffset, HeapOffset )
import StgSyn
import CgMonad
-import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
+import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
+ mAX_SPEC_FUN_SIZE, mAX_SPEC_THUNK_SIZE, mAX_SPEC_CONSTR_SIZE )
import CgRetConv ( assignRegs )
import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
mkInfoTableLabel,
@@ -393,18 +394,19 @@ layOutStaticClosure name kind_fn things lf_info
(tot_wds, -- #ptr_wds + #nonptr_wds
ptr_wds, -- #ptr_wds
things_w_offsets) = mkVirtHeapOffsets (StaticRep bot bot bot) kind_fn things
+
-- constructors with no pointer fields will definitely be NOCAF things.
-- this is a compromise until we can generate both kinds of constructor
-- (a normal static kind and the NOCAF_STATIC kind).
closure_type = case lf_info of
LFCon _ _ | ptr_wds == 0 -> CONSTR_NOCAF
- _ -> getClosureType lf_info
+ _ -> getStaticClosureType lf_info
bot = panic "layoutStaticClosure"
layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> ClosureInfo
layOutStaticNoFVClosure name lf_info
- = MkClosureInfo name lf_info (StaticRep 0 0 (getClosureType lf_info))
+ = MkClosureInfo name lf_info (StaticRep 0 0 (getStaticClosureType lf_info))
\end{code}
%************************************************************************
@@ -422,24 +424,48 @@ chooseDynSMRep
chooseDynSMRep lf_info tot_wds ptr_wds
= let
nonptr_wds = tot_wds - ptr_wds
- closure_type = getClosureType lf_info
+ closure_type = getClosureType tot_wds ptr_wds nonptr_wds lf_info
in
case lf_info of
LFTuple _ True -> ConstantRep
LFCon _ True -> ConstantRep
_ -> GenericRep ptr_wds nonptr_wds closure_type
-getClosureType :: LambdaFormInfo -> ClosureType
-getClosureType lf_info =
+getStaticClosureType :: LambdaFormInfo -> ClosureType
+getStaticClosureType lf_info =
case lf_info of
LFCon con True -> CONSTR_NOCAF
- LFCon con False -> CONSTR
+ LFCon con False -> CONSTR
LFReEntrant _ _ _ _ -> FUN
LFTuple _ _ -> CONSTR
LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR
LFThunk _ _ _ _ _ -> THUNK
_ -> panic "getClosureType"
- -- ToDo: could be anything else here?
+
+getClosureType :: Int -> Int -> Int -> LambdaFormInfo -> ClosureType
+getClosureType tot_wds ptrs nptrs lf_info =
+ case lf_info of
+ LFCon con True -> CONSTR_NOCAF
+
+ LFCon con False
+ | tot_wds > 0 && tot_wds <= mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n ptrs nptrs
+ | otherwise -> CONSTR
+
+ LFReEntrant _ _ _ _
+ | tot_wds > 0 && tot_wds <= mAX_SPEC_FUN_SIZE -> FUN_p_n ptrs nptrs
+ | otherwise -> FUN
+
+ LFTuple _ _
+ | tot_wds > 0 && tot_wds <= mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n ptrs nptrs
+ | otherwise -> CONSTR
+
+ LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR
+
+ LFThunk _ _ _ _ _
+ | tot_wds > 0 && tot_wds <= mAX_SPEC_THUNK_SIZE -> THUNK_p_n ptrs nptrs
+ | otherwise -> THUNK
+
+ _ -> panic "getClosureType"
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs
index fe463172c6a9..9a36a339b5fe 100644
--- a/ghc/compiler/codeGen/SMRep.lhs
+++ b/ghc/compiler/codeGen/SMRep.lhs
@@ -10,7 +10,7 @@ Other modules should access this info through ClosureInfo.
module SMRep (
SMRep(..), ClosureType(..),
isConstantRep, isStaticRep,
- fixedHdrSize, arrHdrSize, fixedItblSize, getSMRepStr, getClosureTypeStr
+ fixedHdrSize, arrHdrSize, fixedItblSize, pprSMRep
#ifndef OMIT_NATIVE_CODEGEN
, getSMRepClosureTypeInt
@@ -67,9 +67,12 @@ data SMRep
data ClosureType
= CONSTR
+ | CONSTR_p_n Int Int
| CONSTR_NOCAF
| FUN
+ | FUN_p_n Int Int
| THUNK
+ | THUNK_p_n Int Int
| THUNK_SELECTOR
deriving (Eq,Ord)
@@ -135,18 +138,22 @@ instance Text SMRep where
ConstantRep -> "")
instance Outputable SMRep where
- ppr rep = text (show rep)
-
-getSMRepStr (GenericRep _ _ t) = getClosureTypeStr t
-getSMRepStr (StaticRep _ _ t) = getClosureTypeStr t ++ "_STATIC"
-getSMRepStr ConstantRep = "CONSTR_NOCAF_STATIC"
-getSMRepStr BlackHoleRep = "BLACKHOLE"
-
-getClosureTypeStr CONSTR = "CONSTR"
-getClosureTypeStr CONSTR_NOCAF = "CONSTR_NOCAF"
-getClosureTypeStr FUN = "FUN"
-getClosureTypeStr THUNK = "THUNK"
-getClosureTypeStr THUNK_SELECTOR = "THUNK_SELECTOR"
+ ppr rep = pprSMRep rep
+
+pprSMRep :: SMRep -> SDoc
+pprSMRep (GenericRep _ _ t) = pprClosureType t
+pprSMRep (StaticRep _ _ t) = pprClosureType t <> ptext SLIT("_STATIC")
+pprSMRep ConstantRep = ptext SLIT("CONSTR_NOCAF_STATIC")
+pprSMRep BlackHoleRep = ptext SLIT("BLACKHOLE")
+
+pprClosureType CONSTR = ptext SLIT("CONSTR")
+pprClosureType (CONSTR_p_n p n) = ptext SLIT("CONSTR_") <> int p <> char '_' <> int n
+pprClosureType CONSTR_NOCAF = ptext SLIT("CONSTR_NOCAF")
+pprClosureType FUN = ptext SLIT("FUN")
+pprClosureType (FUN_p_n p n) = ptext SLIT("FUN_") <> int p <> char '_' <> int n
+pprClosureType THUNK = ptext SLIT("THUNK")
+pprClosureType (THUNK_p_n p n) = ptext SLIT("THUNK_") <> int p <> char '_' <> int n
+pprClosureType THUNK_SELECTOR = ptext SLIT("THUNK_SELECTOR")
#ifndef OMIT_NATIVE_CODEGEN
getSMRepClosureTypeInt :: SMRep -> Int
diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs
index c0bf4872a69f..d30a976b7b83 100644
--- a/ghc/compiler/main/Constants.lhs
+++ b/ghc/compiler/main/Constants.lhs
@@ -18,6 +18,9 @@ module Constants (
mAX_CONTEXT_REDUCTION_DEPTH,
mAX_TUPLE_SIZE,
+ mAX_SPEC_THUNK_SIZE,
+ mAX_SPEC_FUN_SIZE,
+ mAX_SPEC_CONSTR_SIZE,
mAX_SPEC_SELECTEE_SIZE,
mAX_SPEC_AP_SIZE,
@@ -107,6 +110,11 @@ uNFOLDING_KEENESS_FACTOR = ( 2.0 :: Float)
\begin{code}
+-- specialised fun/thunk/constr closure types
+mAX_SPEC_THUNK_SIZE = (MAX_SPEC_THUNK_SIZE :: Int)
+mAX_SPEC_FUN_SIZE = (MAX_SPEC_FUN_SIZE :: Int)
+mAX_SPEC_CONSTR_SIZE = (MAX_SPEC_CONSTR_SIZE :: Int)
+
-- pre-compiled thunk types
mAX_SPEC_SELECTEE_SIZE = (MAX_SPEC_SELECTEE_SIZE :: Int)
mAX_SPEC_AP_SIZE = (MAX_SPEC_AP_SIZE :: Int)
diff --git a/ghc/includes/ClosureTypes.h b/ghc/includes/ClosureTypes.h
index 9ae6332936dc..24d41896953c 100644
--- a/ghc/includes/ClosureTypes.h
+++ b/ghc/includes/ClosureTypes.h
@@ -1,5 +1,5 @@
/* ----------------------------------------------------------------------------
- * $Id: ClosureTypes.h,v 1.6 1999/01/26 11:12:55 simonm Exp $
+ * $Id: ClosureTypes.h,v 1.7 1999/01/26 16:16:19 simonm Exp $
*
* Closure Type Constants
*
@@ -13,52 +13,65 @@
/* Object tag 0 raises an internal error */
#define INVALID_OBJECT 0
#define CONSTR 1
-/* #define CONSTR_p_np */
-#define CONSTR_INTLIKE 2
-#define CONSTR_CHARLIKE 3
-#define CONSTR_STATIC 4
-#define CONSTR_NOCAF_STATIC 5
-#define FUN 6
-#define FUN_STATIC 7
-#define THUNK 8
-/* #define THUNK_p_np */
-#define THUNK_STATIC 9
-#define THUNK_SELECTOR 10
-#define BCO 11
-#define AP_UPD 12
-#define PAP 13
-#define IND 14
-#define IND_OLDGEN 15
-#define IND_PERM 16
-#define IND_OLDGEN_PERM 17
-#define IND_STATIC 18
-#define CAF_UNENTERED 19
-#define CAF_ENTERED 20
-#define CAF_BLACKHOLE 21
-#define RET_BCO 22
-#define RET_SMALL 23
-#define RET_VEC_SMALL 24
-#define RET_BIG 25
-#define RET_VEC_BIG 26
-#define RET_DYN 27
-#define UPDATE_FRAME 28
-#define CATCH_FRAME 29
-#define STOP_FRAME 30
-#define SEQ_FRAME 31
-#define BLACKHOLE 32
-#define BLACKHOLE_BQ 33
-#define MVAR 34
-#define ARR_WORDS 35
-#define MUT_ARR_WORDS 36
-#define MUT_ARR_PTRS 37
-#define MUT_ARR_PTRS_FROZEN 38
-#define MUT_VAR 49
-#define WEAK 40
-#define FOREIGN 41
-#define STABLE_NAME 42
-#define TSO 43
-#define BLOCKED_FETCH 44
-#define FETCH_ME 45
-#define EVACUATED 46
+#define CONSTR_1_0 2
+#define CONSTR_0_1 3
+#define CONSTR_2_0 4
+#define CONSTR_1_1 5
+#define CONSTR_0_2 6
+#define CONSTR_INTLIKE 7
+#define CONSTR_CHARLIKE 8
+#define CONSTR_STATIC 9
+#define CONSTR_NOCAF_STATIC 10
+#define FUN 11
+#define FUN_1_0 12
+#define FUN_0_1 13
+#define FUN_2_0 14
+#define FUN_1_1 15
+#define FUN_0_2 16
+#define FUN_STATIC 17
+#define THUNK 18
+#define THUNK_1_0 19
+#define THUNK_0_1 20
+#define THUNK_2_0 21
+#define THUNK_1_1 22
+#define THUNK_0_2 23
+#define THUNK_STATIC 24
+#define THUNK_SELECTOR 25
+#define BCO 26
+#define AP_UPD 27
+#define PAP 28
+#define IND 29
+#define IND_OLDGEN 30
+#define IND_PERM 31
+#define IND_OLDGEN_PERM 32
+#define IND_STATIC 33
+#define CAF_UNENTERED 34
+#define CAF_ENTERED 35
+#define CAF_BLACKHOLE 36
+#define RET_BCO 37
+#define RET_SMALL 38
+#define RET_VEC_SMALL 39
+#define RET_BIG 40
+#define RET_VEC_BIG 41
+#define RET_DYN 42
+#define UPDATE_FRAME 43
+#define CATCH_FRAME 44
+#define STOP_FRAME 45
+#define SEQ_FRAME 46
+#define BLACKHOLE 47
+#define BLACKHOLE_BQ 48
+#define MVAR 49
+#define ARR_WORDS 50
+#define MUT_ARR_WORDS 51
+#define MUT_ARR_PTRS 52
+#define MUT_ARR_PTRS_FROZEN 53
+#define MUT_VAR 54
+#define WEAK 55
+#define FOREIGN 56
+#define STABLE_NAME 57
+#define TSO 58
+#define BLOCKED_FETCH 59
+#define FETCH_ME 60
+#define EVACUATED 61
#endif CLOSURETYPES_H
diff --git a/ghc/includes/Constants.h b/ghc/includes/Constants.h
index d97016044d4f..fbb3dbf4ea31 100644
--- a/ghc/includes/Constants.h
+++ b/ghc/includes/Constants.h
@@ -1,5 +1,5 @@
/* ----------------------------------------------------------------------------
- * $Id: Constants.h,v 1.3 1999/01/21 10:31:41 simonm Exp $
+ * $Id: Constants.h,v 1.4 1999/01/26 16:16:20 simonm Exp $
*
* Constants
*
@@ -88,6 +88,12 @@
#define MAX_SPEC_AP_SIZE 8
+/* Specialised FUN/THUNK/CONSTR closure types */
+
+#define MAX_SPEC_THUNK_SIZE 2
+#define MAX_SPEC_FUN_SIZE 2
+#define MAX_SPEC_CONSTR_SIZE 2
+
/* -----------------------------------------------------------------------------
Update Frame Layout
-------------------------------------------------------------------------- */
diff --git a/ghc/includes/InfoTables.h b/ghc/includes/InfoTables.h
index fb1640daba42..9c71d6172db5 100644
--- a/ghc/includes/InfoTables.h
+++ b/ghc/includes/InfoTables.h
@@ -1,5 +1,5 @@
/* ----------------------------------------------------------------------------
- * $Id: InfoTables.h,v 1.6 1999/01/26 11:12:55 simonm Exp $
+ * $Id: InfoTables.h,v 1.7 1999/01/26 16:16:21 simonm Exp $
*
* Info Tables
*
@@ -85,18 +85,32 @@ typedef struct {
typedef enum {
INVALID_OBJECT /* Object tag 0 raises an internal error */
+
, CONSTR
- /* CONSTR_p_np */
+ , CONSTR_1_0
+ , CONSTR_0_1
+ , CONSTR_2_0
+ , CONSTR_1_1
+ , CONSTR_0_2
, CONSTR_INTLIKE
, CONSTR_CHARLIKE
, CONSTR_STATIC
, CONSTR_NOCAF_STATIC
, FUN
+ , FUN_1_0
+ , FUN_0_1
+ , FUN_2_0
+ , FUN_1_1
+ , FUN_0_2
, FUN_STATIC
, THUNK
- /* THUNK_p_np */
+ , THUNK_1_0
+ , THUNK_0_1
+ , THUNK_2_0
+ , THUNK_1_1
+ , THUNK_0_2
, THUNK_STATIC
, THUNK_SELECTOR
@@ -176,11 +190,26 @@ typedef enum {
/* HNF BTM NS STA THU MUT UPT SRT */
#define FLAGS_CONSTR (_HNF| _NS )
+#define FLAGS_CONSTR_1_0 (_HNF| _NS )
+#define FLAGS_CONSTR_0_1 (_HNF| _NS )
+#define FLAGS_CONSTR_2_0 (_HNF| _NS )
+#define FLAGS_CONSTR_1_1 (_HNF| _NS )
+#define FLAGS_CONSTR_0_2 (_HNF| _NS )
#define FLAGS_CONSTR_STATIC (_HNF| _NS|_STA )
#define FLAGS_CONSTR_NOCAF_STATIC (_HNF| _NS|_STA )
#define FLAGS_FUN (_HNF| _NS| _SRT )
+#define FLAGS_FUN_1_0 (_HNF| _NS )
+#define FLAGS_FUN_0_1 (_HNF| _NS )
+#define FLAGS_FUN_2_0 (_HNF| _NS )
+#define FLAGS_FUN_1_1 (_HNF| _NS )
+#define FLAGS_FUN_0_2 (_HNF| _NS )
#define FLAGS_FUN_STATIC (_HNF| _NS|_STA| _SRT )
#define FLAGS_THUNK ( _BTM| _THU| _SRT )
+#define FLAGS_THUNK_1_0 ( _BTM| _THU| _SRT )
+#define FLAGS_THUNK_0_1 ( _BTM| _THU| _SRT )
+#define FLAGS_THUNK_2_0 ( _BTM| _THU| _SRT )
+#define FLAGS_THUNK_1_1 ( _BTM| _THU| _SRT )
+#define FLAGS_THUNK_0_2 ( _BTM| _THU| _SRT )
#define FLAGS_THUNK_STATIC ( _BTM| _STA|_THU| _SRT )
#define FLAGS_THUNK_SELECTOR ( _BTM| _THU| _SRT )
#define FLAGS_BCO (_HNF| _NS )
diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c
index 619aa5c6f62d..fa52ddaa9042 100644
--- a/ghc/rts/GC.c
+++ b/ghc/rts/GC.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.19 1999/01/26 11:12:43 simonm Exp $
+ * $Id: GC.c,v 1.20 1999/01/26 16:16:22 simonm Exp $
*
* Two-space garbage collector
*
@@ -807,7 +807,7 @@ MarkRoot(StgClosure *root)
return evacuate(root);
}
-static inline void addBlock(step *step)
+static void addBlock(step *step)
{
bdescr *bd = allocBlock();
bd->gen = step->gen;
@@ -828,9 +828,8 @@ static inline void addBlock(step *step)
}
static __inline__ StgClosure *
-copy(StgClosure *src, nat size, bdescr *bd)
+copy(StgClosure *src, nat size, step *step)
{
- step *step;
P_ to, from, dest;
/* Find out where we're going, using the handy "to" pointer in
@@ -838,7 +837,6 @@ copy(StgClosure *src, nat size, bdescr *bd)
* evacuate to an older generation, adjust it here (see comment
* by evacuate()).
*/
- step = bd->step->to;
if (step->gen->no < evac_gen) {
step = &generations[evac_gen].steps[0];
}
@@ -850,11 +848,12 @@ copy(StgClosure *src, nat size, bdescr *bd)
addBlock(step);
}
- dest = step->hp;
- step->hp += size;
- for(to = dest, from = (P_)src; size>0; --size) {
+ for(to = step->hp, from = (P_)src; size>0; --size) {
*to++ = *from++;
}
+
+ dest = step->hp;
+ step->hp = to;
return (StgClosure *)dest;
}
@@ -864,12 +863,10 @@ copy(StgClosure *src, nat size, bdescr *bd)
*/
static __inline__ StgClosure *
-copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, bdescr *bd)
+copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, step *step)
{
- step *step;
P_ dest, to, from;
- step = bd->step->to;
if (step->gen->no < evac_gen) {
step = &generations[evac_gen].steps[0];
}
@@ -878,12 +875,12 @@ copyPart(StgClosure *src, nat size_to_reserve, nat size_to_copy, bdescr *bd)
addBlock(step);
}
- dest = step->hp;
- step->hp += size_to_reserve;
- for(to = dest, from = (P_)src; size_to_copy>0; --size_to_copy) {
+ for(to = step->hp, from = (P_)src; size_to_copy>0; --size_to_copy) {
*to++ = *from++;
}
+ dest = step->hp;
+ step->hp += size_to_reserve;
return (StgClosure *)dest;
}
@@ -942,6 +939,7 @@ evacuate_large(StgPtr p, rtsBool mutable)
*/
if (bd->gen->no < evac_gen) {
failed_to_evac = rtsTrue;
+ TICK_GC_FAILED_PROMOTION();
}
return;
}
@@ -1039,6 +1037,7 @@ evacuate(StgClosure *q)
{
StgClosure *to;
bdescr *bd = NULL;
+ step *step;
const StgInfoTable *info;
loop:
@@ -1052,9 +1051,11 @@ loop:
if (bd->gen->no < evac_gen) {
/* nope */
failed_to_evac = rtsTrue;
+ TICK_GC_FAILED_PROMOTION();
}
return q;
}
+ step = bd->step->to;
}
/* make sure the info pointer is into text space */
@@ -1065,20 +1066,43 @@ loop:
switch (info -> type) {
case BCO:
- to = copy(q,bco_sizeW(stgCast(StgBCO*,q)),bd);
+ to = copy(q,bco_sizeW(stgCast(StgBCO*,q)),step);
upd_evacuee(q,to);
return to;
case MUT_VAR:
case MVAR:
- to = copy(q,sizeW_fromITBL(info),bd);
+ to = copy(q,sizeW_fromITBL(info),step);
upd_evacuee(q,to);
evacuate_mutable((StgMutClosure *)to);
return to;
case STABLE_NAME:
stable_ptr_table[((StgStableName *)q)->sn].keep = rtsTrue;
- to = copy(q,sizeofW(StgStableName),bd);
+ to = copy(q,sizeofW(StgStableName),step);
+ upd_evacuee(q,to);
+ return to;
+
+ case FUN_1_0:
+ case FUN_0_1:
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ to = copy(q,sizeofW(StgHeader)+1,step);
+ upd_evacuee(q,to);
+ return to;
+
+ case THUNK_1_0: /* here because of MIN_UPD_SIZE */
+ case THUNK_0_1:
+ case FUN_1_1:
+ case FUN_0_2:
+ case FUN_2_0:
+ case THUNK_1_1:
+ case THUNK_0_2:
+ case THUNK_2_0:
+ case CONSTR_1_1:
+ case CONSTR_0_2:
+ case CONSTR_2_0:
+ to = copy(q,sizeofW(StgHeader)+2,step);
upd_evacuee(q,to);
return to;
@@ -1091,18 +1115,18 @@ loop:
case CAF_ENTERED:
case WEAK:
case FOREIGN:
- to = copy(q,sizeW_fromITBL(info),bd);
+ to = copy(q,sizeW_fromITBL(info),step);
upd_evacuee(q,to);
return to;
case CAF_BLACKHOLE:
case BLACKHOLE:
- to = copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),bd);
+ to = copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
upd_evacuee(q,to);
return to;
case BLACKHOLE_BQ:
- to = copy(q,BLACKHOLE_sizeW(),bd);
+ to = copy(q,BLACKHOLE_sizeW(),step);
upd_evacuee(q,to);
evacuate_mutable((StgMutClosure *)to);
return to;
@@ -1116,6 +1140,11 @@ loop:
selectee_info = get_itbl(selectee);
switch (selectee_info->type) {
case CONSTR:
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ case CONSTR_2_0:
+ case CONSTR_1_1:
+ case CONSTR_0_2:
case CONSTR_STATIC:
{
StgNat32 offset = info->layout.selector_offset;
@@ -1137,6 +1166,7 @@ loop:
if (bd->evacuated) {
if (bd->gen->no < evac_gen) {
failed_to_evac = rtsTrue;
+ TICK_GC_FAILED_PROMOTION();
}
return q;
}
@@ -1165,6 +1195,11 @@ loop:
goto selector_loop;
case THUNK:
+ case THUNK_1_0:
+ case THUNK_0_1:
+ case THUNK_2_0:
+ case THUNK_1_1:
+ case THUNK_0_2:
case THUNK_STATIC:
case THUNK_SELECTOR:
/* aargh - do recursively???? */
@@ -1179,7 +1214,7 @@ loop:
barf("evacuate: THUNK_SELECTOR: strange selectee");
}
}
- to = copy(q,THUNK_SELECTOR_sizeW(),bd);
+ to = copy(q,THUNK_SELECTOR_sizeW(),step);
upd_evacuee(q,to);
return to;
@@ -1239,7 +1274,7 @@ loop:
case PAP:
/* these are special - the payload is a copy of a chunk of stack,
tagging and all. */
- to = copy(q,pap_sizeW(stgCast(StgPAP*,q)),bd);
+ to = copy(q,pap_sizeW(stgCast(StgPAP*,q)),step);
upd_evacuee(q,to);
return to;
@@ -1256,6 +1291,7 @@ loop:
if (Bdescr((P_)p)->gen->no < evac_gen) {
/* fprintf(stderr,"evac failed!\n");*/
failed_to_evac = rtsTrue;
+ TICK_GC_FAILED_PROMOTION();
}
}
return ((StgEvacuated*)q)->evacuee;
@@ -1270,7 +1306,7 @@ loop:
return q;
} else {
/* just copy the block */
- to = copy(q,size,bd);
+ to = copy(q,size,step);
upd_evacuee(q,to);
return to;
}
@@ -1286,7 +1322,7 @@ loop:
to = q;
} else {
/* just copy the block */
- to = copy(q,size,bd);
+ to = copy(q,size,step);
upd_evacuee(q,to);
if (info->type == MUT_ARR_PTRS) {
evacuate_mutable((StgMutClosure *)to);
@@ -1311,7 +1347,7 @@ loop:
* list it contains.
*/
} else {
- StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),bd);
+ StgTSO *new_tso = (StgTSO *)copy((StgClosure *)tso,tso_sizeW(tso),step);
diff = (StgPtr)new_tso - (StgPtr)tso; /* In *words* */
@@ -1482,6 +1518,54 @@ scavenge(step *step)
break;
}
+ case THUNK_2_0:
+ case FUN_2_0:
+ scavenge_srt(info);
+ case CONSTR_2_0:
+ ((StgClosure *)p)->payload[1] = evacuate(((StgClosure *)p)->payload[1]);
+ ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+ p += sizeofW(StgHeader) + 2;
+ break;
+
+ case THUNK_1_0:
+ scavenge_srt(info);
+ ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+ p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
+ break;
+
+ case FUN_1_0:
+ scavenge_srt(info);
+ case CONSTR_1_0:
+ ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+ p += sizeofW(StgHeader) + 1;
+ break;
+
+ case THUNK_0_1:
+ scavenge_srt(info);
+ p += sizeofW(StgHeader) + 2; /* MIN_UPD_SIZE */
+ break;
+
+ case FUN_0_1:
+ scavenge_srt(info);
+ case CONSTR_0_1:
+ p += sizeofW(StgHeader) + 1;
+ break;
+
+ case THUNK_0_2:
+ case FUN_0_2:
+ scavenge_srt(info);
+ case CONSTR_0_2:
+ p += sizeofW(StgHeader) + 2;
+ break;
+
+ case THUNK_1_1:
+ case FUN_1_1:
+ scavenge_srt(info);
+ case CONSTR_1_1:
+ ((StgClosure *)p)->payload[0] = evacuate(((StgClosure *)p)->payload[0]);
+ p += sizeofW(StgHeader) + 2;
+ break;
+
case FUN:
case THUNK:
scavenge_srt(info);
@@ -1679,8 +1763,23 @@ scavenge_one(StgPtr p)
switch (info -> type) {
case FUN:
+ case FUN_1_0: /* hardly worth specialising these guys */
+ case FUN_0_1:
+ case FUN_1_1:
+ case FUN_0_2:
+ case FUN_2_0:
case THUNK:
+ case THUNK_1_0:
+ case THUNK_0_1:
+ case THUNK_1_1:
+ case THUNK_0_2:
+ case THUNK_2_0:
case CONSTR:
+ case CONSTR_1_0:
+ case CONSTR_0_1:
+ case CONSTR_1_1:
+ case CONSTR_0_2:
+ case CONSTR_2_0:
case WEAK:
case FOREIGN:
case IND_PERM:
@@ -2066,22 +2165,24 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
continue;
} else {
bdescr *bd = Bdescr((P_)frame->updatee);
+ step *step;
if (bd->gen->no > N) {
if (bd->gen->no < evac_gen) {
failed_to_evac = rtsTrue;
}
continue;
}
+ step = bd->step->to;
switch (type) {
case BLACKHOLE:
case CAF_BLACKHOLE:
to = copyPart(frame->updatee, BLACKHOLE_sizeW(),
- sizeofW(StgHeader), bd);
+ sizeofW(StgHeader), step);
upd_evacuee(frame->updatee,to);
frame->updatee = to;
continue;
case BLACKHOLE_BQ:
- to = copy(frame->updatee, BLACKHOLE_sizeW(), bd);
+ to = copy(frame->updatee, BLACKHOLE_sizeW(), step);
upd_evacuee(frame->updatee,to);
frame->updatee = to;
evacuate_mutable((StgMutClosure *)to);
diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc
index ae400803d99a..784c6a1676a8 100644
--- a/ghc/rts/PrimOps.hc
+++ b/ghc/rts/PrimOps.hc
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.7 1999/01/26 11:12:46 simonm Exp $
+ * $Id: PrimOps.hc,v 1.8 1999/01/26 16:16:25 simonm Exp $
*
* Primitive functions / data
*
@@ -871,3 +871,4 @@ FN_(makeStableNameZh_fast)
}
#endif /* COMPILER */
+
diff --git a/ghc/rts/RtsFlags.c b/ghc/rts/RtsFlags.c
index 089efd28238f..bcba5d13b616 100644
--- a/ghc/rts/RtsFlags.c
+++ b/ghc/rts/RtsFlags.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.6 1999/01/21 10:31:48 simonm Exp $
+ * $Id: RtsFlags.c,v 1.7 1999/01/26 16:16:28 simonm Exp $
*
* Functions for parsing the argument list.
*
@@ -67,6 +67,7 @@ void initRtsFlagsDefaults(void)
RtsFlags.GcFlags.pcFreeHeap = 3; /* 3% */
RtsFlags.GcFlags.oldGenFactor = 2;
RtsFlags.GcFlags.generations = 2;
+ RtsFlags.GcFlags.steps = 2;
RtsFlags.GcFlags.forceGC = rtsFalse;
RtsFlags.GcFlags.forcingInterval = 5000000; /* 5MB (or words?) */
@@ -214,6 +215,7 @@ usage_text[] = {
" -M<size> Sets the maximum heap size (default 64M) Egs: -H256k -H1G",
" -m<n>% Minimum % of heap which must be available (default 3%)",
" -G<n> Number of generations (default: 2)",
+" -T<n> Number of steps in younger generations (default: 2)",
" -s<file> Summary GC statistics (default file: <program>.stat)",
" -S<file> Detailed GC statistics (with -Sstderr going to stderr)",
"",
@@ -265,8 +267,6 @@ usage_text[] = {
" -r<file> Produce reduction profiling statistics (with -rstderr for stderr)",
"",
#endif
-" -T<level> Trace garbage collection execution (debugging)",
-"",
# ifdef PAR
" -N<n> Use <n> PVMish processors in parallel (default: 2)",
/* NB: the -N<n> is implemented by the driver!! */
@@ -484,6 +484,13 @@ error = rtsTrue;
}
break;
+ case 'T':
+ RtsFlags.GcFlags.steps = decode(rts_argv[arg]+2);
+ if (RtsFlags.GcFlags.steps < 1) {
+ bad_option(rts_argv[arg]);
+ }
+ break;
+
case 'H':
/* ignore for compatibility with older versions */
break;
diff --git a/ghc/rts/RtsFlags.h b/ghc/rts/RtsFlags.h
index da65c5b4117e..9678a98ddf50 100644
--- a/ghc/rts/RtsFlags.h
+++ b/ghc/rts/RtsFlags.h
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.6 1999/01/26 11:12:46 simonm Exp $
+ * $Id: RtsFlags.h,v 1.7 1999/01/26 16:16:29 simonm Exp $
*
* Datatypes that holds the command-line flag settings.
*
@@ -26,6 +26,7 @@ struct GC_FLAGS {
double pcFreeHeap;
nat generations;
+ nat steps;
rtsBool forceGC; /* force a major GC every <interval> bytes */
int forcingInterval; /* actually, stored as a number of *words* */
diff --git a/ghc/rts/Storage.c b/ghc/rts/Storage.c
index 6b44104ef03d..5117375f58b4 100644
--- a/ghc/rts/Storage.c
+++ b/ghc/rts/Storage.c
@@ -1,5 +1,5 @@
/* -----------------------------------------------------------------------------
- * $Id: Storage.c,v 1.6 1999/01/21 10:31:51 simonm Exp $
+ * $Id: Storage.c,v 1.7 1999/01/26 16:16:30 simonm Exp $
*
* Storage manager front end
*
@@ -82,9 +82,10 @@ initStorage (void)
/* set up all except the oldest generation with 2 steps */
for(g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
- generations[g].n_steps = 2;
- generations[g].steps = stgMallocBytes (2 * sizeof(struct _step),
- "initStorage: steps");
+ generations[g].n_steps = RtsFlags.GcFlags.steps;
+ generations[g].steps =
+ stgMallocBytes (RtsFlags.GcFlags.steps * sizeof(struct _step),
+ "initStorage: steps");
}
} else {
@@ -112,14 +113,10 @@ initStorage (void)
/* Set up the destination pointers in each younger gen. step */
for (g = 0; g < RtsFlags.GcFlags.generations-1; g++) {
- for (s = 0; s < generations[g].n_steps; s++) {
- step = &generations[g].steps[s];
- if ( s == 1 ) {
- step->to = &generations[g+1].steps[0];
- } else {
- step->to = &generations[g].steps[s+1];
- }
+ for (s = 0; s < generations[g].n_steps-1; s++) {
+ generations[g].steps[s].to = &generations[g].steps[s+1];
}
+ generations[g].steps[s].to = &generations[g+1].steps[0];
}
/* The oldest generation has one step and its destination is the
--
GitLab