From 6478af6db8629d7eca79e6d415b3edc669e34849 Mon Sep 17 00:00:00 2001 From: sewardj Date: Tue, 7 Dec 1999 11:15:02 +0000 Subject: [PATCH] [project @ 1999-12-07 11:14:56 by sewardj] Don't create a new infotable for every constructor application. Amazingly, that's what the codegen.c used to do. It didn't generate vast numbers of redundant infotables until recently, when I changed translate.c to generate saturated constructor applications in line. Prior to that, there was only ever one application of each constructor, so the old scheme was ok. Also, fix the assembler so that info table ptrs are commoned up. Eg, for [1,2,3], store only one copy of the address of the (:) itbl, rather than 3, in the BCO. --- ghc/interpreter/stg.c | 20 ++++++++++++-------- ghc/interpreter/storage.c | 6 ++++-- ghc/interpreter/storage.h | 12 +++++++----- ghc/rts/Assembler.c | 32 ++++++++++++++++++++++++++++---- ghc/rts/QueueTemplate.h | 16 +++++++++++++--- 5 files changed, 64 insertions(+), 22 deletions(-) diff --git a/ghc/interpreter/stg.c b/ghc/interpreter/stg.c index f426799..ac620f7 100644 --- a/ghc/interpreter/stg.c +++ b/ghc/interpreter/stg.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: stg.c,v $ - * $Revision: 1.9 $ - * $Date: 1999/11/29 18:59:32 $ + * $Revision: 1.10 $ + * $Date: 1999/12/07 11:14:56 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -28,12 +28,16 @@ void* stgConInfo( StgDiscr d ) { switch (whatIs(d)) { - case NAME: - return asmMkInfo(cfunOf(d),name(d).arity); - case TUPLE: - return asmMkInfo(0,tupleOf(d)); - default: - internal("stgConInfo"); + case NAME: + if (!name(d).itbl) + name(d).itbl = asmMkInfo(cfunOf(d),name(d).arity); + return name(d).itbl; + case TUPLE: + if (!tycon(d).itbl) + tycon(d).itbl = asmMkInfo(0,tupleOf(d)); + return tycon(d).itbl; + default: + internal("stgConInfo"); } } diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 04a9f84..f9c983b 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.23 $ - * $Date: 1999/12/06 16:47:07 $ + * $Revision: 1.24 $ + * $Date: 1999/12/07 11:14:57 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -468,6 +468,7 @@ Text t; { tycon(tyconHw).tagToCon = NIL; tycon(tyconHw).tuple = -1; tycon(tyconHw).mod = currentModule; + tycon(tyconHw).itbl = NULL; module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons); tycon(tyconHw).nextTyconHash = tyconHash[h]; tyconHash[h] = tyconHw; @@ -659,6 +660,7 @@ Cell parent; { name(nameHw).type = NIL; name(nameHw).primop = 0; name(nameHw).mod = currentModule; + name(nameHw).itbl = NULL; module(currentModule).names=cons(nameHw,module(currentModule).names); name(nameHw).nextNameHash = nameHash[h]; nameHash[h] = nameHw; diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index 2ea30db..39d7c20 100644 --- a/ghc/interpreter/storage.h +++ b/ghc/interpreter/storage.h @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: storage.h,v $ - * $Revision: 1.18 $ - * $Date: 1999/12/06 16:47:09 $ + * $Revision: 1.19 $ + * $Date: 1999/12/07 11:14:58 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -500,6 +500,7 @@ struct strTycon { Cell defn; Name conToTag; /* used in derived code */ Name tagToCon; + void* itbl; /* For tuples, the info tbl pointer */ Tycon nextTyconHash; }; @@ -540,9 +541,10 @@ struct strName { Int number; Cell type; Cell defn; - Cell stgVar; /* really StgVar */ - Text callconv; /* for foreign import/export */ - void* primop; /* really StgPrim* */ + Cell stgVar; /* really StgVar */ + Text callconv; /* for foreign import/export */ + void* primop; /* really StgPrim* */ + void* itbl; /* For constructors, the info tbl pointer */ Name nextNameHash; }; diff --git a/ghc/rts/Assembler.c b/ghc/rts/Assembler.c index 004321e..488bb1e 100644 --- a/ghc/rts/Assembler.c +++ b/ghc/rts/Assembler.c @@ -5,8 +5,8 @@ * Copyright (c) 1994-1998. * * $RCSfile: Assembler.c,v $ - * $Revision: 1.19 $ - * $Date: 1999/11/29 18:59:40 $ + * $Revision: 1.20 $ + * $Date: 1999/12/07 11:15:00 $ * * This module provides functions to construct BCOs and other closures * required by the bytecode compiler. @@ -79,25 +79,33 @@ typedef struct { #define Queue Instrs #define Type StgWord8 +#define MAKE_findIn 0 #include "QueueTemplate.h" +#undef MAKE_findIn #undef Type #undef Queue #define Queue Ptrs #define Type AsmObject +#define MAKE_findIn 0 #include "QueueTemplate.h" +#undef MAKE_findIn #undef Type #undef Queue #define Queue Refs #define Type AsmRef +#define MAKE_findIn 0 #include "QueueTemplate.h" +#undef MAKE_findIn #undef Type #undef Queue #define Queue NonPtrs #define Type StgWord +#define MAKE_findIn 1 #include "QueueTemplate.h" +#undef MAKE_findIn #undef Type #undef Queue @@ -467,6 +475,11 @@ static void asmWord( AsmBCO bco, StgWord i ) insertNonPtrs( &bco->nps, i ); } +static int asmFindInNonPtrs ( AsmBCO bco, StgWord i ) +{ + return findInNonPtrs ( &bco->nps, i ); +} + #define asmWords(bco,ty,x) \ { \ union { ty a; AsmWord b[sizeofW(ty)]; } p; \ @@ -1560,9 +1573,20 @@ AsmBCO asm_BCO_takeMVar ( void ) AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info ) { + int i; ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) ); - emiti_8(bco,i_ALLOC_CONSTR,bco->nps.len); - asmWords(bco,AsmInfo,info); + + /* Look in this bco's collection of nonpointers (literals) + to see if the itbl pointer is already there. If so, re-use it. */ + i = asmFindInNonPtrs ( bco, (StgWord)info ); + + if (i == -1) { + emiti_8(bco,i_ALLOC_CONSTR,bco->nps.len); + asmWords(bco,AsmInfo,info); + } else { + emiti_8(bco,i_ALLOC_CONSTR,i); + } + incSp(bco, sizeofW(StgClosurePtr)); grabHpNonUpd(bco,sizeW_fromITBL(info)); return bco->sp; diff --git a/ghc/rts/QueueTemplate.h b/ghc/rts/QueueTemplate.h index 2fb146e..b4a3513 100644 --- a/ghc/rts/QueueTemplate.h +++ b/ghc/rts/QueueTemplate.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $Id: QueueTemplate.h,v 1.4 1999/04/27 10:07:19 sewardj Exp $ + * $Id: QueueTemplate.h,v 1.5 1999/12/07 11:15:02 sewardj Exp $ * * (c) The GHC Team, 1998 * @@ -16,8 +16,8 @@ * static void freeQueue ( Queue* q ); * * $RCSfile: QueueTemplate.h,v $ - * $Revision: 1.4 $ - * $Date: 1999/04/27 10:07:19 $ + * $Revision: 1.5 $ + * $Date: 1999/12/07 11:15:02 $ * * ------------------------------------------------------------------------*/ @@ -37,6 +37,16 @@ typedef struct { } Queue; +#if MAKE_findIn +static int mycat2(findIn,Queue)( Queue* q, Type x ) +{ + nat i; + for (i = 0; i < q->len; i++) + if (q->elems[i] == x) return i; + return -1; +} +#endif + static void mycat2(init,Queue)( Queue* q ) { q->len = 0; -- 1.7.10.4