[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.

13 files changed, 317 insertions, 123 deletions

diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index d0b396eeec..63646ce918 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 f1a0ef25c9..c3839985dc 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 9e99002671..f64b8dccc9 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 fe463172c6..9a36a339b5 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 c0bf4872a6..d30a976b7b 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 9ae6332936..24d4189695 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 d97016044d..fbb3dbf4ea 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 fb1640daba..9c71d6172d 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 619aa5c6f6..fa52ddaa90 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 ae400803d9..784c6a1676 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 089efd2823..bcba5d13b6 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 da65c5b411..9678a98ddf 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 6b44104ef0..5117375f58 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