X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fpmc.c;fp=ghc%2Finterpreter%2Fpmc.c;h=0000000000000000000000000000000000000000;hb=1e4cbfcf578f32d9ea1b407d5c2ed9296638b13f;hp=b6a2bd4921dffe728a6e7758afed75b282927f4e;hpb=aed83b985ee18906415ed90db084c5f3ec550b2a;p=ghc-hetmet.git diff --git a/ghc/interpreter/pmc.c b/ghc/interpreter/pmc.c deleted file mode 100644 index b6a2bd4..0000000 --- a/ghc/interpreter/pmc.c +++ /dev/null @@ -1,585 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -/* -------------------------------------------------------------------------- - * Pattern matching Compiler - * - * Copyright (c) The University of Nottingham and Yale University, 1994-1997. - * All rights reserved. See NOTICE for details and conditions of use etc... - * Hugs version 1.4, December 1997 - * - * $RCSfile: pmc.c,v $ - * $Revision: 1.2 $ - * $Date: 1998/12/02 13:22:29 $ - * ------------------------------------------------------------------------*/ - -#include "prelude.h" -#include "storage.h" -#include "connect.h" -#include "errors.h" -#include "link.h" - -#include "desugar.h" -#include "pat.h" -#include "pmc.h" - -/* -------------------------------------------------------------------------- - * 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). - * ------------------------------------------------------------------------*/ - -/* -------------------------------------------------------------------------- - * Local function prototypes: - * ------------------------------------------------------------------------*/ - -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 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)); -#if TREX -static Bool local isExtDiscr Args((Cell)); -static Bool local eqExtDiscr Args((Cell,Cell)); -#endif - -/* -------------------------------------------------------------------------- - * - * ------------------------------------------------------------------------*/ - -Cell 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 NPLUSK - case ADDPAT : -#endif -#if TREX - case EXT : -#endif - case TUPLE : - case NAME : - case CHARCELL : - case INTCELL : - case BIGCELL : - case FLOATCELL: - case STRCELL : break; - - default : 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 ... */ - return snd(x); - } - else { /* local function ... */ - return fst3(snd(x)); - } - } - - n = findName(t); - assert(nonNull(n)); - 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 */ -} - -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]) */ - Int arity = intOf(snd3(fd)); - Cell temp = altsMatch(co+1,arity,sc,thd3(fd)); - Cell xs; - - temp = match(co+arity,temp); - thd3(fd) = triple(NIL,NIL,temp); /* used to be freevar info */ - -} - -/* --------------------------------------------------------------------------- - * 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. - * - * 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)) - -List 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); -} - -Cell 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))); - } -#if TREX - else if (isExtDiscr(d)) { /* Record 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)))) - && isExtDiscr(d=maDiscr(hd(mas))) - && eqExtDiscr(d,d1)) { - List temp = tl(mas); - tl(mas) = smas; - smas = mas; - mas = temp; - } - smas = rev(smas); - map2Proc(advance,co,da,smas); - srhs = ap(EXTCASE,triple(mkOffset(o),d1,match(co+da,smas))); - } -#endif - 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)); - if (whatIs(p)==CONFLDS) { /* Special case for record syntax */ - Name c = fst(snd(p)); - List fs = snd(snd(p)); - List qs = NIL; - List vs = NIL; - for (; nonNull(fs); fs=tl(fs)) { - vs = cons(mkOffset(co+a+1-sfunPos(fst(hd(fs)),c)),vs); - qs = cons(snd(hd(fs)),qs); - } - ps = revOnto(qs,ps); - us = revOnto(vs,us); - } - else /* Normally just spool off patterns*/ - 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 = ap2(nameCons,mkChar(*s),p); - } else { - p = ap2(nameCons,mkChar('\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 : -#if !OVERLOADED_CONSTANTS - case INTCELL : - case BIGCELL : - case FLOATCELL : -#endif - case NAME : - case CONFLDS : - 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)) { - case CONFLDS : return fst(snd(p)); -#if NPLUSK - case ADDPAT : arg(fun(p)) = translate(arg(fun(p))); - return fun(p); -#endif -#if TREX - case EXT : h = fun(fun(p)); - arg(h) = translate(arg(h)); - return h; -#endif -#if OVERLOADED_CONSTANTS - case NAME : if (h==nameFromInt || h==nameFromInteger - || h==nameFromDouble) { - if (argCount==2) - arg(fun(p)) = translate(arg(fun(p))); - return p; - } -#endif - } - return h; -} - -static Bool local isNumDiscr(d) /* TRUE => numeric discriminator */ -Cell d; { - switch (whatIs(d)) { - case NAME : - case TUPLE : - case CHARCELL : return FALSE; -#if OVERLOADED_CONSTANTS -#if TREX - case AP : return !isExt(fun(d)); -#else - case AP : return TRUE; /* must be a literal or (n+k) */ -#endif -#else - case INTCELL : - case BIGCELL : - case FLOATCELL: - return TRUE; -#endif - } - 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 !OVERLOADED_CONSTANTS - case INTCELL : - case BIGCELL : - case FLOATCELL : return 0; -#endif /* !OVERLOADED_CONSTANTS */ - -#if TREX - case AP : switch (whatIs(fun(d))) { -#if NPLUSK - case ADDPAT : return 1; -#endif - case EXT : return 2; - default : return 0; - } -#else -#if NPLUSK - case AP : return (whatIs(fun(d))==ADDPAT) ? 1 : 0; -#else - case AP : return 0; /* must be an Int or Float lit */ -#endif -#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 && bignumEq(snd(fun(d1)),snd(fun(d2))); -#endif -#if OVERLOADED_CONSTANTS - d1 = arg(d1); - d2 = arg(d2); -#endif - if (isInt(d1)) - return isInt(d2) && intEq(d1,d2); - if (isFloat(d1)) - return isFloat(d2) && floatEq(d1,d2); - if (isBignum(d1)) - return isBignum(d2) && bignumEq(d1,d2); - internal("eqNumDiscr"); - return FALSE;/*NOTREACHED*/ -} - -#if TREX -static Bool local isExtDiscr(d) /* Test of extension discriminator */ -Cell d; { - return isAp(d) && isExt(fun(d)); -} - -static Bool local eqExtDiscr(d1,d2) /* Determine whether two extension */ -Cell d1, d2; { /* discriminators have same label */ - return fun(d1)==fun(d2); -} -#endif - -/*-------------------------------------------------------------------------*/