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

diff --git a/ghc/interpreter/stg.c b/ghc/interpreter/stg.c
index f426799..ac620f7 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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;