[project @ 2000-04-06 15:05:30 by sewardj]

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

diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index ead65fc..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.24 $
- * $Date: 1999/12/10 15:59:56 $
+ * $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);
             {
@@ -415,7 +409,9 @@ StgExpr failExpr;
             length_args = length(args);
             if ( (isName(e) && isCfun(e)
                   && name(e).arity > 0 
-                  && name(e).arity == length_args)
+                  && name(e).arity == length_args
+                  && !name(e).hasStrict
+                  && numQualifiers(name(e).type) == 0)
                  ||
                  (isTuple(e) && tycon(e).tuple == length_args)
                ) {
@@ -441,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 )
 {
@@ -475,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);
 
@@ -491,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);
@@ -899,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
@@ -942,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;        
@@ -966,7 +948,6 @@ Void implementForeignExport ( Name n )
     else
        internal ( "implementForeignExport: unknown calling convention");
 
-
     {
     List     tdList;
     Text     tdText;
@@ -979,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
@@ -998,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)))
                    )
                 )
              );