From 260c34f4f706780db7d985d0e84c71d171b7255d Mon Sep 17 00:00:00 2001 From: sewardj Date: Thu, 6 Apr 2000 14:23:55 +0000 Subject: [PATCH] [project @ 2000-04-06 14:23:55 by sewardj] Align Hugs' constructor-building with that of GHC. Always pass dictionaries to the constructor function, even if they are ignored. Generate a constructor function which expects dictionaries. And ignore dictionaries in constructor types when desugaring patterns containing them. --- ghc/interpreter/compiler.c | 13 +++++++++---- ghc/interpreter/storage.c | 17 +++++++++++++---- ghc/interpreter/storage.h | 15 +++++++++------ ghc/interpreter/translate.c | 14 +++++++++----- ghc/interpreter/type.c | 6 +++--- 5 files changed, 43 insertions(+), 22 deletions(-) diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index 4ab3144..ac85831 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -11,8 +11,8 @@ * included in the distribution. * * $RCSfile: compiler.c,v $ - * $Revision: 1.25 $ - * $Date: 2000/03/24 14:32:03 $ + * $Revision: 1.26 $ + * $Date: 2000/04/06 14:23:55 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -847,7 +847,7 @@ List lds; { } case DICTVAR : /* shouldn't really occur */ - assert(0); /* so let's test for it then! ADR */ + //assert(0); /* so let's test for it then! ADR */ case VARIDCELL : case VAROPCELL : return addEqn(pat,expr,lds); @@ -865,10 +865,15 @@ List lds; { /* intentional fall-thru */ case TUPLE : { List ps = getArgs(pat); + /* get rid of leading dictionaries in args */ + if (isName(c) && isCfun(c)) { + Int i = numQualifiers(name(c).type); + for (; i > 0; i--) ps = tl(ps); + } + if (nonNull(ps)) { Cell nv, sel; Int i; - if (isVar(expr) || isName(expr)) nv = expr; else { diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index e82660a..39e68ea 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.64 $ - * $Date: 2000/04/06 00:01:27 $ + * $Revision: 1.65 $ + * $Date: 2000/04/06 14:23:55 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -523,7 +523,7 @@ static Bool debugStorageExtra = FALSE; newTab[i].inUse = FALSE; \ newTab[i].nextFree = i-1+TAB_BASE_ADDR; \ } \ - if (debugStorageExtra) \ + if (0 && debugStorageExtra) \ fprintf(stderr, "Expanding " #type_name \ "table to size %d\n", newSz ); \ newTab[tab_size].nextFree = TAB_BASE_ADDR-1; \ @@ -1532,6 +1532,15 @@ List getAllKnownTyconsAndClasses ( void ) return xs; } +Int numQualifiers ( Type t ) +{ + if (isPolyType(t)) t = monotypeOf(t); + if (isQualType(t)) + return length ( fst(snd(t)) ); else + return 0; +} + + /* Purely for debugging. */ void locateSymbolByName ( Text t ) { @@ -2013,7 +2022,7 @@ Void garbageCollect() { /* Run garbage collector ... */ everybody(GCDONE); #if defined(DEBUG_STORAGE) || defined(DEBUG_STORAGE_EXTRA) - fprintf(stderr, "\n--- GC recovered %d\n",recovered ); + /* fprintf(stderr, "\n--- GC recovered %d\n",recovered ); */ #endif /* can only return if freeList is nonempty on return. */ diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index 8fc200f..e05bfb2 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.40 $ - * $Date: 2000/04/05 16:57:18 $ + * $Revision: 1.41 $ + * $Date: 2000/04/06 14:23:55 $ * ------------------------------------------------------------------------*/ #define DEBUG_STORAGE /* a moderate level of sanity checking */ @@ -688,11 +688,11 @@ struct strTycon { extern struct strTycon* tabTycon; extern Int tabTyconSz; -extern Tycon newTycon ( Text ); -extern Tycon findTycon ( Text ); -extern Tycon addTycon ( Tycon ); +extern Tycon newTycon ( Text ); +extern Tycon findTycon ( Text ); +extern Tycon addTycon ( Tycon ); extern Tycon findQualTycon ( Cell ); -extern Tycon addPrimTycon ( Text,Kind,Int,Cell,Cell ); +extern Tycon addPrimTycon ( Text,Kind,Int,Cell,Cell ); #define isSynonym(h) (isTycon(h) && tycon(h).what==SYNONYM) #define isQualType(t) (isPair(t) && fst(t)==QUAL) @@ -705,6 +705,9 @@ extern Tycon addPrimTycon ( Text,Kind,Int,Cell,Cell ); extern Tycon findQualTyconWithoutConsultingExportList ( QualId q ); +extern Int numQualifiers ( Type ); + + /* -------------------------------------------------------------------------- * Globally defined name values: * ------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index 54b01b9..eee6260 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.31 $ - * $Date: 2000/04/05 10:25:09 $ + * $Revision: 1.32 $ + * $Date: 2000/04/06 14:23:55 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -454,11 +454,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); @@ -470,7 +474,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); diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index 063e469..eb2d2d9 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: type.c,v $ - * $Revision: 1.33 $ - * $Date: 2000/04/06 00:01:27 $ + * $Revision: 1.34 $ + * $Date: 2000/04/06 14:23:55 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -800,7 +800,7 @@ Cell e; { /* requires polymorphism, qualified*/ for (; nonNull(predsAre); predsAre=tl(predsAre)) { evs = cons(assumeEvid(hd(predsAre),typeOff),evs); } - if (!isName(h) || !isCfun(h)) { + /* we now _always_ do this: if (!isName(h) || !isCfun(h)) */ { h = applyToArgs(h,rev(evs)); } } -- 1.7.10.4