![[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.