X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fstatic.c;h=3dc513367d39b385192a92f1ace8f8270409f743;hb=b287d1d7082f03a18e302e0ea58c97b56422ae7b;hp=3794bc5483d9a5ea6380357d3c65c12ad2de4e56;hpb=170d1670295c7cb9731f8d0eb034cf21f3e613ee;p=ghc-hetmet.git diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index 3794bc5..3dc5133 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -9,184 +9,179 @@ * included in the distribution. * * $RCSfile: static.c,v $ - * $Revision: 1.11 $ - * $Date: 1999/10/16 02:17:30 $ + * $Revision: 1.38 $ + * $Date: 2000/04/06 00:01:27 $ * ------------------------------------------------------------------------*/ -#include "prelude.h" +#include "hugsbasictypes.h" #include "storage.h" -#include "backend.h" #include "connect.h" -#include "link.h" #include "errors.h" -#include "subst.h" /* -------------------------------------------------------------------------- * local function prototypes: * ------------------------------------------------------------------------*/ -static Void local kindError Args((Int,Constr,Constr,String,Kind,Int)); -static Void local checkQualImport Args((Pair)); -static Void local checkUnqualImport Args((Triple)); - -static Name local lookupName Args((Text,List)); -static List local checkSubentities Args((List,List,List,String,Text)); -static List local checkExportTycon Args((List,Text,Cell,Tycon)); -static List local checkExportClass Args((List,Text,Cell,Class)); -static List local checkExport Args((List,Text,Cell)); -static List local checkImportEntity Args((List,Module,Cell)); -static List local resolveImportList Args((Module,Cell)); -static Void local checkImportList Args((Pair)); - -static Void local importEntity Args((Module,Cell)); -static Void local importName Args((Module,Name)); -static Void local importTycon Args((Module,Tycon)); -static Void local importClass Args((Module,Class)); -static List local checkExports Args((List)); - -static Void local checkTyconDefn Args((Tycon)); -static Void local depConstrs Args((Tycon,List,Cell)); -static List local addSels Args((Int,Name,List,List)); -static List local selectCtxt Args((List,List)); -static Void local checkSynonyms Args((List)); -static List local visitSyn Args((List,Tycon,List)); -static Type local instantiateSyn Args((Type,Type)); - -static Void local checkClassDefn Args((Class)); -static Cell local depPredExp Args((Int,List,Cell)); -static Void local checkMems Args((Class,List,Cell)); -static Void local addMembers Args((Class)); -static Name local newMember Args((Int,Int,Cell,Type,Class)); -static Name local newDSel Args((Class,Int)); -static Text local generateText Args((String,Class)); -static Int local visitClass Args((Class)); - -static List local classBindings Args((String,Class,List)); -static Name local memberName Args((Class,Text)); -static List local numInsert Args((Int,Cell,List)); - -static List local typeVarsIn Args((Cell,List,List,List)); -static List local maybeAppendVar Args((Cell,List)); - -static Type local checkSigType Args((Int,String,Cell,Type)); -static Void local checkOptQuantVars Args((Int,List,List)); -static Type local depTopType Args((Int,List,Type)); -static Type local depCompType Args((Int,List,Type)); -static Type local depTypeExp Args((Int,List,Type)); -static Type local depTypeVar Args((Int,List,Text)); -static List local checkQuantVars Args((Int,List,List,Cell)); -static List local otvars Args((Cell,List)); -static Bool local osubset Args((List,List)); -static Void local kindConstr Args((Int,Int,Int,Constr)); -static Kind local kindAtom Args((Int,Constr)); -static Void local kindPred Args((Int,Int,Int,Cell)); -static Void local kindType Args((Int,String,Type)); -static Void local fixKinds Args((Void)); - -static Void local kindTCGroup Args((List)); -static Void local initTCKind Args((Cell)); -static Void local kindTC Args((Cell)); -static Void local genTC Args((Cell)); - -static Void local checkInstDefn Args((Inst)); -static Void local insertInst Args((Inst)); -static Bool local instCompare Args((Inst,Inst)); -static Name local newInstImp Args((Inst)); -static Void local kindInst Args((Inst,Int)); -static Void local checkDerive Args((Tycon,List,List,Cell)); -static Void local addDerInst Args((Int,Class,List,List,Type,Int)); -static Void local deriveContexts Args((List)); -static Void local initDerInst Args((Inst)); -static Void local calcInstPreds Args((Inst)); -static Void local maybeAddPred Args((Cell,Int,Int,List)); -static List local calcFunDeps Args((List)); -static Cell local copyAdj Args((Cell,Int,Int)); -static Void local tidyDerInst Args((Inst)); -static List local otvarsZonk Args((Cell,List,Int)); - -static Void local addDerivImp Args((Inst)); - -static Void local checkDefaultDefns Args((Void)); - -static Void local checkForeignImport Args((Name)); -static Void local checkForeignExport Args((Name)); - -static Cell local tidyInfix Args((Int,Cell)); -static Pair local attachFixity Args((Int,Cell)); -static Syntax local lookupSyntax Args((Text)); - -static Cell local checkPat Args((Int,Cell)); -static Cell local checkMaybeCnkPat Args((Int,Cell)); -static Cell local checkApPat Args((Int,Int,Cell)); -static Void local addToPatVars Args((Int,Cell)); -static Name local conDefined Args((Int,Cell)); -static Void local checkIsCfun Args((Int,Name)); -static Void local checkCfunArgs Args((Int,Cell,Int)); -static Cell local checkPatType Args((Int,String,Cell,Type)); -static Cell local applyBtyvs Args((Cell)); -static Cell local bindPat Args((Int,Cell)); -static Void local bindPats Args((Int,List)); - -static List local extractSigdecls Args((List)); -static List local extractFixdecls Args((List)); -static List local extractBindings Args((List)); -static List local getPatVars Args((Int,Cell,List)); -static List local addPatVar Args((Int,Cell,List)); -static List local eqnsToBindings Args((List,List,List,List)); -static Void local notDefined Args((Int,List,Cell)); -static Cell local findBinding Args((Text,List)); -static Cell local getAttr Args((List,Cell)); -static Void local addSigdecl Args((List,Cell)); -static Void local addFixdecl Args((List,List,List,List,Triple)); -static Void local dupFixity Args((Int,Text)); -static Void local missFixity Args((Int,Text)); - -static List local dependencyAnal Args((List)); -static List local topDependAnal Args((List)); -static Void local addDepField Args((Cell)); -static Void local remDepField Args((List)); -static Void local remDepField1 Args((Cell)); -static Void local clearScope Args((Void)); -static Void local withinScope Args((List)); -static Void local leaveScope Args((Void)); -static Void local saveSyntax Args((Cell,Cell)); - -static Void local depBinding Args((Cell)); -static Void local depDefaults Args((Class)); -static Void local depInsts Args((Inst)); -static Void local depClassBindings Args((List)); -static Void local depAlt Args((Cell)); -static Void local depRhs Args((Cell)); -static Void local depGuard Args((Cell)); -static Cell local depExpr Args((Int,Cell)); -static Void local depPair Args((Int,Cell)); -static Void local depTriple Args((Int,Cell)); -static Void local depComp Args((Int,Cell,List)); -static Void local depCaseAlt Args((Int,Cell)); -static Cell local depVar Args((Int,Cell)); -static Cell local depQVar Args((Int,Cell)); -static Void local depConFlds Args((Int,Cell,Bool)); -static Void local depUpdFlds Args((Int,Cell)); -static List local depFields Args((Int,Cell,List,Bool)); +static Void local kindError ( Int,Constr,Constr,String,Kind,Int ); +static Void local checkQualImport ( Pair ); +static Void local checkUnqualImport ( Triple ); + +static Name local lookupName ( Text,List ); +static List local checkSubentities ( List,List,List,String,Text ); +static List local checkExportTycon ( List,Text,Cell,Tycon ); +static List local checkExportClass ( List,Text,Cell,Class ); +static List local checkExport ( List,Text,Cell ); +static List local checkImportEntity ( List,Module,Bool,Cell ); +static List local resolveImportList ( Module,Cell,Bool ); +static Void local checkImportList ( Pair ); + +static Void local importEntity ( Module,Cell ); +static Void local importName ( Module,Name ); +static Void local importTycon ( Module,Tycon ); +static Void local importClass ( Module,Class ); +static List local checkExports ( List, Module ); + +static Void local checkTyconDefn ( Tycon ); +static Void local depConstrs ( Tycon,List,Cell ); +static List local addSels ( Int,Name,List,List ); +static List local selectCtxt ( List,List ); +static Void local checkSynonyms ( List ); +static List local visitSyn ( List,Tycon,List ); +static Type local instantiateSyn ( Type,Type ); + +static Void local checkClassDefn ( Class ); +static Cell local depPredExp ( Int,List,Cell ); +static Void local checkMems ( Class,List,Cell ); +static Void local checkMems2 ( Class,Cell ); +static Void local addMembers ( Class ); +static Name local newMember ( Int,Int,Cell,Type,Class ); +static Text local generateText ( String,Class ); + +static List local classBindings ( String,Class,List ); +static Name local memberName ( Class,Text ); +static List local numInsert ( Int,Cell,List ); + +static List local maybeAppendVar ( Cell,List ); + +static Type local checkSigType ( Int,String,Cell,Type ); +static Void local checkOptQuantVars ( Int,List,List ); +static Type local depTopType ( Int,List,Type ); +static Type local depCompType ( Int,List,Type ); +static Type local depTypeExp ( Int,List,Type ); +static Type local depTypeVar ( Int,List,Text ); +static List local checkQuantVars ( Int,List,List,Cell ); +static List local otvars ( Cell,List ); +static Bool local osubset ( List,List ); +static Void local kindConstr ( Int,Int,Int,Constr ); +static Kind local kindAtom ( Int,Constr ); +static Void local kindPred ( Int,Int,Int,Cell ); +static Void local kindType ( Int,String,Type ); +static Void local fixKinds ( Void ); + +static Void local kindTCGroup ( List ); +static Void local initTCKind ( Cell ); +static Void local kindTC ( Cell ); +static Void local genTC ( Cell ); + +static Void local checkInstDefn ( Inst ); +static Void local insertInst ( Inst ); +static Bool local instCompare ( Inst,Inst ); +static Name local newInstImp ( Inst ); +static Void local kindInst ( Inst,Int ); +static Void local checkDerive ( Tycon,List,List,Cell ); +static Void local addDerInst ( Int,Class,List,List,Type,Int ); +static Void local deriveContexts ( List ); +static Void local initDerInst ( Inst ); +static Void local calcInstPreds ( Inst ); +static Void local maybeAddPred ( Cell,Int,Int,List ); +static List local calcFunDeps ( List ); +static Cell local copyAdj ( Cell,Int,Int ); +static Void local tidyDerInst ( Inst ); +static List local otvarsZonk ( Cell,List,Int ); + +static Void local addDerivImp ( Inst ); + +static Void local checkDefaultDefns ( Void ); + +static Void local checkForeignImport ( Name ); +static Void local checkForeignExport ( Name ); + +static Cell local tidyInfix ( Int,Cell ); +static Pair local attachFixity ( Int,Cell ); +static Syntax local lookupSyntax ( Text ); + +static Cell local checkPat ( Int,Cell ); +static Cell local checkMaybeCnkPat ( Int,Cell ); +static Cell local checkApPat ( Int,Int,Cell ); +static Void local addToPatVars ( Int,Cell ); +static Name local conDefined ( Int,Cell ); +static Void local checkIsCfun ( Int,Name ); +static Void local checkCfunArgs ( Int,Cell,Int ); +static Cell local checkPatType ( Int,String,Cell,Type ); +static Cell local applyBtyvs ( Cell ); +static Cell local bindPat ( Int,Cell ); +static Void local bindPats ( Int,List ); + +static List local extractSigdecls ( List ); +static List local extractFixdecls ( List ); +static List local extractBindings ( List ); +static List local getPatVars ( Int,Cell,List ); +static List local addPatVar ( Int,Cell,List ); +static List local eqnsToBindings ( List,List,List,List ); +static Void local notDefined ( Int,List,Cell ); +static Cell local findBinding ( Text,List ); +static Cell local getAttr ( List,Cell ); +static Void local addSigdecl ( List,Cell ); +static Void local addFixdecl ( List,List,List,List,Triple ); +static Void local dupFixity ( Int,Text ); +static Void local missFixity ( Int,Text ); + +static List local dependencyAnal ( List ); +static List local topDependAnal ( List ); +static Void local addDepField ( Cell ); +static Void local remDepField ( List ); +static Void local remDepField1 ( Cell ); +static Void local clearScope ( Void ); +static Void local withinScope ( List ); +static Void local leaveScope ( Void ); +static Void local saveSyntax ( Cell,Cell ); + +static Void local depBinding ( Cell ); +static Void local depDefaults ( Class ); +static Void local depInsts ( Inst ); +static Void local depClassBindings ( List ); +static Void local depAlt ( Cell ); +static Void local depRhs ( Cell ); +static Void local depGuard ( Cell ); +static Cell local depExpr ( Int,Cell ); +static Void local depPair ( Int,Cell ); +static Void local depTriple ( Int,Cell ); +static Void local depComp ( Int,Cell,List ); +static Void local depCaseAlt ( Int,Cell ); +static Cell local depVar ( Int,Cell ); +static Cell local depQVar ( Int,Cell ); +static Void local depConFlds ( Int,Cell,Bool ); +static Void local depUpdFlds ( Int,Cell ); +static List local depFields ( Int,Cell,List,Bool ); #if IPARAM -static Void local depWith Args((Int,Cell)); -static List local depDwFlds Args((Int,Cell,List)); +static Void local depWith ( Int,Cell ); +static List local depDwFlds ( Int,Cell,List ); #endif #if TREX -static Cell local depRecord Args((Int,Cell)); +static Cell local depRecord ( Int,Cell ); #endif -static List local tcscc Args((List,List)); -static List local bscc Args((List)); +static List local tcscc ( List,List ); +static List local bscc ( List ); -static Void local addRSsigdecls Args((Pair)); -static Void local allNoPrevDef Args((Cell)); -static Void local noPrevDef Args((Int,Cell)); -static Bool local odiff Args((List,List)); +static Void local addRSsigdecls ( Pair ); +static Void local allNoPrevDef ( Cell ); +static Void local noPrevDef ( Int,Cell ); +static Bool local odiff ( List,List ); -static Void local duplicateErrorAux Args((Int,Module,Text,String)); +static Void local duplicateErrorAux ( Int,Module,Text,String ); #define duplicateError(l,m,t,k) duplicateErrorAux(l,m,t,k) -static Void local checkTypeIn Args((Pair)); +static Void local checkTypeIn ( Pair ); /* -------------------------------------------------------------------------- * The code in this file is arranged in roughly the following order: @@ -260,24 +255,9 @@ Kind extKind; /* Kind of extension, *->row->row */ * Static analysis of modules: * ------------------------------------------------------------------------*/ -#if HSCRIPT -String reloadModule; -#endif - -Void startModule(nm) /* switch to a new module */ -Cell nm; { - Module m; - if (!isCon(nm)) internal("startModule"); - if (isNull(m = findModule(textOf(nm)))) - m = newModule(textOf(nm)); - else if (!isPreludeScript()) { - /* You're allowed to break the rules in the Prelude! */ -#if HSCRIPT - reloadModule = textToStr(textOf(nm)); -#endif - ERRMSG(0) "Module \"%s\" already loaded", textToStr(textOf(nm)) - EEND; - } +Void startModule ( Module m ) /* switch to a new module */ +{ + if (isNull(m)) internal("startModule"); setCurrModule(m); } @@ -354,15 +334,28 @@ Text textParent; { return imports; } -static List local checkImportEntity(imports,exporter,entity) +static List local checkImportEntity(imports,exporter,priv,entity) List imports; /* Accumulated list of things to import */ Module exporter; -Cell entity; { /* Entry from import list */ +Bool priv; +Cell entity; { /* Entry from import list */ List oldImports = imports; Text t = isIdent(entity) ? textOf(entity) : textOf(fst(entity)); - List es = module(exporter).exports; + List es = NIL; + if (priv) { + es = module(exporter).names; + es = dupOnto(module(exporter).tycons,es); + es = dupOnto(module(exporter).classes,es); + } else { + es = module(exporter).exports; + } + for(; nonNull(es); es=tl(es)) { - Cell e = hd(es); /* :: Entity | (Entity, NIL|DOTDOT) */ + Cell e = hd(es); /* :: Entity + | (Entity, NIL|DOTDOT) + | tycon + | class + */ if (isPair(e)) { Cell f = fst(e); if (isTycon(f)) { @@ -373,10 +366,11 @@ Cell entity; { /* Entry from import list */ case NEWTYPE: case DATATYPE: if (DOTDOT == snd(entity)) { - imports=dupOnto(tycon(f).defn,imports); + imports = dupOnto(tycon(f).defn,imports); } else { - imports=checkSubentities(imports,snd(entity),tycon(f).defn, - "constructor of type",t); + imports = checkSubentities( + imports,snd(entity),tycon(f).defn, + "constructor of type",t); } break; default:; @@ -391,8 +385,9 @@ Cell entity; { /* Entry from import list */ if (DOTDOT == snd(entity)) { return dupOnto(cclass(f).members,imports); } else { - return checkSubentities(imports,snd(entity),cclass(f).members, - "member of class",t); + return checkSubentities( + imports,snd(entity),cclass(f).members, + "member of class",t); } } } @@ -403,6 +398,18 @@ Cell entity; { /* Entry from import list */ if (isIdent(entity) && name(e).text == t) { imports = cons(e,imports); } + } else if (isTycon(e) && priv) { + if (tycon(e).text == t) { + imports = cons(e,imports); + return dupOnto(tycon(e).defn,imports); + } + } else if (isClass(e) && priv) { + if (cclass(e).text == t) { + imports = cons(e,imports); + return dupOnto(cclass(e).members,imports); + } + } else if (whatIs(e) == TUPLE && priv) { + // do nothing } else { internal("checkImportEntity3"); } @@ -416,9 +423,10 @@ Cell entity; { /* Entry from import list */ return imports; } -static List local resolveImportList(m,impList) +static List local resolveImportList(m,impList,priv) Module m; /* exporting module */ -Cell impList; { +Cell impList; +Bool priv; { List imports = NIL; if (DOTDOT == impList) { List es = module(m).exports; @@ -442,7 +450,7 @@ Cell impList; { } } } else { - map1Accum(checkImportEntity,imports,m,impList); + map2Accum(checkImportEntity,imports,m,priv,impList); } return imports; } @@ -455,20 +463,23 @@ Pair importSpec; { List imports = NIL; /* entities we want to import */ List hidden = NIL; /* entities we want to hide */ - if (moduleThisScript(m)) { - ERRMSG(0) "Module \"%s\" recursively imports itself", - textToStr(module(m).text) - EEND; - } if (isPair(impList) && HIDDEN == fst(impList)) { /* Somewhat inefficient - but obviously correct: * imports = importsOf("module Foo") `setDifference` hidden; */ - hidden = resolveImportList(m, snd(impList)); - imports = resolveImportList(m, DOTDOT); + hidden = resolveImportList(m, snd(impList),FALSE); + imports = resolveImportList(m, DOTDOT,FALSE); + } else if (isPair(impList) && STAR == fst(impList)) { + // Previously, I was forcing an import Prelude, + // but this precluded doing things like + // import Prelude hiding ( catch) + // so, for now, you need to put an explicit + // import Prelude if you use import privileged. + imports = resolveImportList(m, snd(impList),TRUE); } else { - imports = resolveImportList(m, impList); + imports = resolveImportList(m, impList,FALSE); } + for(; nonNull(imports); imports=tl(imports)) { Cell e = hd(imports); if (!cellIsMember(e,hidden)) @@ -485,6 +496,7 @@ Cell e; { switch (whatIs(e)) { case NAME : importName(source,e); break; + case TUPLE: case TYCON : importTycon(source,e); break; case CLASS : importClass(source,e); @@ -498,7 +510,8 @@ Module source; Name n; { Name clash = addName(n); if (nonNull(clash) && clash!=n) { - ERRMSG(0) "Entity \"%s\" imported from module \"%s\" already defined in module \"%s\"", + ERRMSG(0) "Entity \"%s\" imported from module \"%s\"" + " already defined in module \"%s\"", textToStr(name(n).text), textToStr(module(source).text), textToStr(module(name(clash).mod).text) @@ -679,9 +692,9 @@ Cell e; { return exports; /* NOTUSED */ } -static List local checkExports(exports) -List exports; { - Module m = lastModule(); +static List local checkExports ( List exports, Module thisModule ) +{ + Module m = thisModule; Text mt = module(m).text; List es = NIL; @@ -953,8 +966,9 @@ Cell cd; { /* definitions (w or w/o deriving) */ con = ty; } - if (nr2>0) /* Add rank 2 annotation */ - type = ap(RANK2,pair(mkInt(nr2),type)); + if (nr2>0) { /* Add rank 2 annotation */ + type = ap(RANK2,pair(mkInt(nr2-length(lps)),type)); + } if (nonNull(evs)) { /* Add existential annotation */ if (nonNull(derivs)) { @@ -1017,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; @@ -1238,6 +1253,7 @@ List fds; { /* functional dependencies */ cclass(nw).members = ms; cclass(nw).level = 0; cclass(nw).fds = fds; + cclass(nw).xfds = NIL; classDefns = cons(nw,classDefns); if (arity!=1) h98DoesntSupport(line,"multiple parameter classes"); @@ -1296,7 +1312,7 @@ Class c; { /* Check for trivial dependency */ - if (isNull(snd(fd))) { + if (isNull(vs)) { ERRMSG(cclass(c).line) "Functional dependency is trivial" EEND; } @@ -1358,6 +1374,78 @@ Class c; { tcDeps = NIL; } + +/* -------------------------------------------------------------------------- + * Functional dependencies are inherited from superclasses. + * For example, if I've got the following classes: + * + * class C a b | a -> b + * class C [b] a => D a b + * + * then C will have the dependency ([a], [b]) as expected, and D will inherit + * the dependency ([b], [a]) from C. + * When doing pairwise improvement, we have to consider not just improving + * when we see a pair of Cs or a pair of Ds in the context, but when we've + * got a C and a D as well. In this case, we only improve when the + * predicate in question matches the type skeleton in the relevant superclass + * constraint. E.g., we improve the pair (C [Int] a, D b Int) (unifying + * a and b), but we don't improve the pair (C Int a, D b Int). + * To implement functional dependency inheritance, we calculate + * the closure of all functional dependencies, and store the result + * in an additional field `xfds' (extended functional dependencies). + * The `xfds' field is a list of functional dependency lists, annotated + * with a list of predicate skeletons constraining when improvement can + * happen against this dependency list. For example, the xfds field + * for C above would be: + * [([C a b], [([a], [b])])] + * and the xfds field for D would be: + * [([C [b] a, D a b], [([b], [a])])] + * Self-improvement (of a C with a C, or a D with a D) is treated as a + * special case of an inherited dependency. + * ------------------------------------------------------------------------*/ +static List local inheritFundeps ( Class c, Cell pi, Int o ) +{ + Int alpha = newKindedVars(cclass(c).kinds); + List scs = cclass(c).supers; + List xfds = NIL; + Cell this = NIL; + /* better not fail ;-) */ + if (!matchPred(pi,o,cclass(c).head,alpha)) + internal("inheritFundeps - predicate failed to match it's own head!"); + this = copyPred(pi,o); + for (; nonNull(scs); scs=tl(scs)) { + Class s = getHead(hd(scs)); + if (isClass(s)) { + List sfds = inheritFundeps(s,hd(scs),alpha); + for (; nonNull(sfds); sfds=tl(sfds)) { + Cell h = hd(sfds); + xfds = cons(pair(cons(this,fst(h)),snd(h)),xfds); + } + } + } + if (nonNull(cclass(c).fds)) { + List fds = NIL, fs = cclass(c).fds; + for (; nonNull(fs); fs=tl(fs)) { + fds = cons(pair(otvars(this,fst(hd(fs))), + otvars(this,snd(hd(fs)))),fds); + } + xfds = cons(pair(cons(this,NIL),fds),xfds); + } + return xfds; +} + +static Void local extendFundeps ( Class c ) +{ + Int alpha; + emptySubstitution(); + alpha = newKindedVars(cclass(c).kinds); + cclass(c).xfds = inheritFundeps(c,cclass(c).head,alpha); + + /* we can now check for ambiguity */ + map1Proc(checkMems2,c,fst(cclass(c).members)); +} + + static Cell local depPredExp(line,tyvars,pred) Int line; List tyvars; @@ -1460,6 +1548,14 @@ Cell m; { h98CheckType(line,"member type",hd(vs),t); } +static Void local checkMems2(c,m) /* check member function details */ +Class c; +Cell m; { + Int line = intOf(fst3(m)); + List vs = snd3(m); + Type t = thd3(m); +} + static Void local addMembers(c) /* Add definitions of member funs */ Class c; { /* and other parts of class struct.*/ List ms = fst(cclass(c).members); @@ -1509,8 +1605,13 @@ Class c; { /* and other parts of class struct.*/ */ mno = cclass(c).numSupers + cclass(c).numMembers; - cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,NIL); - implementCfun(cclass(c).dcon,NIL); /* ADR addition */ + /* cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,NIL); */ + cclass(c).dcon = addPrimCfun(generateText(":D%s",c),mno,0,NIL); + /* implementCfun(cclass(c).dcon,NIL); + Don't manufacture a wrapper fn for dictionary constructors. + Applications of dictionary constructors are always saturated, + and translate.c:stgExpr() special-cases saturated constructor apps. + */ if (mno==1) { /* Single entry dicts use newtype */ name(cclass(c).dcon).defn = nameId; @@ -1541,17 +1642,17 @@ Class parent; { name(m).arity = 1; name(m).number = mfunNo(no); name(m).type = t; - name(m).inlineMe = TRUE; return m; } -static Name local newDSel(c,no) /* Make definition for dict selectr*/ +Name newDSel(c,no) /* Make definition for dict selectr*/ Class c; Int no; { Name s; char buf[16]; - sprintf(buf,"sc%d.%s",no,"%s"); + /* sprintf(buf,"sc%d.%s",no,"%s"); */ + sprintf(buf,"$p%d%s",no+1,"%s"); s = newName(generateText(buf,c),c); name(s).line = cclass(c).line; name(s).arity = 1; @@ -1575,7 +1676,7 @@ Class c; { /* to each class. */ return findText(buffer); } -static Int local visitClass(c) /* visit class defn to check that */ + Int visitClass(c) /* visit class defn to check that */ Class c; { /* class hierarchy is acyclic */ #if TREX if (isExt(c)) { /* special case for lacks preds */ @@ -1666,12 +1767,16 @@ List xs; { * occur in the type expression when read from left to right. * ------------------------------------------------------------------------*/ -static List local typeVarsIn(ty,us,ws,vs)/*Calculate list of type variables*/ +List local typeVarsIn(ty,us,ws,vs) /*Calculate list of type variables*/ Cell ty; /* used in type expression, reading*/ List us; /* from left to right ignoring any */ List ws; /* listed in us. */ List vs; { /* ws = explicitly quantified vars */ + if (isNull(ty)) return vs; switch (whatIs(ty)) { + case DICTAP : return typeVarsIn(snd(snd(ty)),us,ws,vs); + case UNBOXEDTUP: return typeVarsIn(snd(ty),us,ws,vs); + case AP : return typeVarsIn(snd(ty),us,ws, typeVarsIn(fst(ty),us,ws,vs)); @@ -1698,8 +1803,14 @@ List vs; { /* ws = explicitly quantified vars */ } return vs; } + case TUPLE: + case TYCON: + case CONIDCELL: + case QUALIDENT: return vs; + + default: fprintf(stderr, " bad tag = %d\n", whatIs(ty));internal("typeVarsIn"); } - return vs; + assert(0); } static List local maybeAppendVar(v,vs) /* append variable to list if not */ @@ -1762,7 +1873,7 @@ Type type; { } if (nonNull(tvs)) { - if (length(tvs)>=NUM_OFFSETS) { + if (length(tvs) >= (OFF_MAX-OFF_MIN+1)) { ERRMSG(line) "Too many type variables in %s\n", where EEND; } else { @@ -2005,7 +2116,9 @@ List vs; { else return cons(t,vs); - case OFFSET : internal("zonkTyvarsIn"); + /* this case will lead to a type error -- + much better than reporting an internal error ;-) */ + /* case OFFSET : internal("zonkTyvarsIn"); */ default : return vs; } @@ -2025,7 +2138,6 @@ static List local otvarsZonk(pi,os,o) /* same as above, but zonks */ Cell pi; List os; { List us = NIL; - List vs = NIL; for (; nonNull(os); os=tl(os)) { Type t = zonkType(nthArg(offsetOf(hd(os)),pi),o); us = zonkTyvarsIn(t,us); @@ -2102,11 +2214,14 @@ List ps; { Cell pi = hd(ps); Cell c = getHead(pi); if (isClass(c)) { - List fs = cclass(c).fds; - for (; nonNull(fs); fs=tl(fs)) { - fds = cons(pair(otvars(pi,fst(hd(fs))), - otvars(pi,snd(hd(fs)))),fds); - } + List xfs = cclass(c).xfds; + for (; nonNull(xfs); xfs=tl(xfs)) { + List fs = snd(hd(xfs)); + for (; nonNull(fs); fs=tl(fs)) { + fds = cons(pair(otvars(pi,fst(hd(fs))), + otvars(pi,snd(hd(fs)))),fds); + } + } } #if IPARAM else if (isIP(c)) { @@ -2126,10 +2241,13 @@ List ps; { Cell c = getHead(pi); Int o = intOf(snd3(pi3)); if (isClass(c)) { - List fs = cclass(c).fds; - for (; nonNull(fs); fs=tl(fs)) { - fds = cons(pair(otvarsZonk(pi,fst(hd(fs)),o), - otvarsZonk(pi,snd(hd(fs)),o)),fds); + List xfs = cclass(c).xfds; + for (; nonNull(xfs); xfs=tl(xfs)) { + List fs = snd(hd(xfs)); + for (; nonNull(fs); fs=tl(fs)) { + fds = cons(pair(otvarsZonk(pi,fst(hd(fs)),o), + otvarsZonk(pi,snd(hd(fs)),o)),fds); + } } } #if IPARAM @@ -2545,6 +2663,30 @@ Inst in; { ERRMSG(line) "Illegal predicate in instance declaration" EEND; } + + if (nonNull(cclass(inst(in).c).fds)) { + List fds = cclass(inst(in).c).fds; + for (; nonNull(fds); fds=tl(fds)) { + List as = otvars(inst(in).head, fst(hd(fds))); + List bs = otvars(inst(in).head, snd(hd(fds))); + List fs = calcFunDeps(inst(in).specifics); + as = oclose(fs,as); + if (!osubset(bs,as)) { + ERRMSG(inst(in).line) + "Instance is more general than a dependency allows" + ETHEN + ERRTEXT "\n*** Instance : " + ETHEN ERRPRED(inst(in).head); + ERRTEXT "\n*** For class : " + ETHEN ERRPRED(cclass(inst(in).c).head); + ERRTEXT "\n*** Under dependency : " + ETHEN ERRFD(hd(fds)); + ERRTEXT "\n" + EEND; + } + } + } + kindInst(in,length(tyvars)); insertInst(in); @@ -2884,6 +3026,7 @@ Inst in; { /* of the context for a derived */ List spcs = fst(snd(inst(in).specifics)); Int beta = inst(in).numSpecifics; Int its = 1; + Int factor = 1+length(ps); #ifdef DEBUG_DERIVING Printf("calcInstPreds: "); @@ -2894,9 +3037,8 @@ Inst in; { /* of the context for a derived */ while (nonNull(ps)) { Cell p = hd(ps); ps = tl(ps); - if (its++ >= cutoff) { + if (its++ >= factor*cutoff) { Cell bpi = inst(in).head; - Cell pi = copyPred(fun(p),intOf(snd(p))); ERRMSG(inst(in).line) "\n*** Cannot derive " ETHEN ERRPRED(bpi); ERRTEXT " after %d iterations.", its-1 ETHEN ERRTEXT @@ -3014,7 +3156,7 @@ Int beta; { return copyAdj(tyv->bound,tyv->offs,beta); } vn -= beta; - if (vn<0 || vn>=NUM_OFFSETS) { + if (vn<0 || vn>=(OFF_MAX-OFF_MIN+1)) { internal("copyAdj"); } return mkOffset(vn); @@ -3131,15 +3273,18 @@ static Void local checkDefaultDefns() { /* check that default types are */ * Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism. * They are used to "import" C functions into a module. * They are usually not written by hand but, rather, generated automatically - * by GreenCard, IDL compilers or whatever. + * by GreenCard, IDL compilers or whatever. We support foreign import + * (static) and foreign import dynamic. In the latter case, extName==NIL. * * Foreign export declarations generate C wrappers for Hugs functions. * Hugs only provides "foreign export dynamic" because it's not obvious * what "foreign export static" would mean in an interactive setting. * ------------------------------------------------------------------------*/ -Void foreignImport(line,extName,intName,type) /* Handle foreign imports */ +Void foreignImport(line,callconv,extName,intName,type) + /* Handle foreign imports */ Cell line; +Text callconv; Pair extName; Cell intName; Cell type; { @@ -3153,10 +3298,11 @@ Cell type; { ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t) EEND; } - name(n).line = l; - name(n).defn = extName; - name(n).type = type; - foreignImports = cons(n,foreignImports); + name(n).line = l; + name(n).defn = extName; + name(n).type = type; + name(n).callconv = callconv; + foreignImports = cons(n,foreignImports); } static Void local checkForeignImport(p) /* Check foreign import */ @@ -3173,8 +3319,10 @@ Name p; { implementForeignImport(p); } -Void foreignExport(line,extName,intName,type)/* Handle foreign exports */ +Void foreignExport(line,callconv,extName,intName,type) + /* Handle foreign exports */ Cell line; +Text callconv; Cell extName; Cell intName; Cell type; { @@ -3188,10 +3336,11 @@ Cell type; { ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t) EEND; } - name(n).line = l; - name(n).defn = NIL; /* nothing to say */ - name(n).type = type; - foreignExports = cons(n,foreignExports); + name(n).line = l; + name(n).defn = NIL; /* nothing to say */ + name(n).type = type; + name(n).callconv = callconv; + foreignExports = cons(n,foreignExports); } static Void local checkForeignExport(p) /* Check foreign export */ @@ -3279,7 +3428,6 @@ Cell p; { static Cell local checkMaybeCnkPat(l,p)/* Check applicative pattern with */ Int l; /* the possibility of n+k pattern */ Cell p; { -#if NPLUSK Cell h = getHead(p); if (argCount==2 && isVar(h) && textOf(h)==textPlus) { /* n+k */ @@ -3297,7 +3445,6 @@ Cell p; { arg(p) = checkPat(l,v); return p; } -#endif return checkApPat(l,0,p); } @@ -4366,7 +4513,7 @@ Cell g; { /* expression */ static Cell local depExpr(line,e) /* find dependents of expression */ Int line; Cell e; { - // Printf( "\n\n"); print(e,100); Printf("\n"); + //Printf( "\n\n"); print(e,100); Printf("\n"); //printExp(stdout,e); switch (whatIs(e)) { @@ -4573,9 +4720,6 @@ Cell e; { EEND; } - if (!moduleThisScript(name(n).mod)) { - return n; - } /* Later phases of the system cannot cope if we resolve references * to unprocessed objects too early. This is the main reason that * we cannot cope with recursive modules at the moment. @@ -4859,7 +5003,8 @@ Void checkExp() { /* Top level static check on Expr */ staticAnalysis(RESET); } -Void checkContext() { /* Top level static check on Expr */ +#if EXPLAIN_INSTANCE_RESOLUTION +Void checkContext(void) { /* Top level static check on Expr */ List vs, qs; staticAnalysis(RESET); @@ -4873,9 +5018,11 @@ Void checkContext() { /* Top level static check on Expr */ leaveScope(); staticAnalysis(RESET); } +#endif + +Void checkDefns ( Module thisModule ) { /* Top level static analysis */ + Text modName = module(thisModule).text; -Void checkDefns() { /* Top level static analysis */ - Module thisModule = lastModule(); staticAnalysis(RESET); setCurrModule(thisModule); @@ -4884,27 +5031,39 @@ Void checkDefns() { /* Top level static analysis */ mapProc(checkQualImport, module(thisModule).qualImports); mapProc(checkUnqualImport,unqualImports); /* Add "import Prelude" if there`s no explicit import */ - if (thisModule!=modulePrelude - && isNull(cellAssoc(modulePrelude,unqualImports)) - && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) { - unqualImports = cons(pair(modulePrelude,DOTDOT),unqualImports); + if (modName == textPrelPrim || modName == textPrelude) { + /* Nothing. */ + } else if (isNull(cellAssoc(modulePrelude,unqualImports)) + && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) { + unqualImports = cons(pair(modulePrelude,DOTDOT),unqualImports); } else { - /* Every module (including the Prelude) implicitly contains - * "import qualified Prelude" - */ - module(thisModule).qualImports=cons(pair(mkCon(textPrelude),modulePrelude), - module(thisModule).qualImports); + /* Every module implicitly contains "import qualified Prelude" + */ + module(thisModule).qualImports + =cons(pair(mkCon(textPrelude),modulePrelude), + module(thisModule).qualImports); } mapProc(checkImportList, unqualImports); - linkPreludeTC(); /* Get prelude tycons and classes */ + /* Note: there's a lot of side-effecting going on here, so + don't monkey about with the order of operations here unless + you know what you are doing */ + if (!combined) linkPreludeTC(); /* Get prelude tycons and classes */ + mapProc(checkTyconDefn,tyconDefns); /* validate tycon definitions */ checkSynonyms(tyconDefns); /* check synonym definitions */ mapProc(checkClassDefn,classDefns); /* process class definitions */ mapProc(kindTCGroup,tcscc(tyconDefns,classDefns)); /* attach kinds */ + mapProc(visitClass,classDefns); /* check class hierarchy */ + mapProc(extendFundeps,classDefns); /* finish class definitions */ + /* (convenient if we do this after */ + /* calling `visitClass' so that we */ + /* know the class hierarchy is */ + /* acyclic) */ + mapProc(addMembers,classDefns); /* add definitions for member funs */ - mapProc(visitClass,classDefns); /* check class hierarchy */ - linkPreludeCM(); /* Get prelude cfuns and mfuns */ + + if (!combined) linkPreludeCM(); /* Get prelude cfuns and mfuns */ instDefns = rev(instDefns); /* process instance definitions */ mapProc(checkInstDefn,instDefns); @@ -4920,7 +5079,7 @@ Void checkDefns() { /* Top level static analysis */ mapProc(allNoPrevDef,valDefns); /* check against previous defns */ - linkPreludeNames(); + if (!combined) linkPrimNames(); /* link primitive names */ mapProc(checkForeignImport,foreignImports); /* check foreign imports */ mapProc(checkForeignExport,foreignExports); /* check foreign exports */ @@ -4931,7 +5090,8 @@ Void checkDefns() { /* Top level static analysis */ /* export list. Note that this has to happen before dependency */ /* analysis so that references to Prelude.foo will be resolved */ /* when compiling the prelude. */ - module(thisModule).exports = checkExports(module(thisModule).exports); + module(thisModule).exports + = checkExports ( module(thisModule).exports, thisModule ); mapProc(checkTypeIn,typeInDefns); /* check restricted synonym defns */ @@ -5129,11 +5289,12 @@ Int what; { #endif break; - case INSTALL : staticAnalysis(RESET); + case POSTPREL: break; + + case PREPREL : staticAnalysis(RESET); #if TREX extKind = pair(STAR,pair(ROW,ROW)); #endif - break; } }