[project @ 2000-04-17 13:28:17 by sewardj]

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

diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index 0fb0439..d20fd7b 100644 (file)
--- a/ghc/interpreter/translate.c
+++ b/ghc/interpreter/translate.c
@@ -10,27 +10,25 @@
  * included in the distribution.
  *
  * $RCSfile: translate.c,v $
- * $Revision: 1.21 $
- * $Date: 1999/12/03 17:01:26 $
+ * $Revision: 1.33 $
+ * $Date: 2000/04/06 15:05:30 $
  * ------------------------------------------------------------------------*/
 
-#include "prelude.h"
+#include "hugsbasictypes.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 +36,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 +209,6 @@ StgExpr failExpr;
             Int    da    = discrArity(discr);
             char   str[30];
 
-#if NPLUSK
             if (whatIs(h) == ADDPAT && argCount == 1) {
                 /*   ADDPAT num dictIntegral
                  * ==>
@@ -260,7 +255,6 @@ StgExpr failExpr;
                                           failExpr)),
                          failExpr));
             }
-#endif /* NPLUSK */
 
             assert(isName(h) && argCount == 2);
             {
@@ -370,6 +364,7 @@ StgExpr failExpr;
             List args  = NIL;
             List binds = NIL;
             List as    = NIL;
+            Int  length_args;
 
             /* Unwind args */
             while (isAp(e)) {
@@ -411,12 +406,18 @@ 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
+                  && !name(e).hasStrict
+                  && numQualifiers(name(e).type) == 0)
+                 ||
+                 (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 +437,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 )
 {
@@ -470,11 +455,15 @@ 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 fields. */
-    Int a = name(c).arity;
+    Int  a  = name(c).arity;               /* arity, not incl dictionaries */
+    Int  ad = numQualifiers(name(c).type);   /* the number of dictionaries */
+    Type t  = name(c).type;
 
-    if (a > 0) {
+    /* a+ad is total arity for this fn */
+    if (a+ad > 0) {
         StgVar  vcurr, e1, v, vsi;
         List    args  = makeArgs(a);
+        List    argsd = makeArgs(ad);
         StgVar  v0    = mkStgVar(mkStgCon(c,args),NIL);
         List    binds = singleton(v0);
 
@@ -486,7 +475,7 @@ List scs; {                             /* in incr order of strict fields. */
         }
         binds = rev(binds);
         e1    = mkStgLet(binds,vcurr);
-        v     = mkStgVar(mkStgLambda(args,e1),NIL);
+        v     = mkStgVar(mkStgLambda(dupOnto(argsd,args),e1),NIL);
         name(c).stgVar = v;
     } else {
         StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
@@ -894,17 +883,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 +924,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 +948,6 @@ Void implementForeignExport ( Name n )
     else
        internal ( "implementForeignExport: unknown calling convention");
 
-
     {
     List     tdList;
     Text     tdText;
@@ -974,7 +960,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 +979,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 +992,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 +1014,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;
     }
 }