[project @ 2000-03-13 11:37:16 by sewardj]

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

diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index f85275e..a6935cb 100644 (file)
--- a/ghc/interpreter/translate.c
+++ b/ghc/interpreter/translate.c
@@ -10,27 +10,26 @@
  * included in the distribution.
  *
  * $RCSfile: translate.c,v $
- * $Revision: 1.20 $
- * $Date: 1999/11/29 18:53:15 $
+ * $Revision: 1.28 $
+ * $Date: 2000/03/13 11:37:17 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
 #include "storage.h"
-#include "backend.h"
 #include "connect.h"
 #include "errors.h"
 #include "link.h"
-#include "dynamic.h"
+
 #include "Assembler.h"
 
 
 /* ---------------------------------------------------------------- */
 
-static StgVar  local stgOffset       Args((Offset,List));
-static StgVar  local stgText         Args((Text,List));
-static StgRhs  local stgRhs          Args((Cell,Int,List,StgExpr));
-static StgCaseAlt local stgCaseAlt   Args((Cell,Int,List,StgExpr));
-static StgExpr local stgExpr         Args((Cell,Int,List,StgExpr));
+static StgVar     local stgOffset    ( Offset,List );
+static StgVar     local stgText      ( Text,List );
+static StgRhs     local stgRhs       ( Cell,Int,List,StgExpr );
+static StgCaseAlt local stgCaseAlt   ( Cell,Int,List,StgExpr );
+static StgExpr    local stgExpr      ( Cell,Int,List,StgExpr );
 
 /* ---------------------------------------------------------------- */
 
@@ -38,9 +37,7 @@ static StgExpr local stgExpr         Args((Cell,Int,List,StgExpr));
 /* dictionaries, tuples, etc                                        */
 List stgGlobals = NIL;
 
-static StgVar local getSTGTupleVar  Args((Cell));
-
-static StgVar local getSTGTupleVar( Cell d )
+static StgVar local getSTGTupleVar ( Cell d )
 {
     Pair p = cellAssoc(d,stgGlobals);
     /* Yoiks - only the Prelude sees Tuple decls! */
@@ -213,7 +210,6 @@ StgExpr failExpr;
             Int    da    = discrArity(discr);
             char   str[30];
 
-#if NPLUSK
             if (whatIs(h) == ADDPAT && argCount == 1) {
                 /*   ADDPAT num dictIntegral
                  * ==>
@@ -260,7 +256,6 @@ StgExpr failExpr;
                                           failExpr)),
                          failExpr));
             }
-#endif /* NPLUSK */
 
             assert(isName(h) && argCount == 2);
             {
@@ -370,6 +365,7 @@ StgExpr failExpr;
             List args  = NIL;
             List binds = NIL;
             List as    = NIL;
+            Int  length_args;
 
             /* Unwind args */
             while (isAp(e)) {
@@ -411,12 +407,16 @@ StgExpr failExpr;
             }
 
             /* Special case: saturated constructor application */
-            if (isName(e) && isCfun(e)
-                && name(e).arity > 0 
-                && name(e).arity == length(args)) {
+            length_args = length(args);
+            if ( (isName(e) && isCfun(e)
+                  && name(e).arity > 0 
+                  && name(e).arity == length_args)
+                 ||
+                 (isTuple(e) && tycon(e).tuple == length_args)
+               ) {
                StgVar v; 
                /* fprintf ( stderr, "saturated application of %s\n",
-                                    textToStr(name(e).text)); */
+                           textToStr(isTuple(e) ? tycon(e).text : name(e).text)); */
                v = mkStgVar(mkStgCon(e,args),NIL);
                binds = cons(v,binds);
                return mkStgLet(binds,v);
@@ -436,22 +436,6 @@ StgExpr failExpr;
     }
 }
 
-#if 0 /* apparently not used */
-static Void ppExp( Name n, Int arity, Cell e )
-{
-    if (1 || debugCode) {
-        Int i;
-        printf("%s", textToStr(name(n).text));
-        for (i = arity; i > 0; i--) {
-            printf(" o%d", i);
-        }
-        printf(" = ");
-        printExp(stdout,e); 
-        printf("\n");
-    }
-}
-#endif
-
 
 Void stgDefn( Name n, Int arity, Cell e )
 {
@@ -469,7 +453,7 @@ Void stgDefn( Name n, Int arity, Cell e )
 
 Void implementCfun(c,scs)               /* Build implementation for constr */
 Name c;                                 /* fun c.  scs lists integers (1..)*/
-List scs; {                             /* in incr order of strict comps.  */
+List scs; {                             /* in incr order of strict fields. */
     Int a = name(c).arity;
 
     if (a > 0) {
@@ -894,17 +878,15 @@ Void implementForeignImport ( Name n )
        descriptor->arg_tys++;
        descriptor->num_args--;
     }
-
-    
 }
 
 
 /* Generate code:
  *
- * \ fun s0 ->
+ * \ fun ->
      let e1 = A# "...."
          e3 = C# 'c' -- (ccall), or 's' (stdcall)
-     in  primMkAdjThunk fun e1 e3 s0
+     in  primMkAdjThunk fun e1 e3
 
    we require, and check that,
      fun :: prim_arg* -> IO prim_result
@@ -937,7 +919,7 @@ Void implementForeignExport ( Name n )
         assert(length(resultTys) == 1);
         resultTys = hd(resultTys);
     } else {
-        ERRMSG(name(n).line) "foreign export doesn't return an IO type" ETHEN
+        ERRMSG(name(n).line) "function to be exported doesn't return an IO type: " ETHEN
         ERRTEXT " \"" ETHEN ERRTYPE(t);
         ERRTEXT "\""
         EEND;        
@@ -961,7 +943,6 @@ Void implementForeignExport ( Name n )
     else
        internal ( "implementForeignExport: unknown calling convention");
 
-
     {
     List     tdList;
     Text     tdText;
@@ -974,7 +955,7 @@ Void implementForeignExport ( Name n )
        tdList = cons(foreignOutboundTy(resultTys),tdList);
 
     tdText = findText(charListToString ( tdList ));
-    args   = makeArgs(2);
+    args   = makeArgs(1);
     e1     = mkStgVar(
                 mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
                 NIL
@@ -993,7 +974,7 @@ Void implementForeignExport ( Name n )
                    tripleton(e1,e2,e3),
                    mkStgApp(
                       nameCreateAdjThunk,
-                      cons(hd(args),cons(e2,cons(e3,cons(hd(tl(args)),NIL))))
+                      cons(hd(args),cons(e2,cons(e3,NIL)))
                    )
                 )
              );
@@ -1006,7 +987,6 @@ Void implementForeignExport ( Name n )
     }
 }
 
-// ToDo: figure out how to set inlineMe for these (non-Name) things
 Void implementTuple(size)
 Int size; {
     if (size > 0) {
@@ -1029,16 +1009,14 @@ Int size; {
 Void translateControl(what)
 Int what; {
     switch (what) {
-    case INSTALL:
-        {
-            /* deliberate fall through */
-        }
-    case RESET: 
-            stgGlobals=NIL;
-            break;
-    case MARK: 
-            mark(stgGlobals);
-            break;
+       case POSTPREL: break;
+       case PREPREL:
+       case RESET: 
+          stgGlobals=NIL;
+          break;
+       case MARK: 
+          mark(stgGlobals);
+          break;
     }
 }