![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to mcopt.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / translate|
Return to mcopt.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / translate |
1.1 ! root 1: (* Copyright 1989 by AT&T Bell Laboratories *) ! 2: signature MCOPT = ! 3: sig ! 4: structure Absyn : BAREABSYN ! 5: structure Access : ACCESS ! 6: type rhs ! 7: val opt : (Absyn.pat list * rhs) list * Access.lvar list -> ! 8: (Absyn.pat list * rhs) list * Access.lvar list ! 9: end ! 10: ! 11: structure MCopt : MCOPT = struct ! 12: ! 13: structure Absyn : BAREABSYN = Absyn ! 14: structure Lambda : LAMBDA = Lambda ! 15: structure Access : ACCESS = Access ! 16: open Basics Absyn Lambda ! 17: open PrintUtil PrintBasics PrintAbsyn MCprint ErrorMsg ! 18: ! 19: type rhs = (Access.lvar * Access.lvar) list * int (* bindings and tag *) ! 20: ! 21: fun cons2 (hd::hds,tl::tls) = (hd::tl)::cons2(hds,tls) ! 22: | cons2 (hd::hds,[]) = [hd]::cons2(hds,[]) ! 23: | cons2 ([],[]) = [] ! 24: | cons2 _ = impossible "cons2 in mcopt" ! 25: ! 26: infixr cons2 ! 27: ! 28: (* take a list of record patterns and return the list ! 29: of the tail fields of each record pattern *) ! 30: fun tl2 ([_]::_) = [] ! 31: | tl2 ((_::tl)::pats) = tl::(tl2 pats) ! 32: | tl2 [] = [] ! 33: | tl2 _ = impossible "tl2 in mcopt" ! 34: ! 35: (* take a list of record patterns and return the list ! 36: of the first field of each record pattern *) ! 37: fun hd2 ((hd::_)::pats) = hd::(hd2 pats) ! 38: | hd2 [] = [] ! 39: | hd2 _ = impossible "hd2 in mcopt" ! 40: ! 41: fun combine(relf::relfs,irrelf::irrelfs) = (relf@irrelf)::(combine(relfs,irrelfs)) ! 42: | combine([],[]) = [] ! 43: | combine([],irrel) = irrel ! 44: | combine(rel,[]) = rel ! 45: fun addtail (fields::pats,rhs::tl) = (fields,rhs)::addtail(pats,tl) ! 46: | addtail ([],[]) = [] ! 47: | addtail _ = impossible "addtail in mcopt" ! 48: fun strip ((fields,rhs)::pats) = ! 49: let val (fl,tl) = strip pats in (fields::fl,rhs::tl) end ! 50: | strip [] = ([],[]) ! 51: ! 52: fun branch_factor fs = ! 53: let fun existsPat f = ! 54: let val rec ePat = ! 55: fn [] => false ! 56: | VARpat _::more => ePat more ! 57: | WILDpat::more => ePat more ! 58: | LAYEREDpat (_,p)::more => ePat (p::more) ! 59: | CONSTRAINTpat (p,_)::more => ePat (p::more) ! 60: | p::more => (f p orelse ePat more ! 61: handle Match => impossible "ePat in mcopt") ! 62: in ePat ! 63: end ! 64: fun within(p,plist) = ! 65: case p ! 66: of APPpat(DATACON{name=r1,...},_) => ! 67: existsPat (fn APPpat(DATACON{name=r2,...},_) => Symbol.eq(r1,r2) ! 68: | CONpat _ => false) plist ! 69: | CONpat(DATACON{name=r1,...}) => ! 70: existsPat (fn CONpat(DATACON{name=r2,...}) => Symbol.eq(r1,r2) ! 71: | APPpat _ => false) plist ! 72: | INTpat i => existsPat (fn INTpat j => i=j) plist ! 73: | REALpat r => existsPat (fn REALpat s => r=s) plist ! 74: | STRINGpat s => existsPat (fn STRINGpat t => s=t) plist ! 75: | VARpat _ => true ! 76: | WILDpat => true ! 77: | LAYEREDpat (_,p) => within (p,plist) ! 78: | CONSTRAINTpat (p,_) => within (p,plist) ! 79: | _ => impossible "within in mcopt" ! 80: in length (fold (fn(a::_,b) => if within(a,b) then b else a::b) fs []) ! 81: end ! 82: ! 83: fun arity ((hd::_)::_) = ! 84: let val rec ar = ! 85: fn INTpat _ => 1 ! 86: | REALpat _ => 1 ! 87: | STRINGpat _ => 1 ! 88: | VARpat _ => 0 ! 89: | WILDpat => 0 ! 90: | RECORDpat{pats=ref pats,...} => length pats ! 91: | APPpat (_,p) => 1 + ar p ! 92: | CONpat _ => 1 ! 93: | LAYEREDpat (_,p) => ar p ! 94: | CONSTRAINTpat (p,_) => ar p ! 95: in ar hd ! 96: end ! 97: | arity _ = impossible "arity in mcopt" ! 98: ! 99: exception Record ! 100: val rec relevant = ! 101: fn VARpat _ => false ! 102: | WILDpat => false (* any var always matches so never relevant *) ! 103: | RECORDpat{pats=ref [],...} => false (* unit isDCB never relevant *) ! 104: | RECORDpat _ => raise Record (* otherwise, immediately expand records *) ! 105: | LAYEREDpat (_,p) => relevant p ! 106: | CONSTRAINTpat (p,_) => relevant p ! 107: (* if only one data constructor, no need to test *) ! 108: | CONpat(DATACON{sign = [_],...}) => false ! 109: | APPpat(DATACON{sign = [_],...},p) => relevant p ! 110: | _ => true (* everything else is relevant *) ! 111: ! 112: fun rel fs = fold (fn (a::_,b) => if relevant a then b else b+1) fs 0 ! 113: ! 114: (* a record should be immediately expanded by mcand so that ! 115: the nested fields can be considered as well; ! 116: don't bother to look at the rest of the fields, ! 117: and leave the record at the end of relf. ! 118: otherwise, just check the relevant. ! 119: *) ! 120: local ! 121: fun r_o([],[],relf,relx,irrelf,irrelx) = (relf,relx,irrelf,irrelx) ! 122: | r_o(arg as (hd::_)::_,x::xs,relf,relx,irrelf,irrelx) = ! 123: ((if relevant hd ! 124: then r_o(tl2 arg,xs,(hd2 arg) cons2 relf,x::relx,irrelf,irrelx) ! 125: else r_o(tl2 arg,xs,relf,relx,(hd2 arg) cons2 irrelf,x::irrelx)) ! 126: handle Record => ! 127: ((hd2 arg) cons2 [],[x],combine(relf,combine(tl2 arg,irrelf)),relx@xs@irrelx)) ! 128: | r_o _ = impossible "r_o in mcopt" ! 129: in fun rel_order(a,x) = r_o(a,x,[],[],[],[]) ! 130: end ! 131: ! 132: local ! 133: fun gen_order f = ! 134: let fun order([],[],_,bestf,bestx,otherfs,otherxs) = ! 135: (bestf,bestx,otherfs,otherxs) ! 136: | order(argp,x::xs,old,bestf,bestx,otherfs,otherxs) = ! 137: let val head = hd2 argp ! 138: val tail = tl2 argp ! 139: val new = f argp ! 140: in if Integer.<(new,old) ! 141: then order(tail,xs,new,head cons2 [],[x], ! 142: combine(bestf,otherfs),bestx@otherxs) ! 143: else if new > old ! 144: then order(tail,xs,old,bestf,bestx,head cons2 otherfs,x::otherxs) ! 145: else order(tail,xs,old,head cons2 bestf,x::bestx,otherfs,otherxs) ! 146: end ! 147: | order _ = impossible "order in mcopt" ! 148: in fn(a,x::xs) => ! 149: let val hd = hd2 a ! 150: val tl = tl2 a ! 151: val bestf = hd cons2 [] ! 152: in order(tl,xs,f bestf,bestf,[x],[],[]) ! 153: end ! 154: end ! 155: in ! 156: val relevance_order = gen_order rel ! 157: val branch_order = gen_order branch_factor ! 158: val arity_order = gen_order arity ! 159: end ! 160: ! 161: (* OPT: rearrange the fields of a tuple into a better order to evaluate. ! 162: use the relevant test. if there are no relevant fields, ! 163: then the first pattern will match - don't bother returning ! 164: the rest. if one of the fields is a record, return it first ! 165: so it is expanded. if the relevant test does not isolate ! 166: one field, use the branch factor test, then the arity test. *) ! 167: ! 168: fun opt (arg as ([],_)) = arg ! 169: | opt (pl as hd::_,xl) = ! 170: let val (pats,tl) = strip pl ! 171: val (relf,relx,irrelf,irrelx) = rel_order(pats,xl) ! 172: in case relf of ! 173: [] => ([hd],xl) ! 174: | [_]::_ => (addtail(combine(relf,irrelf),tl),relx@irrelx) ! 175: | _ => ! 176: let val (rf,rx,irf,irx) = relevance_order(relf,relx) ! 177: val rrest = combine(irf,irrelf) ! 178: val rrestx = irx@irrelx ! 179: in case rf of ! 180: [_]::_ => (addtail(combine(rf,rrest),tl),rx@rrestx) ! 181: | _ => ! 182: let val (branchf,branchx,branchfs,branchxs) = branch_order(rf,rx) ! 183: val brest = combine(branchfs,rrest) ! 184: val brestx = branchxs@rrestx ! 185: in case branchf of ! 186: [_]::_ => (addtail(combine(branchf,brest),tl),branchx@brestx) ! 187: | _ => let val (arityf,arityx,arityfs,arityxs) = ! 188: arity_order(branchf,branchx) ! 189: in (addtail(combine(arityf,combine(arityfs,brest)),tl), ! 190: arityx@arityxs@brestx) ! 191: end ! 192: end ! 193: end ! 194: end ! 195: ! 196: end (* structure MCopt *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.