/* --------------------------------------------------------------------------
* compiler.c: Copyright (c) Mark P Jones 1991-1998. All rights reserved.
* See NOTICE for details and conditions of use etc...
* Hugs version 1.3b, January 1998
*
* This is the Hugs compiler, handling translation of typechecked code to
* `kernel' language, elimination of pattern matching and translation to
* super combinators (lambda lifting).
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"
/*#define DEBUG_CODE*/
/*#define DEBUG_SHOWSC*/ /* Must also be set in output.c */
Addr inputCode; /* Addr of compiled code for expr */
/* --------------------------------------------------------------------------
* Local function prototypes:
* ------------------------------------------------------------------------*/
static Cell local translate Args((Cell));
static Void local transBindToAlt Args((Cell));
static List local mkTuplePat Args((List));
static Cell local transTempl2 Args((Cell));
static Void local transPair Args((Pair));
static Void local transTriple Args((Triple));
static Void local transAlt Args((Cell));
static Void local transCase Args((Cell));
static List local transBinds Args((List));
static Cell local transRhs Args((Cell));
static Cell local mkConsList Args((List));
static Cell local expandLetrec Args((Cell));
static Cell local transComp Args((Cell,List,Cell));
static List local mkQuals Args((List));
static Cell local transDo Args((Cell,Cell,Cell,Cell,List));
static Cell local refutePat Args((Cell));
static Cell local refutePatAp Args((Cell));
static Cell local matchPat Args((Cell));
static List local remPat Args((Cell,Cell,List));
static List local remPat1 Args((Cell,Cell,List));
static Cell local pmcTerm Args((Int,List,Cell));
static Cell local pmcPair Args((Int,List,Pair));
static Cell local pmcTriple Args((Int,List,Triple));
static Cell local pmcVar Args((List,Text));
static Void local pmcLetrec Args((Int,List,Pair));
static Cell local pmcVarDef Args((Int,List,List));
static Void local pmcFunDef Args((Int,List,Triple));
static List local altsMatch Args((Int,Int,List,List));
static Cell local match Args((Int,List));
static Cell local joinMas Args((Int,List));
static Bool local canFail Args((Cell));
static List local addConTable Args((Cell,Cell,List));
static Void local advance Args((Int,Int,Cell));
static Bool local emptyMatch Args((Cell));
static Cell local maDiscr Args((Cell));
static Bool local isNumDiscr Args((Cell));
static Bool local eqNumDiscr Args((Cell,Cell));
static Cell local lift Args((Int,List,Cell));
static Void local liftPair Args((Int,List,Pair));
static Void local liftTriple Args((Int,List,Triple));
static Void local liftAlt Args((Int,List,Cell));
static Void local liftNumcase Args((Int,List,Triple));
static Cell local liftVar Args((List,Cell));
static Cell local liftLetrec Args((Int,List,Cell));
static Void local liftFundef Args((Int,List,Triple));
static Void local solve Args((List));
static Cell local preComp Args((Cell));
static Cell local preCompPair Args((Pair));
static Cell local preCompTriple Args((Triple));
static Void local preCompCase Args((Pair));
static Cell local preCompOffset Args((Int));
static Void local compileGlobalFunction Args((Pair));
static Void local compileMemberFunction Args((Name));
static Void local newGlobalFunction Args((Name,Int,List,Int,Cell));
/* --------------------------------------------------------------------------
* Translation: Convert input expressions into a less complex language
* of terms using only LETREC, AP, constants and vars.
* Also remove pattern definitions on lhs of eqns.
* ------------------------------------------------------------------------*/
#if OBJ
static Cell stateExp;
static Bool stateOpen;
static Bool usesState;
#endif
static Cell local translate(e) /* Translate expression: */
Cell e; {
switch (whatIs(e)) {
case LETREC : snd(snd(e)) = translate(snd(snd(e)));
return expandLetrec(e);
case COND : transTriple(snd(e));
return e;
case AP :
if (isName(fst(e)) && isStructSel(fst(e)))
return ap(translate(snd(e)),fst(e));
fst(e) = translate(fst(e));
if (fst(e)==nameId)
return translate(snd(e));
if (fst(e)==mkSelect(0))
return translate(snd(e));
if (fst(e)==nameStrict)
return nameIStrict;
if (fst(e)==nameSeq)
return nameISeq;
snd(e) = translate(snd(e));
return e;
#if BIGNUMS
case POSNUM :
case ZERONUM :
case NEGNUM : return e;
#endif
case NAME : if (e==nameOtherwise)
return nameTrue;
{ String str = textToStr(name(e).text);
str = str;
}
if (isCfun(e)) {
if (isStructSel(e)) {
Cell x = inventVar();
return translate(ap(LAMBDA,
pair(singleton(x),
pair(mkInt(0),
ap(e,x)))));
}
if (isName(name(e).defn))
return name(e).defn;
if (isPair(name(e).defn))
return snd(name(e).defn);
}
return e;
case VAROPCELL :
case VARIDCELL :
#if OBJ
{ Text t = textOf(e);
String vname = textToStr(t);
Cell s;
if (isVar(stateExp)) {
if (t == textOf(stateExp))
usesState = TRUE;
}
else
for (s=stateExp; isAp(s); s=fun(s))
if (t == textOf(arg(s))) {
usesState = TRUE;
break;
}
}
/* fall-thru */
#endif
case TUPLE :
case SELECT :
case DICTVAR :
case DICTCELL :
case INTCELL :
case FLOATCELL :
case STRCELL :
case CHARCELL : return e;
case FINLIST : mapOver(translate,snd(e));
return mkConsList(snd(e));
case DOCOMP : { Cell m = fst3(fst(snd(e)));
Cell m0 = snd3(fst(snd(e)));
Cell mf = thd3(fst(snd(e)));
#if OBJ
Bool oldStateOpen = stateOpen;
stateOpen = TRUE;
#endif
e = transDo(m,m0,mf,fst(snd(snd(e))),snd(snd(snd(e))));
#if OBJ
stateOpen = oldStateOpen;
#endif
return e;
}
case COMP : return transComp(translate(fst(snd(e))),
snd(snd(e)),
nameNil);
#if LAZY_ST
case RUNST : fst(e) = nameSTRun;
snd(e) = translate(snd(e));
return e;
#endif
case CASE : { Cell nv = inventVar();
mapProc(transCase,snd(snd(e)));
return ap(LETREC,
pair(singleton(pair(nv,snd(snd(e)))),
ap(nv,translate(fst(snd(e))))));
}
case LAMBDA : { Cell nv = inventVar();
transAlt(snd(e));
return ap(LETREC,
pair(singleton(pair(nv,
singleton(snd(e)))),
nv));
}
case STRUCTVAL : { Cell nv = inventVar();
mapProc(transBindToAlt,snd(snd(e)));
if (nonNull(snd(snd(e))))
return ap(LETREC,
pair(singleton(pair(nv,
snd(snd(e)))),
nv));
else
return nameId;
}
#if OBJ
case HNDLEXP : { Cell hVar = inventVar(), x = inventVar();
Cell m = fst(fst(snd(e)));
List def = cons(pair(singleton(x),ap(ap(nameRaise,m),x)),NIL);
mapProc(transCase,snd(fst(snd(e))));
return ap(LETREC,
pair(singleton(pair(hVar,appendOnto(snd(fst(snd(e))),def))),
ap(ap(ap(nameCatch,m),
translate(snd(snd(e)))),
hVar)));
}
case TEMPLEXP : return transTempl2(e);
case ACTEXP : return ap(ap(namePrimAct,
varSelf),
translate(snd(e)));
case REQEXP : return ap(ap(namePrimReq,
varSelf),
translate(snd(e)));
#endif
default : internal("translate");
}
return e;
}
/* -------------------------------------------------------------------------
*
* translate (HANDLE {p_1 -> e_1; ...; p_n -> e_n} exp =
* LET _h p_1 = e_1
* ...
* _h p_n = e_n
* IN catchO exp _h
*
* ------------------------------------------------------------------------- */
/* -------------------------------------------------------------------------
* ...
* translate (sel exp) =
* (translate exp) sel
* translate sel =
* translate (\_n -> sel _n)
*
* translate (STRUCT {sel_1 = e_1;...;sel_n = e_n}) = (n >= 1)
* LET _n sel_1 = e_1
* ...
* _n sel_n = e_n
* IN _n
* translate (STRUCT {}) =
* id
*
* ------------------------------------------------------------------------- */
static Void local transBindToAlt(b)
Cell b; {
List alts = snd(b);
if (!isName(fst(b)))
internal("transBindToAlt");
mapProc(transAlt,alts);
fst(b) = singleton(fst(b));
if (isNull(fst(hd(alts))))
snd(b) = snd(hd(alts));
else {
Cell nv = inventVar();
snd(b) = ap(LETREC,pair(singleton(pair(nv,alts)),nv));
}
}
#if OBJ
/* -------------------------------------------------------------------------
* ...
* translate (ACTION stmts) =
* primAct self (translate (DO stmts))
*
* translate (REQUEST stmts) =
* primReq self (translate (DO stmts))
*
* translate (TEMPLATE p_1 := e_1 ... p_n := e_n
* p'_1 <- e'_1 ... p'_n' <- e'_n'
* HANDLE p"_1 -> e"_1 ... p"_n" -> e"_n"
* IN e)
* =
* translate (FIX p'_1 <- e'_1
* ...
* p'_n' <- e'_n'
* self <- let _h2 p_1 ... p_n = stateExp
* _h4 p"_1 = e"_1
* ...
* _h4 p"_n" = e"_n"
* _h4 _x = failO _x
* in primTempl (_h2 e_1 ... e_n) _h4
* return e)
* ------------------------------------------------------------------------- */
static List local mkTuplePat(bs) /* make a tuple pattern from the */
List bs; { /* variables bound in a list of */
Int n = 0; /* pattern bindings */
List pat = NIL;
for (; nonNull(bs); bs=tl(bs)) {
List vs = fst(hd(bs));
for (; nonNull(vs); vs=tl(vs), n++)
pat = ap(pat,hd(vs));
}
if (n==0)
pat = nameUnit;
else if (n==1)
pat = arg(pat);
else {
Cell s = pat;
while (nonNull(fun(s)))
s = fun(s);
fun(s) = mkTuple(n);
}
return pat;
}
static Cell local transTempl2(e)
Cell e; { /* snd :: (([Decl],([Var],[Gen])),(Exp,[Alt])) */
Cell oldStateExp = stateExp;
Bool oldStateOpen = stateOpen;
List bs = fst(fst(snd(e)));
List vs = fst(snd(fst(snd(e))));
List gs = snd(snd(fst(snd(e))));
Cell e0 = fst(snd(snd(e)));
List as = rev(snd(snd(snd(e))));
Cell h2 = inventVar(), h4 = inventVar(), x = inventVar();
List ld2, ld4, qs;
Cell e1 = h2;
List ps = NIL;
stateExp = mkTuplePat(fst(fst(snd(e))));
stateOpen = FALSE;
for (; nonNull(bs); bs=tl(bs)) {
ps = cons(fst(snd(hd(bs))),ps);
e1 = ap(e1,snd(snd(snd(hd(bs)))));
}
ld2 = cons(pair(rev(ps),pair(0,stateExp)),NIL);
ld4 = cons(pair(singleton(x),pair(0,ap(nameRaiseO,x))),NIL);
for (; nonNull(as); as=tl(as)) {
Cell c = hd(as);
fst(c) = singleton(fst(c));
ld4 = cons(c,ld4);
}
e1 = ap(LETREC,
pair(singleton(cons(pair(h2,ld2),
cons(pair(h4,ld4),
NIL))),
ap(ap(namePrimTempl,
e1),
h4)));
qs = singleton(ap(FIXDO,pair(cons(varSelf,vs),cons(pair(varSelf,e1),gs))));
e1 = ap(DOCOMP, pair(triple(dictMonadTempl,NIL,dictFixMonadTempl),
pair(ap(ap(nameReturn,dictMonadTempl),e0),qs)));
e1 = translate(e1);
stateExp = oldStateExp;
stateOpen = oldStateOpen;
return e1;
}
#endif
static Void local transPair(pr) /* Translate each component in a */
Pair pr; { /* pair of expressions. */
fst(pr) = translate(fst(pr));
snd(pr) = translate(snd(pr));
}
static Void local transTriple(tr) /* Translate each component in a */
Triple tr; { /* triple of expressions. */
fst3(tr) = translate(fst3(tr));
snd3(tr) = translate(snd3(tr));
thd3(tr) = translate(thd3(tr));
}
static Void local transAlt(e) /* Translate alt: */
Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */
snd(e) = transRhs(snd(e));
}
static Void local transCase(c) /* Translate case: */
Cell c; { /* (Pat, Rhs) ==> ([Pat], Rhs') */
fst(c) = singleton(fst(c));
snd(c) = transRhs(snd(c));
}
static List local transBinds(bs) /* Translate list of bindings: */
List bs; { /* eliminating pattern matching on */
List newBinds; /* lhs of bindings. */
for (newBinds=NIL; nonNull(bs); bs=tl(bs)) {
if (isVar(fst(hd(bs)))) {
mapProc(transAlt,snd(hd(bs)));
newBinds = cons(hd(bs),newBinds);
}
else
newBinds = remPat(fst(snd(hd(bs))),
snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
newBinds);
}
return newBinds;
}
static Cell local transRhs(rhs) /* Translate rhs: removing line nos */
Cell rhs; {
switch (whatIs(rhs)) {
case LETREC : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
return expandLetrec(rhs);
case GUARDED : mapOver(snd,snd(rhs)); /* discard line number */
mapProc(transPair,snd(rhs));
return rhs;
default : return translate(snd(rhs)); /* discard line number */
}
}
static Cell local mkConsList(es) /* Construct expression for list es */
List es; { /* using nameNil and nameCons */
if (isNull(es))
return nameNil;
else
return ap(ap(nameCons,hd(es)),mkConsList(tl(es)));
}
static Cell local expandLetrec(root) /* translate LETREC with list of */
Cell root; { /* groups of bindings (from depend. */
Cell e = snd(snd(root)); /* analysis) to use nested LETRECs */
List bss = fst(snd(root));
Cell temp;
if (isNull(bss)) /* should never happen, but just in */
return e; /* case: LETREC [] IN e ==> e */
mapOver(transBinds,bss); /* translate each group of bindings */
for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
fst(snd(temp)) = hd(bss);
snd(snd(temp)) = ap(LETREC,pair(NIL,e));
temp = snd(snd(temp));
}
fst(snd(temp)) = hd(bss);
return root;
}
/* --------------------------------------------------------------------------
* Translation of list comprehensions is based on the description in
* `The Implementation of Functional Programming Languages':
*
* [ e | qs ] ++ l => transComp e qs l
* transComp e [] l => e : l
* transComp e ((p<-xs):qs) l => LETREC _h [] = l
* _h (p:_xs) = transComp e qs (_h _xs)
* _h (_:_xs) = _h _xs --if p !failFree
* IN _h xs
* transComp e (b:qs) l => if b then transComp e qs l else l
* transComp e (decls:qs) l => LETREC decls IN transComp e qs l
* ------------------------------------------------------------------------*/
static Cell local transComp(e,qs,l) /* Translate [e | qs] ++ l */
Cell e;
List qs;
Cell l; {
if (nonNull(qs)) {
Cell q = hd(qs);
Cell qs1 = tl(qs);
switch (fst(q)) {
case FROMQUAL : { Cell ld = NIL;
Cell hVar = inventVar();
Cell xsVar = inventVar();
if (!failFree(fst(snd(q))))
ld = cons(pair(singleton(
ap(ap(nameCons,
WILDCARD),
xsVar)),
ap(hVar,xsVar)),
ld);
ld = cons(pair(singleton(
ap(ap(nameCons,
fst(snd(q))),
xsVar)),
transComp(e,
qs1,
ap(hVar,xsVar))),
ld);
ld = cons(pair(singleton(nameNil),
l),
ld);
return ap(LETREC,
pair(singleton(pair(hVar,
ld)),
ap(hVar,
translate(snd(snd(q))))));
}
case QWHERE : return
expandLetrec(ap(LETREC,
pair(snd(q),
transComp(e,qs1,l))));
case BOOLQUAL : return ap(COND,
triple(translate(snd(q)),
transComp(e,qs1,l),
l));
}
}
return ap(ap(nameCons,e),l);
}
/* --------------------------------------------------------------------------
* Translation of monad comprehensions written using do-notation:
*
* do { e } => e
* do { p <- exp; qs } => LETREC _h p = do { qs }
* _h _ = zero{m0} -- if monad with 0
* IN exp >>={m} _h
* do { LET decls; qs } => LETREC decls IN do { qs }
* do { exp; qs } => LETREC _h _ = do { qs }
* IN exp >>={m} _h
*
* where m :: Monad f, m0 :: Monad0 f
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
*
* do { p := e; qs } => LETREC _h1 _ = do { qs }
* _h2 p = primSet stateExp
* IN _h2 e >>={m} _h1
*
* do { q; qs } => LETREC _h stateExp = do { q; qs }
* IN primGet >>={m} _h
* if q makes any reference to the local state
*
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
*
* do { FORALL p <- exp doexp; qs }
* => do { forallDo exp (\p -> doexp); qs }
* do { WHILE exp doexp; qs }
* => do { whileDo (do return exp) doexp; qs }
*
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
*
* do { FIX gens; qs } => do { p <- fixM (\p -> do gens; return p); qs }
*
* where p = (x_1,..,x_n) and x_1,..,x_n = vars bound by gens
*
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
*
* p!e1 := e2 => p := p // [(e1,e2)] (w/o overloading)
*
* (!) dict p e1 := e2 => p := (//) dict p [(e1,e2)]
*
* ------------------------------------------------------------------------*/
static List local mkQuals(gs)
List gs; {
List qs = NIL;
for (; nonNull(gs); gs=tl(gs))
qs = cons(ap(FROMQUAL,hd(gs)),qs);
return rev(qs);
}
static Cell local transDo(m,m0,mf,e,qs) /* Translate do { qs ; e } */
Cell m;
Cell m0;
Cell mf;
Cell e;
List qs; {
Cell e1;
#if OBJ
Bool oldUsesState = usesState;
usesState = FALSE;
#endif
if (nonNull(qs)) {
Cell q = hd(qs);
Cell qs1 = tl(qs);
switch (fst(q)) {
case FROMQUAL : { Cell ld = NIL;
Cell hVar = inventVar();
if (!failFree(fst(snd(q))) && nonNull(m0))
ld = cons(pair(singleton(WILDCARD),
ap(nameZero,m0)),ld);
ld = cons(pair(singleton(fst(snd(q))),
transDo(m,m0,mf,e,qs1)),
ld);
e1 = ap(LETREC,
pair(singleton(pair(hVar,ld)),
ap(ap(ap(nameBind,
m),
translate(snd(snd(q)))),
hVar)));
}
break;
case DOQUAL : { Cell hVar = inventVar();
Cell ld = cons(pair(singleton(WILDCARD),
transDo(m,m0,mf,e,qs1)),
NIL);
e1 = ap(LETREC,
pair(singleton(pair(hVar,ld)),
ap(ap(ap(nameBind,
m),
translate(snd(q))),
hVar)));
}
break;
case QWHERE : e1 = expandLetrec(ap(LETREC,
pair(snd(q),
transDo(m,m0,mf,e,qs1))));
break;
case BOOLQUAL : e1 = ap(COND,
triple(translate(snd(q)),
transDo(m,m0,mf,e,qs1),
ap(nameZero,m0)));
break;
#if OBJ
case FORALLDO : e1 = transDo(m,m0,mf,e,
cons(ap(DOQUAL,
ap(ap(ap(nameForall,m),
snd3(snd(q))),
ap(LAMBDA,pair(singleton(fst3(snd(q))),
pair(0,thd3(snd(q))))))),
qs1));
break;
case WHILEDO : e1 = transDo(m,m0,mf,e,
cons(ap(DOQUAL,
ap(ap(ap(nameWhile,m),
ap(DOCOMP,
pair(triple(m,m0,mf),
pair(ap(ap(nameReturn,m),
fst(snd(q))),
NIL)))),
snd(snd(q)))),
qs1));
break;
case FIXDO : { /* Hack: snd(q) is not a pattern binding, but */
/* mkTuplePat only looks at its fst part... */
Cell pat = mkTuplePat(singleton(snd(q)));
List qs = rev(mkQuals(snd(snd(q))));
Cell mdo = ap(DOCOMP,
pair(triple(m,m0,mf),
pair(ap(ap(nameReturn,m),pat),
qs)));
Cell f = ap(LAMBDA,pair(singleton(ap(LAZYPAT,pat)),pair(0,mdo)));
e1 = transDo(m,m0,mf,e,
cons(ap(FROMQUAL,
pair(pat,
ap(ap(nameFixM,mf),
f))),
qs1));
}
break;
case ASSIGNQ : { Cell hVar1 = inventVar();
Cell hVar2 = inventVar();
Cell ld1 = cons(pair(singleton(WILDCARD),
transDo(m,m0,mf,e,qs1)),
NIL);
Cell ld2;
Name upd = findName(findText("//"));
Cell h = getHead(fst(snd(q)));
while (argCount== 3 && isName(h) && name(h).text==textBang) {
Cell dict = arg(fun(fun(fst(snd(q)))));
Cell p = arg(fun(fst(snd(q))));
Cell e1 = arg(fst(snd(q)));
Cell e2 = snd(snd(snd(q)));
fst(snd(q)) = p;
snd(snd(snd(q))) = ap(ap(ap(upd,
dict),
p),
ap(ap(nameCons,
ap(ap(mkTuple(2),
e1),
e2)),
nameNil));
h = getHead(fst(snd(q)));
}
ld2 = cons(pair(singleton(fst(snd(q))),
ap(namePrimSet,stateExp)),
NIL);
e1 = ap(LETREC,
pair(cons(pair(hVar1,ld1),
cons(pair(hVar2,ld2),
NIL)),
ap(ap(ap(nameBind,
m),
ap(hVar2,
translate(snd(snd(snd(q)))))),
hVar1)));
usesState = TRUE;
}
break;
#endif
}
}
else
e1 = translate(e);
#if OBJ
if (usesState) {
Cell hVar = inventVar();
Cell ld = cons(pair(singleton(stateExp),e1),NIL);
e1 = ap(LETREC,pair(singleton(pair(hVar,ld)),
ap(ap(ap(nameBind,
m),
namePrimGet),
hVar)));
}
usesState = oldUsesState;
#endif
return e1;
}
/* --------------------------------------------------------------------------
* Elimination of pattern bindings:
*
* The following code adopts the definition of failure free patterns as given
* in the Haskell 1.3 report; the term "irrefutable" is also used there for
* a subset of the failure free patterns described here, but has no useful
* role in this implementation. Basically speaking, the failure free patterns
* are: variable, wildcard, ~apat
* var@apat, if apat is failure free
* C apat1 ... apatn if C is a product constructor
* (i.e. an only constructor) and
* apat1,...,apatn are failure free
* Note that the last case automatically covers the case where C comes from
* a newtype construction.
* ------------------------------------------------------------------------*/
Bool failFree(pat) /* is pattern failure free? (do we need */
Cell pat; { /* a conformality check?) */
Cell c = getHead(pat);
switch (whatIs(c)) {
case ASPAT : return failFree(snd(snd(pat)));
case NAME : if (!isCfun(c) || cfunOf(c)!=0)
return FALSE;
/*intentional fall-thru*/
case TUPLE : for (; isAp(pat); pat=fun(pat))
if (!failFree(arg(pat)))
return FALSE;
/*intentional fall-thru*/
case LAZYPAT :
case VAROPCELL :
case VARIDCELL :
case DICTVAR :
case WILDCARD : return TRUE;
default : return FALSE;
}
}
static Cell local refutePat(pat) /* find pattern to refute in conformality*/
Cell pat; { /* test with pat. */
/* e.g. refPat (x:y) == (_:_) */
/* refPat ~(x:y) == _ etc.. */
switch (whatIs(pat)) {
case ASPAT : return refutePat(snd(snd(pat)));
case FINLIST : { Cell ys = snd(pat);
Cell xs = NIL;
for (; nonNull(ys); ys=tl(ys))
xs = ap(ap(nameCons,refutePat(hd(ys))),xs);
return revOnto(xs,nameNil);
}
case VAROPCELL :
case VARIDCELL :
case DICTVAR :
case WILDCARD :
case LAZYPAT : return WILDCARD;
case STRCELL :
case CHARCELL :
#if NPLUSK
case ADDPAT :
#endif
case TUPLE :
case NAME : return pat;
case AP : return refutePatAp(pat);
default : internal("refutePat");
return NIL; /*NOTREACHED*/
}
}
static Cell local refutePatAp(p) /* find pattern to refute in conformality*/
Cell p; {
Cell h = getHead(p);
if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble)
return p;
#if NPLUSK
else if (whatIs(h)==ADDPAT)
return ap(fun(p),refutePat(arg(p)));
#endif
else {
List as = getArgs(p);
mapOver(refutePat,as);
return applyToArgs(h,as);
}
}
static Cell local matchPat(pat) /* find pattern to match against */
Cell pat; { /* replaces parts of pattern that do not */
/* include variables with wildcards */
switch (whatIs(pat)) {
case ASPAT : { Cell p = matchPat(snd(snd(pat)));
return (p==WILDCARD) ? fst(snd(pat))
: ap(ASPAT,
pair(fst(snd(pat)),p));
}
case FINLIST : { Cell ys = snd(pat);
Cell xs = NIL;
for (; nonNull(ys); ys=tl(ys))
xs = cons(matchPat(hd(ys)),xs);
while (nonNull(xs) && hd(xs)==WILDCARD)
xs = tl(xs);
for (ys=nameNil; nonNull(xs); xs=tl(xs))
ys = ap(ap(nameCons,hd(xs)),ys);
return ys;
}
case VAROPCELL :
case VARIDCELL :
case DICTVAR : return pat;
case LAZYPAT : { Cell p = matchPat(snd(pat));
return (p==WILDCARD) ? WILDCARD : ap(LAZYPAT,p);
}
case WILDCARD :
case STRCELL :
case CHARCELL : return WILDCARD;
case TUPLE :
case NAME :
case AP : { Cell h = getHead(pat);
if (h==nameFromInt ||
h==nameFromInteger || h==nameFromDouble)
return WILDCARD;
#if NPLUSK
else if (whatIs(h)==ADDPAT)
return pat;
#endif
else {
List args = NIL;
Bool avar = FALSE;
for (; isAp(pat); pat=fun(pat)) {
Cell p = matchPat(arg(pat));
if (p!=WILDCARD)
avar = TRUE;
args = cons(p,args);
}
return avar ? applyToArgs(pat,args)
: WILDCARD;
}
}
default : internal("matchPat");
return NIL; /*NOTREACHED*/
}
}
#define addEqn(v,val,lds) cons(pair(v,singleton(pair(NIL,val))),lds)
static List local remPat(pat,expr,lds)
Cell pat; /* Produce list of definitions for eqn */
Cell expr; /* pat = expr, including a conformality */
List lds; { /* check if required. */
/* Conformality test (if required):
* pat = expr ==> nv = LETREC confCheck nv@pat = nv
* IN confCheck expr
* remPat1(pat,nv,.....);
*/
if (!failFree(pat)) {
Cell confVar = inventVar();
Cell nv = inventVar();
Cell locfun = pair(confVar, /* confVar [([nv@refPat],nv)] */
singleton(pair(singleton(ap(ASPAT,
pair(nv,
refutePat(pat)))),
nv)));
if (whatIs(expr)==GUARDED) { /* A spanner ... special case */
lds = addEqn(nv,expr,lds); /* for guarded pattern binding*/
expr = nv;
nv = inventVar();
}
if (whatIs(pat)==ASPAT) { /* avoid using new variable if*/
nv = fst(snd(pat)); /* a variable is already given*/
pat = snd(snd(pat)); /* by an as-pattern */
}
lds = addEqn(nv, /* nv = */
ap(LETREC,pair(singleton(locfun), /* LETREC [locfun] */
ap(confVar,expr))), /* IN confVar expr */
lds);
return remPat1(matchPat(pat),nv,lds);
}
return remPat1(matchPat(pat),expr,lds);
}
static List local remPat1(pat,expr,lds)
Cell pat; /* Add definitions for: pat = expr to */
Cell expr; /* list of local definitions in lds. */
List lds; {
Cell c;
switch (whatIs(c=getHead(pat))) {
case WILDCARD :
case STRCELL :
case CHARCELL : break;
case ASPAT : return remPat1(snd(snd(pat)), /* v@pat = expr */
fst(snd(pat)),
addEqn(fst(snd(pat)),expr,lds));
case LAZYPAT : { Cell nv;
if (isVar(expr) || isName(expr))
nv = expr;
else {
nv = inventVar();
lds = addEqn(nv,expr,lds);
}
return remPat(snd(pat),nv,lds);
}
#if NPLUSK
case ADDPAT : return remPat1(arg(pat), /* n + k = expr */
ap(ap(ap(namePmSub,
arg(fun(pat))),
mkInt(snd(fun(fun(pat))))),
expr),
lds);
#endif
case FINLIST : return remPat1(mkConsList(snd(pat)),expr,lds);
case DICTVAR : /* shouldn't really occur */
case VARIDCELL :
case VAROPCELL : return addEqn(pat,expr,lds);
case NAME : if (c==nameFromInt || c==nameFromInteger
|| c==nameFromDouble)
break;
if (argCount==1 && isCfun(c) && /* for newtype */
cfunOf(c)==0 && name(c).defn==nameId)
return remPat1(arg(pat),expr,lds);
/* intentional fall-thru */
case TUPLE : { List ps = getArgs(pat);
if (nonNull(ps)) {
Cell nv, sel;
Int i;
if (isVar(expr) || isName(expr))
nv = expr;
else {
nv = inventVar();
lds = addEqn(nv,expr,lds);
}
sel = ap(ap(nameSel,c),nv);
for (i=1; nonNull(ps); ++i, ps=tl(ps))
lds = remPat1(hd(ps),
ap(sel,mkInt(i)),
lds);
}
}
break;
default : internal("remPat1");
break;
}
return lds;
}
/* --------------------------------------------------------------------------
* Eliminate pattern matching in function definitions -- pattern matching
* compiler:
*
* The original Gofer/Hugs pattern matching compiler was based on Wadler's
* algorithms described in `Implementation of functional programming
* languages'. That should still provide a good starting point for anyone
* wanting to understand this part of the system. However, the original
* algorithm has been generalized and restructured in order to implement
* new features added in Haskell 1.3.
*
* During the translation, in preparation for later stages of compilation,
* all local and bound variables are replaced by suitable offsets, and
* locally defined function symbols are given new names (which will
* eventually be their names when lifted to make top level definitions).
* ------------------------------------------------------------------------*/
static Offset freeBegin; /* only variables with offset <= freeBegin are of */
static List freeVars; /* interest as `free' variables */
static List freeFuns; /* List of `free' local functions */
static Cell local pmcTerm(co,sc,e) /* apply pattern matching compiler */
Int co; /* co = current offset */
List sc; /* sc = scope */
Cell e; { /* e = expr to transform */
switch (whatIs(e)) {
case GUARDED : map2Over(pmcPair,co,sc,snd(e));
break;
case LETREC : pmcLetrec(co,sc,snd(e));
break;
case VARIDCELL:
case VAROPCELL:
case DICTVAR : return pmcVar(sc,textOf(e));
case COND : return ap(COND,pmcTriple(co,sc,snd(e)));
case AP : return pmcPair(co,sc,e);
#if BIGNUMS
case POSNUM :
case ZERONUM :
case NEGNUM :
#endif
#if NPLUSK
case ADDPAT :
#endif
case TUPLE :
case NAME :
case SELECT :
case DICTCELL :
case CHARCELL :
case INTCELL :
case FLOATCELL:
case STRCELL : break;
default : printf("(%d)",whatIs(e)); internal("pmcTerm");
break;
}
return e;
}
static Cell local pmcPair(co,sc,pr) /* apply pattern matching compiler */
Int co; /* to a pair of exprs */
List sc;
Pair pr; {
return pair(pmcTerm(co,sc,fst(pr)),
pmcTerm(co,sc,snd(pr)));
}
static Cell local pmcTriple(co,sc,tr) /* apply pattern matching compiler */
Int co; /* to a triple of exprs */
List sc;
Triple tr; {
return triple(pmcTerm(co,sc,fst3(tr)),
pmcTerm(co,sc,snd3(tr)),
pmcTerm(co,sc,thd3(tr)));
}
static Cell local pmcVar(sc,t) /* find translation of variable */
List sc; /* in current scope */
Text t; {
List xs;
Name n;
for (xs=sc; nonNull(xs); xs=tl(xs)) {
Cell x = hd(xs);
if (t==textOf(fst(x)))
if (isOffset(snd(x))) { /* local variable ... */
if (snd(x)<=freeBegin && !cellIsMember(snd(x),freeVars))
freeVars = cons(snd(x),freeVars);
return snd(x);
}
else { /* local function ... */
if (!cellIsMember(snd(x),freeFuns))
freeFuns = cons(snd(x),freeFuns);
return fst3(snd(x));
}
}
if (isNull(n=findName(t))) /* Lookup global name - the only way*/
n = newName(t); /* this (should be able to happen) */
/* is with new global var introduced*/
/* after type check; e.g. remPat1 */
return n;
}
static Void local pmcLetrec(co,sc,e) /* apply pattern matching compiler */
Int co; /* to LETREC, splitting decls into */
List sc; /* two sections */
Pair e; {
List fs = NIL; /* local function definitions */
List vs = NIL; /* local variable definitions */
List ds;
for (ds=fst(e); nonNull(ds); ds=tl(ds)) { /* Split decls into two */
Cell v = fst(hd(ds));
Int arity = length(fst(hd(snd(hd(ds)))));
if (arity==0) { /* Variable declaration */
vs = cons(snd(hd(ds)),vs);
sc = cons(pair(v,mkOffset(++co)),sc);
}
else { /* Function declaration */
fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
sc = cons(pair(v,hd(fs)),sc);
}
}
vs = rev(vs); /* Put declaration lists back in */
fs = rev(fs); /* original order */
fst(e) = pair(vs,fs); /* Store declaration lists */
map2Over(pmcVarDef,co,sc,vs); /* Translate variable definitions */
map2Proc(pmcFunDef,co,sc,fs); /* Translate function definitions */
snd(e) = pmcTerm(co,sc,snd(e)); /* Translate LETREC body */
freeFuns = diffList(freeFuns,fs); /* Delete any `freeFuns' bound in fs*/
}
static Cell local pmcVarDef(co,sc,vd) /* apply pattern matching compiler */
Int co; /* to variable definition */
List sc;
List vd; { /* vd :: [ ([], rhs) ] */
Cell d = snd(hd(vd));
if (nonNull(tl(vd)) && canFail(d))
return ap(FATBAR,pair(pmcTerm(co,sc,d),
pmcVarDef(co,sc,tl(vd))));
return pmcTerm(co,sc,d);
}
static Void local pmcFunDef(co,sc,fd) /* apply pattern matching compiler */
Int co; /* to function definition */
List sc;
Triple fd; { /* fd :: (Var, Arity, [Alt]) */
Offset saveFreeBegin = freeBegin;
List saveFreeVars = freeVars;
List saveFreeFuns = freeFuns;
Int arity = intOf(snd3(fd));
Cell temp = altsMatch(co+1,arity,sc,thd3(fd));
Cell xs;
freeBegin = mkOffset(co);
freeVars = NIL;
freeFuns = NIL;
temp = match(co+arity,temp);
thd3(fd) = triple(freeVars,freeFuns,temp);
for (xs=freeVars; nonNull(xs); xs=tl(xs))
if (hd(xs)<=saveFreeBegin && !cellIsMember(hd(xs),saveFreeVars))
saveFreeVars = cons(hd(xs),saveFreeVars);
for (xs=freeFuns; nonNull(xs); xs=tl(xs))
if (!cellIsMember(hd(xs),saveFreeFuns))
saveFreeFuns = cons(hd(xs),saveFreeFuns);
freeBegin = saveFreeBegin;
freeVars = saveFreeVars;
freeFuns = saveFreeFuns;
}
/* ---------------------------------------------------------------------------
* Main part of pattern matching compiler: convert [Alt] to case constructs
*
* This section of Hugs has been almost completely rewritten to be more
* general, in particular, to allow pattern matching in orders other than the
* strictly left-to-right approach of the previous version. This is needed
* for the implementation of the so-called Haskell 1.3 `record' syntax. (VOID)
*
* At each stage, the different branches for the cases to be considered
* are represented by a list of values of type:
* Match ::= { maPats :: [Pat], patterns to match
* maOffs :: [Offs], offsets of corresponding values
* maSc :: Scope, mapping from vars to offsets
* maRhs :: Rhs } right hand side
* [Implementation uses nested pairs, ((pats,offs),(sc,rhs)).]
*
* The Scope component has type:
* Scope ::= [(Var,Expr)]
* and provides a mapping from variable names to offsets used in the matching
* process.
*
* Matches can be normalized by reducing them to a form in which the list
* of patterns is empty (in which case the match itself is described as an
* empty match), or in which the list is non-empty and the first pattern is
* one that requires either a CASE or NUMCASE (or EXTCASE) to decompose.
* ------------------------------------------------------------------------*/
#define mkMatch(ps,os,sc,r) pair(pair(ps,os),pair(sc,r))
#define maPats(ma) fst(fst(ma))
#define maOffs(ma) snd(fst(ma))
#define maSc(ma) fst(snd(ma))
#define maRhs(ma) snd(snd(ma))
#define extSc(v,o,ma) maSc(ma) = cons(pair(v,o),maSc(ma))
static List local altsMatch(co,n,sc,as) /* Make a list of matches from list*/
Int co; /* of Alts, with initial offsets */
Int n; /* reverse (take n [co..]) */
List sc;
List as; {
List mas = NIL;
List us = NIL;
for (; n>0; n--)
us = cons(mkOffset(co++),us);
for (; nonNull(as); as=tl(as)) /* Each Alt is ([Pat], Rhs) */
mas = cons(mkMatch(fst(hd(as)),us,sc,snd(hd(as))),mas);
return rev(mas);
}
static Cell local match(co,mas) /* Generate case statement for Matches mas */
Int co; /* at current offset co */
List mas; { /* N.B. Assumes nonNull(mas). */
Cell srhs = NIL; /* Rhs for selected matches */
List smas = mas; /* List of selected matches */
mas = tl(mas);
tl(smas) = NIL;
if (emptyMatch(hd(smas))) { /* The case for empty matches: */
while (nonNull(mas) && emptyMatch(hd(mas))) {
List temp = tl(mas);
tl(mas) = smas;
smas = mas;
mas = temp;
}
srhs = joinMas(co,rev(smas));
}
else { /* Non-empty match */
Int o = offsetOf(hd(maOffs(hd(smas))));
Cell d = maDiscr(hd(smas));
if (isNumDiscr(d)) { /* Numeric match */
Int da = discrArity(d);
Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
while (nonNull(mas) && !emptyMatch(hd(mas))
&& o==offsetOf(hd(maOffs(hd(mas))))
&& isNumDiscr(d=maDiscr(hd(mas)))
&& eqNumDiscr(d,d1)) {
List temp = tl(mas);
tl(mas) = smas;
smas = mas;
mas = temp;
}
smas = rev(smas);
map2Proc(advance,co,da,smas);
srhs = ap(NUMCASE,triple(mkOffset(o),d1,match(co+da,smas)));
}
else { /* Constructor match */
List tab = addConTable(d,hd(smas),NIL);
Int da;
while (nonNull(mas) && !emptyMatch(hd(mas))
&& o==offsetOf(hd(maOffs(hd(mas))))
&& !isNumDiscr(d=maDiscr(hd(mas)))) {
tab = addConTable(d,hd(mas),tab);
mas = tl(mas);
}
for (tab=rev(tab); nonNull(tab); tab=tl(tab)) {
d = fst(hd(tab));
smas = snd(hd(tab));
da = discrArity(d);
map2Proc(advance,co,da,smas);
srhs = cons(pair(d,match(co+da,smas)),srhs);
}
srhs = ap(CASE,pair(mkOffset(o),srhs));
}
}
return nonNull(mas) ? ap(FATBAR,pair(srhs,match(co,mas))) : srhs;
}
static Cell local joinMas(co,mas) /* Combine list of matches into rhs*/
Int co; /* using FATBARs as necessary */
List mas; { /* Non-empty list of empty matches */
Cell ma = hd(mas);
Cell rhs = pmcTerm(co,maSc(ma),maRhs(ma));
if (nonNull(tl(mas)) && canFail(rhs))
return ap(FATBAR,pair(rhs,joinMas(co,tl(mas))));
else
return rhs;
}
static Bool local canFail(rhs) /* Determine if expression (as rhs) */
Cell rhs; { /* might ever be able to fail */
switch (whatIs(rhs)) {
case LETREC : return canFail(snd(snd(rhs)));
case GUARDED : return TRUE; /* could get more sophisticated ..? */
default : return FALSE;
}
}
/* type Table a b = [(a, [b])]
*
* addTable :: a -> b -> Table a b -> Table a b
* addTable x y [] = [(x,[y])]
* addTable x y (z@(n,sws):zs)
* | n == x = (n,sws++[y]):zs
* | otherwise = (n,sws):addTable x y zs
*/
static List local addConTable(x,y,tab) /* add element (x,y) to table */
Cell x, y;
List tab; {
if (isNull(tab))
return singleton(pair(x,singleton(y)));
else if (fst(hd(tab))==x)
snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
else
tl(tab) = addConTable(x,y,tl(tab));
return tab;
}
static Void local advance(co,a,ma) /* Advance non-empty match by */
Int co; /* processing head pattern */
Int a; /* discriminator arity */
Cell ma; {
Cell p = hd(maPats(ma));
List ps = tl(maPats(ma));
List us = tl(maOffs(ma));
for (; a>0; --a) { /* and corresponding offsets ... */
us = cons(mkOffset(++co),us);
ps = cons(arg(p),ps);
p = fun(p);
}
maPats(ma) = ps;
maOffs(ma) = us;
}
/* --------------------------------------------------------------------------
* Normalize and test for empty match:
* ------------------------------------------------------------------------*/
static Bool local emptyMatch(ma)/* Normalize and test to see if a given */
Cell ma; { /* match, ma, is empty. */
while (nonNull(maPats(ma))) {
Cell p;
tidyHd: switch (whatIs(p=hd(maPats(ma)))) {
case LAZYPAT : { Cell nv = inventVar();
maRhs(ma) = ap(LETREC,
pair(remPat(snd(p),nv,NIL),
maRhs(ma)));
p = nv;
}
/* intentional fall-thru */
case VARIDCELL :
case VAROPCELL :
case DICTVAR : extSc(p,hd(maOffs(ma)),ma);
case WILDCARD : maPats(ma) = tl(maPats(ma));
maOffs(ma) = tl(maOffs(ma));
continue;
/* So-called "as-patterns"are really just pattern intersections:
* (p1@p2:ps, o:os, sc, e) ==> (p1:p2:ps, o:o:os, sc, e)
* (But the input grammar probably doesn't let us take
* advantage of this, so we stick with the special case
* when p1 is a variable.)
*/
case ASPAT : extSc(fst(snd(p)),hd(maOffs(ma)),ma);
hd(maPats(ma)) = snd(snd(p));
goto tidyHd;
case FINLIST : hd(maPats(ma)) = mkConsList(snd(p));
return FALSE;
case STRCELL : { String s = textToStr(textOf(p));
for (p=NIL; *s!='\0'; ++s)
if (*s!='\\' || *++s=='\\')
p = ap(consChar(*s),p);
else
p = ap(consChar('\0'),p);
hd(maPats(ma)) = revOnto(p,nameNil);
}
return FALSE;
case AP : if (isName(fun(p)) &&
isCfun(fun(p)) &&
cfunOf(fun(p))==0 &&
name(fun(p)).defn==nameId) {
hd(maPats(ma)) = arg(p);
goto tidyHd;
}
/* intentional fall-thru */
case CHARCELL :
case NAME : return FALSE;
default : internal("emptyMatch");
}
}
return TRUE;
}
/* --------------------------------------------------------------------------
* Discriminators:
* ------------------------------------------------------------------------*/
static Cell local maDiscr(ma) /* Get the discriminator for a non-empty */
Cell ma; { /* match, ma. */
Cell p = hd(maPats(ma));
Cell h = getHead(p);
switch (whatIs(h)) {
#if NPLUSK
case ADDPAT : return fun(p);
#endif
case NAME : if (h==nameFromInt || h==nameFromInteger
|| h==nameFromDouble)
return p;
}
return h;
}
static Bool local isNumDiscr(d) /* TRUE => numeric discriminator */
Cell d; {
switch (whatIs(d)) {
case NAME :
case TUPLE :
case CHARCELL : return FALSE;
case AP : return TRUE; /* must be a literal or (n+k) */
}
internal("isNumDiscr");
return 0;/*NOTREACHED*/
}
Int discrArity(d) /* Find arity of discriminator */
Cell d; {
switch (whatIs(d)) {
case NAME : return name(d).arity;
case TUPLE : return tupleOf(d);
case CHARCELL : return 0;
#if NPLUSK
case AP : return (whatIs(fun(d))==ADDPAT) ? 1 : 0;
#else
case AP : return 0; /* must be an Int or Float lit */
#endif
}
internal("discrArity");
return 0;/*NOTREACHED*/
}
static Bool local eqNumDiscr(d1,d2) /* Determine whether two numeric */
Cell d1, d2; { /* descriptors have same value */
#if NPLUSK
if (whatIs(fun(d1))==ADDPAT)
return whatIs(fun(d2))==ADDPAT && snd(fun(d1))==snd(fun(d2));
#endif
if (isInt(arg(d1)))
return isInt(arg(d2)) && intOf(arg(d1))==intOf(arg(d2));
if (isFloat(arg(d1)))
return isFloat(arg(d2)) && floatOf(arg(d1))==floatOf(arg(d2));
#if BIGNUMS
if (isBignum(arg(d1)))
return isBignum(arg(d2)) && bigCmp(arg(d1),arg(d2))==0;
#endif
internal("eqNumDiscr");
return FALSE;/*NOTREACHED*/
}
/* --------------------------------------------------------------------------
* Lambda Lifter: replace local function definitions with new global
* functions. Based on Johnsson's algorithm.
* ------------------------------------------------------------------------*/
static Cell local lift(co,tr,e) /* lambda lift term */
Int co;
List tr;
Cell e; {
switch (whatIs(e)) {
case GUARDED : map2Proc(liftPair,co,tr,snd(e));
break;
case FATBAR : liftPair(co,tr,snd(e));
break;
case CASE : map2Proc(liftAlt,co,tr,snd(snd(e)));
break;
case NUMCASE : liftNumcase(co,tr,snd(e));
break;
case COND : liftTriple(co,tr,snd(e));
break;
case AP : liftPair(co,tr,e);
break;
case VAROPCELL :
case VARIDCELL :
case DICTVAR : return liftVar(tr,e);
case LETREC : return liftLetrec(co,tr,e);
#if BIGNUMS
case POSNUM :
case ZERONUM :
case NEGNUM :
#endif
#if NPLUSK
case ADDPAT :
#endif
case TUPLE :
case NAME :
case SELECT :
case DICTCELL :
case INTCELL :
case FLOATCELL :
case STRCELL :
case OFFSET :
case CHARCELL : break;
default : internal("lift");
break;
}
return e;
}
static Void local liftPair(co,tr,pr) /* lift pair of terms */
Int co;
List tr;
Pair pr; {
fst(pr) = lift(co,tr,fst(pr));
snd(pr) = lift(co,tr,snd(pr));
}
static Void local liftTriple(co,tr,e) /* lift triple of terms */
Int co;
List tr;
Triple e; {
fst3(e) = lift(co,tr,fst3(e));
snd3(e) = lift(co,tr,snd3(e));
thd3(e) = lift(co,tr,thd3(e));
}
static Void local liftAlt(co,tr,pr) /* lift (discr,case) pair */
Int co;
List tr;
Cell pr; { /* pr :: (discr,case) */
snd(pr) = lift(co+discrArity(fst(pr)), tr, snd(pr));
}
static Void local liftNumcase(co,tr,nc)/* lift (offset,discr,case) */
Int co;
List tr;
Triple nc; {
Int da = discrArity(snd3(nc));
snd3(nc) = lift(co,tr,snd3(nc));
thd3(nc) = lift(co+da,tr,thd3(nc));
}
static Cell local liftVar(tr,e) /* lift variable */
List tr;
Cell e; {
Text t = textOf(e);
while (nonNull(tr) && textOf(fst(hd(tr)))!=t)
tr = tl(tr);
if (isNull(tr))
internal("liftVar");
return snd(hd(tr));
}
static Cell local liftLetrec(co,tr,e) /* lift letrec term */
Int co;
List tr;
Cell e; {
List vs = fst(fst(snd(e)));
List fs = snd(fst(snd(e)));
List fds;
co += length(vs);
solve(fs);
for (fds=fs; nonNull(fds); fds=tl(fds)) {
Triple fundef = hd(fds);
List fvs = fst3(thd3(fundef));
Cell n = newName(textOf(fst3(fundef)));
Cell e0;
for (e0=n; nonNull(fvs); fvs=tl(fvs))
e0 = ap(e0,hd(fvs));
tr = cons(pair(fst3(fundef),e0),tr);
fst3(fundef) = n;
}
map2Proc(liftFundef,co,tr,fs);
if (isNull(vs))
return lift(co,tr,snd(snd(e)));
map2Over(lift,co,tr,vs);
fst(snd(e)) = vs;
snd(snd(e)) = lift(co,tr,snd(snd(e)));
return e;
}
static Void local liftFundef(co,tr,fd) /* lift function definition */
Int co;
List tr;
Triple fd; {
Int arity = intOf(snd3(fd));
newGlobalFunction(fst3(fd), /* name */
arity, /* arity */
fst3(thd3(fd)), /* free variables */
co+arity, /* current offset */
lift(co+arity,tr,thd3(thd3(fd)))); /* lifted case */
}
/* Each element in a list of fundefs has the form: (v,a,(fvs,ffs,rhs))
* where fvs is a list of free variables which must be added as extra
* parameters to the lifted version of function v,
* ffs is a list of fundefs defined either in the group of definitions
* including v, or in some outer LETREC binding.
*
* In order to determine the correct value for fvs, we must include:
* - all variables explicitly appearing in the body rhs (this much is
* achieved in pmcVar).
* - all variables required for lifting those functions appearing in ffs.
* - If f is a fundef in an enclosing group of definitions then the
* correct list of variables to include with each occurrence of f will
* have already been calculated and stored in the fundef f. We simply
* take the union of this list with fvs.
* - If f is a fundef in the same group of bindings as v, then we iterate
* to find the required solution.
*/
#ifdef DEBUG_CODE
static Void dumpFundefs(fs)
List fs; {
printf("Dumping Fundefs:\n");
for (; nonNull(fs); fs=tl(fs)) {
Cell t = hd(fs);
List fvs = fst3(thd3(t));
List ffs = snd3(thd3(t));
printf("Var \"%s\", arity %d:\n",textToStr(textOf(fst3(t))),
intOf(snd3(t)));
printf("Free variables: ");
printExp(stdout,fvs);
putchar('\n');
printf("Local functions: ");
for (; nonNull(ffs); ffs=tl(ffs)) {
printExp(stdout,fst3(hd(ffs)));
printf(" ");
}
putchar('\n');
}
printf("----------------\n");
}
#endif
static Void local solve(fs) /* Solve eqns for lambda-lifting */
List fs; { /* of local function definitions */
Bool hasChanged;
List fs0, fs1;
/* initial pass distinguishes between those functions defined in fs and
* those defined in enclosing LETREC clauses ...
*/
for (fs0=fs; nonNull(fs0); fs0=tl(fs0)) {
List fvs = fst3(thd3(hd(fs0)));
List ffs = NIL;
for (fs1=snd3(thd3(hd(fs0))); nonNull(fs1); fs1=tl(fs1)) {
if (cellIsMember(hd(fs1),fs)) /* function in same LETREC*/
ffs = cons(hd(fs1),ffs);
else { /* enclosing letrec */
List fvs1 = fst3(thd3(hd(fs1)));
for (; nonNull(fvs1); fvs1=tl(fvs1))
if (!cellIsMember(hd(fvs1),fvs))
fvs = cons(hd(fvs1),fvs);
}
}
fst3(thd3(hd(fs0))) = fvs;
snd3(thd3(hd(fs0))) = ffs;
}
/* now that the ffs component of each fundef in fs has been restricted
* to a list of fundefs in fs, we iterate to add any extra free variables
* that are needed (in effect, calculating the reflexive transitive
* closure of the local call graph of fs).
*/
do {
hasChanged = FALSE;
for (fs0=fs; nonNull(fs0); fs0=tl(fs0)) {
List fvs0 = fst3(thd3(hd(fs0)));
for (fs1=snd3(thd3(hd(fs0))); nonNull(fs1); fs1=tl(fs1))
if (hd(fs1)!=hd(fs0)) {
List fvs1 = fst3(thd3(hd(fs1)));
for (; nonNull(fvs1); fvs1=tl(fvs1))
if (!cellIsMember(hd(fvs1),fvs0)) {
hasChanged = TRUE;
fvs0 = cons(hd(fvs1),fvs0);
}
}
if (hasChanged) fst3(thd3(hd(fs0))) = fvs0;
}
} while (hasChanged);
}
/* --------------------------------------------------------------------------
* Pre-compiler: Uses output from lambda lifter to produce terms suitable
* for input to code generator.
* ------------------------------------------------------------------------*/
static List extraVars; /* List of additional vars to add to function */
static Int numExtraVars; /* Length of extraVars */
static Int localOffset; /* offset value used in original definition */
static Int localArity; /* arity of function being compiled w/o extras */
/* --------------------------------------------------------------------------
* Arrangement of arguments on stack prior to call of
* n x_1 ... x_e y_1 ... y_a
* where
* e = numExtraVars, x_1,...,x_e are the extra params to n
* a = localArity of n, y_1,...,y_a are the original params
*
* offset 1 : y_a } STACKPART1
* .. }
* offset a : y_1 }
*
* offset 1+a : x_e } STACKPART2
* .. }
* offset e+a : x_1 }
*
* offset e+a+1 : used for temporary results ... STACKPART3
* ..
* ..
*
* In the original defn for n, the offsets in STACKPART1 and STACKPART3
* are contiguous. To add the extra parameters we need to insert the
* offsets in STACKPART2, adjusting offset values as necessary.
* ------------------------------------------------------------------------*/
static Cell local preComp(e) /* Adjust output from compiler to */
Cell e; { /* include extra parameters */
switch (whatIs(e)) {
case GUARDED : mapOver(preCompPair,snd(e));
break;
case LETREC : mapOver(preComp,fst(snd(e)));
snd(snd(e)) = preComp(snd(snd(e)));
break;
case COND : return ap(COND,preCompTriple(snd(e)));
case FATBAR : return ap(FATBAR,preCompPair(snd(e)));
case AP : return preCompPair(e);
case CASE : fst(snd(e)) = preComp(fst(snd(e)));
mapProc(preCompCase,snd(snd(e)));
break;
case NUMCASE : return ap(NUMCASE,preCompTriple(snd(e)));
case OFFSET : return preCompOffset(offsetOf(e));
#if BIGNUMS
case POSNUM :
case ZERONUM :
case NEGNUM :
#endif
#if NPLUSK
case ADDPAT :
#endif
case TUPLE :
case NAME :
case SELECT :
case DICTCELL :
case INTCELL :
case FLOATCELL :
case STRCELL :
case CHARCELL : break;
default : internal("preComp");
}
return e;
}
static Cell local preCompPair(e) /* Apply preComp to pair of Exprs */
Pair e; {
return pair(preComp(fst(e)),
preComp(snd(e)));
}
static Cell local preCompTriple(e) /* Apply preComp to triple of Exprs */
Triple e; {
return triple(preComp(fst3(e)),
preComp(snd3(e)),
preComp(thd3(e)));
}
static Void local preCompCase(e) /* Apply preComp to (Discr,Expr) */
Pair e; {
snd(e) = preComp(snd(e));
}
static Cell local preCompOffset(n) /* Determine correct offset value */
Int n; { /* for local variable/function arg. */
if (n>localOffset-localArity)
if (n>localOffset) /* STACKPART3 */
return mkOffset(n-localOffset+localArity+numExtraVars);
else /* STACKPART1 */
return mkOffset(n-localOffset+localArity);
else { /* STACKPART2 */
List fvs = extraVars;
Int i = localArity+numExtraVars;
for (; nonNull(fvs) && offsetOf(hd(fvs))!=n; --i)
fvs=tl(fvs);
return mkOffset(i);
}
}
/* --------------------------------------------------------------------------
* Main entry points to compiler:
* ------------------------------------------------------------------------*/
Void compileExp() { /* compile input expression */
compiler(RESET);
inputExpr = lift(0,NIL,pmcTerm(0,NIL,translate(inputExpr)));
extraVars = NIL;
numExtraVars = 0;
localOffset = 0;
localArity = 0;
inputCode = codeGen(NIL,0,preComp(inputExpr));
// inputExpr = NIL;
}
Void compileDefns() { /* compile script definitions */
Target t = length(valDefns) + length(overDefns);
Target i = 0;
setGoal("Compiling",t);
#ifdef DEBUG_CODE
dumpFundefs(valDefns);
#endif
for (; nonNull(valDefns); valDefns=tl(valDefns)) {
hd(valDefns) = transBinds(hd(valDefns));
mapProc(compileGlobalFunction,hd(valDefns));
soFar(i++);
}
for (; nonNull(overDefns); overDefns=tl(overDefns)) {
compileMemberFunction(hd(overDefns));
soFar(i++);
}
done();
}
static Void local compileGlobalFunction(bind)
Pair bind; {
Name n = findName(textOf(fst(bind)));
List defs = snd(bind);
Int arity = length(fst(hd(defs)));
if (isNull(n))
internal("compileGlobalFunction");
compiler(RESET);
defs = altsMatch(1,arity,NIL,defs);
newGlobalFunction(n,arity,NIL,arity,lift(arity,NIL,match(arity,defs)));
}
static Void local compileMemberFunction(n)
Name n; {
List defs = name(n).defn;
Int arity = length(fst(hd(defs)));
compiler(RESET);
mapProc(transAlt,defs);
defs = altsMatch(1,arity,NIL,defs);
newGlobalFunction(n,arity,NIL,arity,lift(arity,NIL,match(arity,defs)));
}
static Void local newGlobalFunction(n,arity,fvs,co,e)
Name n;
Int arity;
List fvs;
Int co;
Cell e; {
#ifdef DEBUG_SHOWSC
extern Void printSc Args((FILE*, Text, Int, Cell));
#endif
extraVars = fvs;
numExtraVars = length(extraVars);
localOffset = co;
localArity = arity;
name(n).arity = arity+numExtraVars;
e = preComp(e);
#ifdef DEBUG_SHOWSC
printSc(stdout,name(n).text,name(n).arity,e);
#endif
name(n).code = codeGen(n,name(n).arity,e);
}
/* --------------------------------------------------------------------------
* Compiler control:
* ------------------------------------------------------------------------*/
Void compiler(what)
Int what; {
switch (what) {
case INSTALL :
case RESET : freeVars = NIL;
freeFuns = NIL;
freeBegin = mkOffset(0);
extraVars = NIL;
numExtraVars = 0;
localOffset = 0;
localArity = 0;
#if OBJ
stateExp = NIL;
stateOpen = FALSE;
usesState = FALSE;
#endif
break;
case MARK : mark(freeVars);
mark(freeFuns);
mark(extraVars);
#if OBJ
mark(stateExp);
#endif
break;
}
}
/*-------------------------------------------------------------------------*/
syntax highlighted by Code2HTML, v. 0.9.1