From ad9bc691f47d26c56fbea4d83d49468708438905 Mon Sep 17 00:00:00 2001
From: sewardj <unknown>
Date: Wed, 5 Apr 2000 10:25:09 +0000
Subject: [PATCH] [project @ 2000-04-05 10:25:08 by sewardj] Correctly handle
constructors with strict fields, which was broken by overenthusiastic
constructor inlining some time back: * notice if a constructor has strict
fields, and set name(n).hasStrict, both for source modules and interfaces *
if a constr has strict fields, do not inline applications of it
---
ghc/interpreter/codegen.c | 6 +++---
ghc/interpreter/hugs.c | 6 +++---
ghc/interpreter/interface.c | 43 +++++++++++++++++++------------------
ghc/interpreter/static.c | 5 +++--
ghc/interpreter/storage.c | 5 +++--
ghc/interpreter/storage.h | 5 +++--
ghc/interpreter/translate.c | 7 +++---
7 files changed, 41 insertions(+), 36 deletions(-)
diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c
index ba61730e4498..add33649b331 100644
--- a/ghc/interpreter/codegen.c
+++ b/ghc/interpreter/codegen.c
@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: codegen.c,v $
- * $Revision: 1.20 $
- * $Date: 2000/03/23 14:54:20 $
+ * $Revision: 1.21 $
+ * $Date: 2000/04/05 10:25:08 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
@@ -90,7 +90,7 @@ char* lookupHugsName( void* closure )
Name nm;
for( nm = NAME_BASE_ADDR;
nm < NAME_BASE_ADDR+tabNameSz; ++nm )
- if (name(nm).inUse) {
+ if (tabName[nm-NAME_BASE_ADDR].inUse) {
StgVar v = name(nm).stgVar;
if (isStgVar(v)
&& isPtr(stgVarInfo(v))
diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c
index 55b39e497745..340fc2d0248b 100644
--- a/ghc/interpreter/hugs.c
+++ b/ghc/interpreter/hugs.c
@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.57 $
- * $Date: 2000/04/04 17:35:04 $
+ * $Revision: 1.58 $
+ * $Date: 2000/04/05 10:25:08 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
@@ -940,7 +940,7 @@ static void mgFromList ( List /* of CONID */ modgList )
for (u = module(mod).uses; nonNull(u); u=tl(u))
usesT = cons(textOf(hd(u)),usesT);
- /* artifically give all modules a dependency on Prelude */
+ /* artificially give all modules a dependency on Prelude */
if (mT != textPrelude && mT != textPrimPrel)
usesT = cons(textPrelude,usesT);
diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c
index f16ad21fab41..8cb7e24111fb 100644
--- a/ghc/interpreter/interface.c
+++ b/ghc/interpreter/interface.c
@@ -7,8 +7,8 @@
* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.45 $
- * $Date: 2000/04/05 09:22:28 $
+ * $Revision: 1.46 $
+ * $Date: 2000/04/05 10:25:08 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
@@ -1620,6 +1620,7 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
Pair conArg, ctxElem;
Text conArgNm;
Int conArgStrictness;
+ Int conStrictCompCount;
Text t = textOf(tycon);
# ifdef DEBUG_IFACE
@@ -1662,6 +1663,7 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
tyvarsMentioned = NIL;
/* tyvarsMentioned :: [VarId] */
+ conStrictCompCount = 0;
conArgs = reverse(fields);
for (; nonNull(conArgs); conArgs=tl(conArgs)) {
conArg = hd(conArgs); /* (Type,Text) */
@@ -1670,10 +1672,7 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
conArgStrictness = intOf(zthd3(conArg));
tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
tyvarsMentioned);
- /* Not sure what the deal is with strictness. Do we need
- to notify the symbol table, or not? The Hugs desugarer?
- Currently disabled. */
- /* if (conArgStrictness > 0) conArgTy = bang(conArgTy); */
+ if (conArgStrictness > 0) conStrictCompCount++;
ty = fn(conArgTy,ty);
if (nonNull(conArgNm)) {
/* a field name is mentioned too */
@@ -1706,12 +1705,12 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
ty = tvsToOffsets(line,ty, ktyvars);
/* Finally, stick the constructor's type onto it. */
- hd(constrs) = ztriple(conid,fields,ty);
+ hd(constrs) = z4ble(conid,fields,ty,mkInt(conStrictCompCount));
}
/* Final result is that
- constrs :: [((ConId,[((Type,Text))],Type))]
- lists the constructors and their types
+ constrs :: [((ConId,[((Type,Text))],Type,Int))]
+ lists the constructors, their types and # strict comps
sels :: [((VarId,Type))]
lists the selectors and their types
*/
@@ -1722,9 +1721,9 @@ List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
static List startGHCConstrs ( Int line, List cons, List sels )
{
- /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
- /* sels :: [((VarId,Type))] */
- /* returns [Name] */
+ /* cons :: [((ConId,[((Type,Text,Int))],Type,Int))] */
+ /* sels :: [((VarId,Type))] */
+ /* returns [Name] */
List cs, ss;
Int conNo = length(cons)>1 ? 1 : 0;
for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
@@ -1764,15 +1763,16 @@ static Name startGHCSel ( Int line, ZPair sel )
}
-static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
+static Name startGHCConstr ( Int line, Int conNo, Z4Ble constr )
{
- /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
+ /* constr :: ((ConId,[((Type,Text,Int))],Type,Int)) */
/* (ADR) ToDo: add rank2 annotation and existential annotation
* these affect how constr can be used.
*/
- Text con = textOf(zfst3(constr));
- Type type = zthd3(constr);
- Int arity = arityFromType(type);
+ Text con = textOf(zsel14(constr));
+ Type type = zsel34(constr);
+ Int arity = arityFromType(type);
+ Int nStrict = intOf(zsel44(constr));
Name n = findName(con); /* Allocate constructor fun name */
if (isNull(n)) {
n = newName(con,NIL);
@@ -1781,10 +1781,11 @@ static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
textToStr(con)
EEND;
}
- name(n).arity = arity; /* Save constructor fun details */
- name(n).line = line;
- name(n).number = cfunNo(conNo);
- name(n).type = type;
+ name(n).arity = arity; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(conNo);
+ name(n).type = type;
+ name(n).hasStrict = nStrict > 0;
return n;
}
diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c
index 612a57eb208d..582e079c4e53 100644
--- a/ghc/interpreter/static.c
+++ b/ghc/interpreter/static.c
@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: static.c,v $
- * $Revision: 1.35 $
- * $Date: 2000/04/04 01:19:07 $
+ * $Revision: 1.36 $
+ * $Date: 2000/04/05 10:25:08 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
@@ -1031,6 +1031,7 @@ Cell cd; { /* definitions (w or w/o deriving) */
name(n).defn = nameId;
} else {
implementCfun(n,scs);
+ name(n).hasStrict = nonNull(scs);
}
hd(cs) = n;
diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c
index 183495e0dd81..2c1caa8be0dd 100644
--- a/ghc/interpreter/storage.c
+++ b/ghc/interpreter/storage.c
@@ -9,8 +9,8 @@
* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.61 $
- * $Date: 2000/04/04 15:41:56 $
+ * $Revision: 1.62 $
+ * $Date: 2000/04/05 10:25:08 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
@@ -860,6 +860,7 @@ Name newName ( Text t, Cell parent ) /* Add new name to name table */
name(nm).arity = 0;
name(nm).number = EXECNAME;
name(nm).defn = NIL;
+ name(nm).hasStrict = FALSE;
name(nm).stgVar = NIL;
name(nm).callconv = NIL;
name(nm).type = NIL;
diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h
index 7e560c6d31e1..c8b8449a546c 100644
--- a/ghc/interpreter/storage.h
+++ b/ghc/interpreter/storage.h
@@ -10,8 +10,8 @@
* included in the distribution.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.38 $
- * $Date: 2000/04/04 15:41:56 $
+ * $Revision: 1.39 $
+ * $Date: 2000/04/05 10:25:08 $
* ------------------------------------------------------------------------*/
#define DEBUG_STORAGE
@@ -741,6 +741,7 @@ struct strName {
Int number;
Cell type;
Cell defn;
+ Bool hasStrict; /* does constructor have strict components? */
Cell stgVar; /* really StgVar */
Text callconv; /* for foreign import/export */
void* primop; /* really StgPrim* */
diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c
index aa0af806ba22..54b01b9a6e04 100644
--- a/ghc/interpreter/translate.c
+++ b/ghc/interpreter/translate.c
@@ -10,8 +10,8 @@
* included in the distribution.
*
* $RCSfile: translate.c,v $
- * $Revision: 1.30 $
- * $Date: 2000/03/23 14:54:21 $
+ * $Revision: 1.31 $
+ * $Date: 2000/04/05 10:25:09 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
@@ -409,7 +409,8 @@ 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)
||
(isTuple(e) && tycon(e).tuple == length_args)
) {
--
GitLab