[project @ 2000-03-23 14:54:20 by sewardj]

[ghc-hetmet.git] / ghc / interpreter / stg.c

diff --git a/ghc/interpreter/stg.c b/ghc/interpreter/stg.c
index f426799..0fd6df1 100644 (file)
--- a/ghc/interpreter/stg.c
+++ b/ghc/interpreter/stg.c
@@ -9,44 +9,55 @@
  * included in the distribution.
  *
  * $RCSfile: stg.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/11/29 18:59:32 $
+ * $Revision: 1.15 $
+ * $Date: 2000/03/23 14:54:21 $
  * ------------------------------------------------------------------------*/
 
-#include "prelude.h"
+#include "hugsbasictypes.h"
 #include "storage.h"
-#include "backend.h"
 #include "connect.h"
 #include "errors.h"
-#include "link.h"      /* for nameTrue/False     */
+
 #include "Assembler.h" /* for AsmRep and primops */
 
 /* --------------------------------------------------------------------------
  * Utility functions
  * ------------------------------------------------------------------------*/
 
-void* stgConInfo( StgDiscr d )
+/* Make an info table for a constructor or tuple. */
+void* stgConInfo ( StgDiscr d )
 {
+    int tag;
     switch (whatIs(d)) {
-    case NAME:
-            return asmMkInfo(cfunOf(d),name(d).arity);
-    case TUPLE: 
-            return asmMkInfo(0,tupleOf(d));
-    default: 
-            internal("stgConInfo");
+       case NAME: {
+          tag = cfunOf(d);
+          if (tag > 0) tag--;
+          if (!name(d).itbl)
+             name(d).itbl = asmMkInfo(tag,name(d).arity);
+          return name(d).itbl;
+       }
+       case TUPLE: {
+          tag = 0;
+          if (!tycon(d).itbl)
+             tycon(d).itbl = asmMkInfo(tag,tupleOf(d));
+          return tycon(d).itbl;
+       }
+       default: 
+          internal("stgConInfo");
     }
 }
 
-int stgDiscrTag( StgDiscr d )
+/* Return the tag for a constructor or tuple, starting at zero. */
+int stgDiscrTag ( StgDiscr d )
 {
+    int tag;
     switch (whatIs(d)) {
-    case NAME:
-            return cfunOf(d);
-    case TUPLE: 
-            return 0;
-    default: 
-            internal("stgDiscrTag");
+       case NAME:  tag = cfunOf(d); break;
+       case TUPLE: tag = 0;
+       default:    internal("stgDiscrTag");   
     }
+    if (tag > 0) tag--;
+    return tag;
 }
 
 /* --------------------------------------------------------------------------
@@ -147,17 +158,16 @@ StgVar mkStgVar( StgRhs rhs, Cell info )
  * Local functions
  * ------------------------------------------------------------------------*/
 
-static Void local pIndent        Args((Int));
-
-static Void local putStgVar       Args((StgVar));
-static Void local putStgVars      Args((List));
-static Void local putStgAtom      Args((StgAtom a));
-static Void local putStgAtoms     Args((List as));
-static Void local putStgBinds     Args((List));
-static Void local putStgExpr      Args((StgExpr));
-static Void local putStgRhs       Args((StgRhs));
-static Void local putStgPat       Args((StgCaseAlt));
-static Void local putStgPrimPat   Args((StgPrimAlt));
+static Void local pIndent         ( Int );
+static Void local putStgVar       ( StgVar );
+static Void local putStgVars      ( List );
+static Void local putStgAtom      ( StgAtom a );
+static Void local putStgAtoms     ( List as );
+static Void local putStgBinds     ( List );
+static Void local putStgExpr      ( StgExpr );
+static Void local putStgRhs       ( StgRhs );
+static Void local putStgPat       ( StgCaseAlt );
+static Void local putStgPrimPat   ( StgPrimAlt );
 
 
 
@@ -544,7 +554,6 @@ StgVar b;
     endStgPP(fp);
 }
 
-#if 1 /*DEBUG_PRINTER*/
 Void ppStg( StgVar v )
 {
    printStg(stdout,v);
@@ -586,6 +595,5 @@ extern Void ppStgVars( List vs )
    printf("\n");
    endStgPP(stdout);
 }
-#endif
 
 /*-------------------------------------------------------------------------*/