Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/trans/matchcomp.sml

Parent Directory | Revision Log

---

Revision 113 - (view) (download)

1 :	monnier	16	(* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :			(* matchcomp.sml *)
3 :
4 :			signature MATCH_COMP =
5 :			sig
6 :
7 :	monnier	45	type toTcLt = (Types.ty -> PLambdaType.tyc) * (Types.ty -> PLambdaType.lty)
8 :
9 :	monnier	16	val bindCompile :
10 :			StaticEnv.staticEnv * (Absyn.pat * PLambda.lexp) list
11 :	monnier	45	* (PLambda.lexp -> PLambda.lexp) * LambdaVar.lvar * toTcLt
12 :	monnier	16	* ErrorMsg.complainer -> PLambda.lexp
13 :
14 :			val matchCompile :
15 :			StaticEnv.staticEnv * (Absyn.pat * PLambda.lexp) list
16 :	monnier	45	* (PLambda.lexp -> PLambda.lexp) * LambdaVar.lvar * toTcLt
17 :	monnier	16	* ErrorMsg.complainer -> PLambda.lexp
18 :
19 :			val handCompile :
20 :			StaticEnv.staticEnv * (Absyn.pat * PLambda.lexp) list
21 :	monnier	45	* (PLambda.lexp -> PLambda.lexp) * LambdaVar.lvar * toTcLt
22 :	monnier	16	* ErrorMsg.complainer -> PLambda.lexp
23 :
24 :			end (* signature MATCH_COMP *)
25 :
26 :
27 :			structure MatchComp : MATCH_COMP =
28 :			struct
29 :
30 :			local structure DA = Access
31 :			structure BT = BasicTypes
32 :			structure LT = PLambdaType
33 :			structure TU = TypesUtil
34 :			structure PO = PrimOp
35 :			structure MP = PPLexp
36 :			structure EM = ErrorMsg
37 :			structure TP = Types
38 :			structure LN = LiteralToNum
39 :
40 :			open VarCon Types
41 :			open Absyn PLambda
42 :			open PrettyPrint
43 :			open TemplateExpansion MCCommon
44 :
45 :			in
46 :
47 :			val intersect=SortedList.intersect
48 :			val union = SortedList.merge
49 :			val setDifference = SortedList.difference
50 :			fun isthere(i,set) = SortedList.member set i
51 :
52 :			fun bug s = EM.impossible ("MatchComp: " ^ s)
53 :			val say = Control.Print.say
54 :	monnier	45	type toTcLt = (ty -> LT.tyc) * (ty -> LT.lty)
55 :	monnier	16
56 :			(*
57 :			* MAJOR CLEANUP REQUIRED ! The function mkv is currently directly taken
58 :			* from the LambdaVar module; I think it should be taken from the
59 :			* "compInfo". Similarly, should we replace all mkLvar in the backend
60 :			* with the mkv in "compInfo" ? (ZHONG)
61 :			*)
62 :			val mkv = LambdaVar.mkLvar
63 :
64 :			fun abstest0 _ = bug "abstest0 unimplemented"
65 :			fun abstest1 _ = bug "abstest1 unimplemented"
66 :
67 :			(** translating the typ field in DATACON into lty; constant datacons
68 :			will take ltc_unit as the argument *)
69 :	monnier	45	fun toDconLty toLty ty =
70 :	monnier	16	(case ty
71 :			of TP.POLYty{sign, tyfun=TYFUN{arity, body}} =>
72 :	monnier	45	if BT.isArrowType body then toLty ty
73 :			else toLty (TP.POLYty{sign=sign,
74 :	monnier	16	tyfun=TYFUN{arity=arity,
75 :			body=BT.-->(BT.unitTy, body)}})
76 :	monnier	45	| _ => if BT.isArrowType ty then toLty ty
77 :			else toLty (BT.-->(BT.unitTy, ty)))
78 :	monnier	16
79 :			(**************************************************************************)
80 :
81 :			datatype andor
82 :			= AND of {bindings : (int * var) list,
83 :			subtrees : andor list,
84 :			constraints : (dconinfo * int list * andor option) list}
85 :			| CASE of {bindings : (int * var) list,
86 :			sign : DA.consig,
87 :			cases : (pcon * int list * andor list) list,
88 :			constraints : (dconinfo * int list * andor option) list}
89 :			| LEAF of {bindings : (int * var) list,
90 :			constraints : (dconinfo * int list * andor option) list}
91 :
92 :			datatype decision
93 :			= CASEDEC of path * DA.consig *
94 :			(pcon * int list * decision list) list * int list
95 :			| ABSCONDEC of path * dconinfo * int list * decision list * int list
96 :			| BINDDEC of path * int list
97 :
98 :			fun allConses(hds, tls) =
99 :			List.concat (map (fn hd => (map (fn tl => hd::tl) tls)) hds)
100 :
101 :			fun orExpand (ORpat(pat1,pat2)) =
102 :			(orExpand pat1)@(orExpand pat2)
103 :			| orExpand (pat as RECORDpat{fields,...}) =
104 :			map (mkRECORDpat pat) (foldr allConses [nil] (map (orExpand o #2) fields))
105 :			| orExpand (VECTORpat(pats,t)) =
106 :			map (fn p => VECTORpat(p,t)) (foldr allConses [nil] (map orExpand pats))
107 :			| orExpand (APPpat(k,t,pat)) =
108 :			map (fn pat => APPpat(k,t,pat)) (orExpand pat)
109 :			| orExpand (CONSTRAINTpat(pat,_)) =
110 :			orExpand pat
111 :			| orExpand (LAYEREDpat(CONSTRAINTpat(lpat, _), bpat)) =
112 :			orExpand (LAYEREDpat(lpat, bpat))
113 :			| orExpand (LAYEREDpat(lpat, bpat)) =
114 :			map (fn pat => LAYEREDpat(lpat,pat)) (orExpand bpat)
115 :			| orExpand pat =
116 :			[pat]
117 :
118 :			fun lookupVar (v as VALvar{path=p1,...},
119 :			(VALvar{path=p2,...}, value)::rest) =
120 :			if SymPath.equal(p1,p2) then value else lookupVar(v, rest)
121 :			| lookupVar (VALvar _, []) = bug "unbound 18"
122 :			| lookupVar _ = bug "[MC.lookupVar]"
123 :
124 :			fun pathInstSimpexp varenv (VARsimp v) = lookupVar (v, varenv)
125 :			| pathInstSimpexp varenv (RECORDsimp labsimps) =
126 :			RECORDPATH (map (pathInstSimpexp varenv o #2) labsimps)
127 :
128 :			fun expandBindings (varenv, pathenv, nil) = nil
129 :			| expandBindings (varenv, pathenv, v::rest) =
130 :			(pathInstSimpexp pathenv (fullyExpandBinding varenv (VARsimp v)))
131 :			:: (expandBindings(varenv, pathenv, rest))
132 :
133 :			fun boundVariables (VARpat v) = [v]
134 :			| boundVariables (CONSTRAINTpat(pat,_)) = boundVariables pat
135 :			| boundVariables (LAYEREDpat(pat1, pat2)) =
136 :			(boundVariables(pat1))@(boundVariables(pat2))
137 :			| boundVariables (APPpat(k,t,pat)) = boundVariables pat
138 :			| boundVariables (RECORDpat{fields,...}) =
139 :			List.concat (map (boundVariables o #2) fields)
140 :			| boundVariables (VECTORpat(pats,_)) = List.concat (map boundVariables pats)
141 :			| boundVariables (ORpat (pat1,_)) = boundVariables pat1
142 :			| boundVariables _ = nil
143 :
144 :			fun patternBindings (VARpat v, path) = [(v, path)]
145 :			| patternBindings (CONSTRAINTpat(pat,_), path) = patternBindings(pat, path)
146 :			| patternBindings (LAYEREDpat(pat1, pat2), path) =
147 :			(patternBindings(pat1, path))@(patternBindings(pat2, path))
148 :			| patternBindings (APPpat(k,t,pat), path) =
149 :			patternBindings(pat, DELTAPATH(DATApcon(k, t), path))
150 :			| patternBindings (RECORDpat{fields,...}, path) =
151 :			let fun doGen(n, nil) = nil
152 :			| doGen(n, (lab,pat)::rest) =
153 :			(patternBindings(pat,PIPATH(n,path))) @ (doGen(n+1,rest))
154 :			in doGen(0, fields)
155 :			end
156 :			| patternBindings (VECTORpat(pats,t), path) =
157 :			let fun doGen(n, nil) = nil
158 :			| doGen(n, pat::rest) =
159 :			(patternBindings(pat,VPIPATH(n,t,path))) @ (doGen(n+1,rest))
160 :			in doGen(0, pats)
161 :			end
162 :			| patternBindings (ORpat _, _) = bug "Unexpected or pattern"
163 :			| patternBindings _ = nil
164 :
165 :			fun patPaths (pat, constrs) =
166 :			let val patEnv = patternBindings(pat, ROOTPATH)
167 :			fun constrPaths (nil, env, acc) =
168 :			((ROOTPATH, pat)::(rev acc), env)
169 :			| constrPaths ((simpexp,cpat)::rest, env, acc) =
170 :			let val guardPath = pathInstSimpexp env simpexp
171 :			val newEnv = patternBindings(cpat, guardPath)
172 :			in constrPaths(rest, env@newEnv, (guardPath, cpat)::acc)
173 :			end
174 :			in constrPaths(constrs, patEnv, nil)
175 :			end
176 :
177 :	monnier	45	fun vartolvar (VALvar{access=DA.LVAR v, typ,...}, toLty) = (v, toLty (!typ))
178 :			| vartolvar _ = bug "bug variable in mc.sml"
179 :
180 :			fun preProcessPat toLty (pat, rhs) =
181 :	monnier	16	let val bindings = boundVariables pat
182 :			val fname = mkv()
183 :	monnier	45
184 :			fun genRHSFun ([], rhs) = FN(mkv(), LT.ltc_unit, rhs)
185 :			| genRHSFun ([v], rhs) =
186 :			let val (argvar,argt) = vartolvar(v, toLty)
187 :			in FN(argvar,argt,rhs)
188 :			end
189 :			| genRHSFun (vl, rhs) =
190 :			let val argvar = mkv()
191 :			fun foo (nil, n) = (rhs,nil)
192 :			| foo (v::vl, n) =
193 :			let val (lv,lt) = vartolvar(v, toLty)
194 :			val (le,tt) = foo(vl,n+1)
195 :			in (LET(lv, SELECT(n,VAR argvar), le), lt :: tt)
196 :			end
197 :			val (body,tt) = foo(vl,0)
198 :			in FN(argvar, LT.ltc_tuple tt, body)
199 :			end
200 :
201 :			val rhsFun = genRHSFun (bindings, rhs)
202 :	monnier	16	val pats = orExpand pat
203 :			fun expand nil = nil
204 :			| expand (pat::rest) =
205 :			let val (newpat, constrs, varenv) = templateExpandPattern pat
206 :			val (newlist, pathenv) = patPaths (newpat, constrs)
207 :			val bindingPaths = expandBindings(varenv,pathenv,bindings)
208 :			in (newlist, bindingPaths, fname)::(expand rest)
209 :			end handle CANT_MATCH =>
210 :			([(ROOTPATH, NOpat)], nil, fname)::(expand rest)
211 :			in (expand pats, (fname, rhsFun))
212 :			end
213 :
214 :			fun makeAndor (matchRep,err) =
215 :			let fun addBinding (v, rule, AND{bindings, subtrees, constraints}) =
216 :			AND{bindings=(rule,v)::bindings, subtrees=subtrees,
217 :			constraints=constraints}
218 :			| addBinding (v, rule, CASE{bindings, sign, cases, constraints}) =
219 :			CASE{bindings=(rule,v)::bindings, cases=cases, sign = sign,
220 :			constraints=constraints}
221 :			| addBinding (v, rule, LEAF{bindings, constraints}) =
222 :			LEAF{bindings=(rule,v)::bindings, constraints=constraints}
223 :
224 :			fun wordCon(s, t, msg) =
225 :			let fun conv(wrapFn,convFn) =
226 :			wrapFn(convFn s handle Overflow =>
227 :			(err EM.COMPLAIN
228 :			("out-of-range word literal in pattern: 0w"
229 :			^IntInf.toString s)
230 :			EM.nullErrorBody;
231 :			convFn(IntInf.fromInt 0)))
232 :			in if TU.equalType(t,BT.wordTy) then
233 :			conv(WORDpcon,LN.word) (* WORDpcon(LN.word s) *)
234 :			else if TU.equalType(t,BT.word8Ty) then
235 :			conv(WORDpcon,LN.word8) (* WORDpcon(LN.word8 s) *)
236 :			else if TU.equalType(t,BT.word32Ty) then
237 :			conv(WORD32pcon,LN.word32) (* WORD32pcon(LN.word32 s) *)
238 :			else bug msg
239 :			end
240 :
241 :			fun numCon(s, t, msg) =
242 :			if TU.equalType(t,BT.intTy) then
243 :			INTpcon(LN.int s)
244 :			else if TU.equalType(t,BT.int32Ty) then
245 :			INT32pcon (LN.int32 s)
246 :			else wordCon(s, t, msg)
247 :
248 :			fun addAConstraint(k, NONE, rule, nil) = [(k, [rule], NONE)]
249 :			| addAConstraint(k, SOME pat, rule, nil) =
250 :			[(k, [rule], SOME(genAndor(pat, rule)))]
251 :			| addAConstraint(k, patopt as SOME pat, rule,
252 :			(constr as (k', rules, SOME subtree))::rest) =
253 :			if conEq'(k, k') then
254 :			(k, rule::rules, SOME(mergeAndor(pat, subtree, rule)))::rest
255 :			else
256 :			constr::(addAConstraint(k, patopt, rule, rest))
257 :			| addAConstraint(k, NONE, rule, (constr as (k', rules, NONE))::rest) =
258 :			if conEq'(k, k') then (k, rule::rules, NONE)::rest
259 :			else constr::(addAConstraint(k, NONE, rule, rest))
260 :			| addAConstraint(k, patopt, rule, (constr as (k', rules, _))::rest) =
261 :			if conEq'(k, k') then bug "arity conflict"
262 :			else constr::(addAConstraint(k, patopt, rule, rest))
263 :
264 :			and addConstraint(k, patopt, rule, AND{bindings, subtrees, constraints}) =
265 :			AND{bindings=bindings, subtrees=subtrees,
266 :			constraints=addAConstraint(k, patopt, rule, constraints)}
267 :			| addConstraint(k, patopt, rule, CASE{bindings, sign, cases,
268 :			constraints}) =
269 :			CASE{bindings=bindings, cases=cases, sign = sign,
270 :			constraints=addAConstraint(k, patopt, rule, constraints)}
271 :			| addConstraint(k, patopt, rule, LEAF{bindings, constraints}) =
272 :			LEAF{bindings=bindings,
273 :			constraints=addAConstraint(k, patopt, rule, constraints)}
274 :
275 :			and genAndor (VARpat v, rule) =
276 :			LEAF {bindings = [(rule, v)], constraints = nil}
277 :			| genAndor (WILDpat, rule) =
278 :			LEAF {bindings = nil, constraints = nil}
279 :			| genAndor (CONSTRAINTpat(pat, _), rule) = genAndor(pat, rule)
280 :			| genAndor (LAYEREDpat(CONSTRAINTpat(lpat,_), bpat), rule) =
281 :			genAndor (LAYEREDpat(lpat, bpat), rule)
282 :			| genAndor (LAYEREDpat(VARpat v, bpat), rule) =
283 :			addBinding (v, rule, genAndor (bpat, rule))
284 :			| genAndor (LAYEREDpat(CONpat(k,t), bpat), rule) =
285 :			addConstraint ((k,t), NONE, rule, genAndor(bpat, rule))
286 :			| genAndor (LAYEREDpat(APPpat(k,t,lpat), bpat), rule) =
287 :			addConstraint ((k,t), SOME lpat, rule, genAndor(bpat, rule))
288 :			| genAndor (INTpat (s,t), rule) =
289 :			let val con = numCon(s, t, "genAndor INTpat")
290 :			in CASE{bindings = nil, constraints = nil, sign = DA.CNIL,
291 :			cases = [(con, [rule], nil)]}
292 :			end
293 :			| genAndor (WORDpat(s,t), rule) =
294 :			let val con = wordCon(s, t, "genAndor WORDpat")
295 :			in CASE{bindings = nil, constraints = nil, sign = DA.CNIL,
296 :			cases = [(con, [rule], nil)]}
297 :			end
298 :			| genAndor (REALpat r, rule) =
299 :			CASE {bindings = nil, constraints = nil, sign = DA.CNIL,
300 :			cases = [(REALpcon r, [rule], nil)]}
301 :			| genAndor (STRINGpat s, rule) =
302 :			CASE {bindings = nil, constraints = nil, sign = DA.CNIL,
303 :			cases = [(STRINGpcon s, [rule], nil)]}
304 :
305 :			(*
306 :			* NOTE: the following won't work for cross compiling
307 :			* to multi-byte characters.
308 :			*)
309 :			| genAndor (CHARpat s, rule) =
310 :			CASE {bindings = nil, constraints = nil, sign = DA.CNIL,
311 :			cases = [(INTpcon (Char.ord(String.sub(s, 0))), [rule], nil)]}
312 :			| genAndor (RECORDpat{fields,...}, rule) =
313 :			AND{bindings = nil, constraints = nil,
314 :			subtrees=multiGen(map #2 fields, rule)}
315 :			| genAndor (VECTORpat(pats,t), rule) =
316 :			CASE {bindings = nil, constraints = nil, sign = DA.CNIL,
317 :			cases = [(VLENpcon (length pats, t), [rule],
318 :			multiGen(pats, rule))]}
319 :			| genAndor (CONpat(k,t), rule) =
320 :			if abstract k then
321 :			LEAF {bindings = nil, constraints = [((k, t), [rule], NONE)]}
322 :			else
323 :			CASE {bindings = nil, constraints = nil, sign = signOfCon k,
324 :			cases = [(DATApcon(k, t), [rule], nil)]}
325 :			| genAndor (APPpat(k,t,pat), rule) =
326 :			if abstract k then
327 :			LEAF {bindings = nil,
328 :			constraints = [((k,t), [rule], SOME(genAndor (pat, rule)))]}
329 :			else
330 :			CASE {bindings = nil, constraints = nil, sign = signOfCon k,
331 :			cases = [(DATApcon(k,t), [rule], [genAndor(pat, rule)])]}
332 :			| genAndor _ =
333 :			bug "genandor applied to inapplicable pattern"
334 :
335 :			and multiGen(nil, rule) = nil
336 :			| multiGen(pat::rest, rule) = (genAndor(pat,rule))::multiGen((rest,rule))
337 :
338 :			and mergeAndor (VARpat v, andor, rule) = addBinding (v, rule, andor)
339 :			| mergeAndor (WILDpat, andor, rule) = andor
340 :			| mergeAndor (CONSTRAINTpat(pat, _), andor, rule) =
341 :			mergeAndor(pat, andor, rule)
342 :			| mergeAndor (LAYEREDpat(CONSTRAINTpat(lpat,_), bpat), andor, rule) =
343 :			mergeAndor (LAYEREDpat(lpat, bpat), andor, rule)
344 :			| mergeAndor (LAYEREDpat(VARpat v, bpat), andor, rule) =
345 :			addBinding (v, rule, mergeAndor (bpat, andor, rule))
346 :			| mergeAndor (LAYEREDpat(CONpat(k,t), bpat), andor, rule) =
347 :			addConstraint ((k,t), NONE, rule, mergeAndor(bpat, andor, rule))
348 :			| mergeAndor (LAYEREDpat(APPpat(k,t,lpat), bpat), andor, rule) =
349 :			addConstraint ((k,t), SOME lpat, rule, mergeAndor(bpat, andor, rule))
350 :			| mergeAndor (CONpat(k,t), LEAF{bindings, constraints}, rule) =
351 :			if abstract k then
352 :			LEAF {bindings = nil,
353 :			constraints = addAConstraint((k, t), NONE, rule, constraints)}
354 :			else
355 :			CASE {bindings = nil, constraints = nil, sign = signOfCon k,
356 :			cases = [(DATApcon(k,t), [rule], nil)]}
357 :			| mergeAndor (APPpat(k,t,pat), LEAF{bindings, constraints}, rule) =
358 :			if abstract k then
359 :			LEAF {bindings = bindings,
360 :			constraints = addAConstraint((k,t), SOME pat, rule, constraints)}
361 :			else
362 :			CASE {bindings = bindings, constraints = constraints,
363 :			sign = signOfCon k,
364 :			cases = [(DATApcon(k,t), [rule], [genAndor(pat, rule)])]}
365 :			| mergeAndor (pat, LEAF{bindings, constraints}, rule) =
366 :			(case genAndor(pat, rule)
367 :			of CASE{bindings=nil, constraints=nil, sign, cases} =>
368 :			CASE{bindings=bindings, sign=sign,
369 :			constraints=constraints, cases=cases}
370 :			| AND{bindings=nil, constraints=nil, subtrees} =>
371 :			AND{bindings=bindings, constraints=constraints,
372 :			subtrees=subtrees}
373 :			| _ => bug "genAndor returned bogusly")
374 :			| mergeAndor (INTpat (s,t), CASE{bindings, cases,
375 :			constraints, sign}, rule) =
376 :			let val pcon = numCon(s, t, "mergeAndor INTpat")
377 :			in CASE{bindings = bindings, constraints = constraints, sign = sign,
378 :			cases = addACase(pcon, nil, rule, cases)}
379 :			end
380 :			| mergeAndor (WORDpat(s,t), CASE{bindings, cases,
381 :			constraints, sign}, rule) =
382 :			let val pcon = wordCon(s, t, "mergeAndor WORDpat")
383 :			in CASE{bindings = bindings, constraints = constraints, sign = sign,
384 :			cases = addACase(pcon, nil, rule, cases)}
385 :			end
386 :			| mergeAndor (REALpat r, CASE{bindings, cases, constraints,sign}, rule) =
387 :			CASE {bindings = bindings, constraints = constraints, sign=sign,
388 :			cases = addACase(REALpcon r, nil, rule, cases)}
389 :			| mergeAndor (STRINGpat s, CASE{bindings, cases, constraints,sign}, rule) =
390 :			CASE {bindings = bindings, constraints = constraints, sign=sign,
391 :			cases = addACase(STRINGpcon s, nil, rule, cases)}
392 :
393 :			(*
394 :			* NOTE: the following won't work for cross compiling
395 :			* to multi-byte characters
396 :			*)
397 :			| mergeAndor (CHARpat s, CASE{bindings, cases,
398 :			constraints, sign}, rule) =
399 :			CASE {bindings = bindings, constraints = constraints, sign=sign,
400 :			cases = addACase(INTpcon(Char.ord(String.sub(s, 0))),
401 :			nil, rule, cases)}
402 :
403 :			| mergeAndor (RECORDpat{fields,...},
404 :			AND{bindings, constraints, subtrees}, rule) =
405 :			AND{bindings = bindings, constraints = constraints,
406 :			subtrees=multiMerge(map #2 fields, subtrees, rule)}
407 :			| mergeAndor (VECTORpat(pats,t), CASE{bindings, cases, sign,
408 :			constraints}, rule) =
409 :			CASE {bindings = bindings, constraints = constraints, sign = sign,
410 :			cases = addACase(VLENpcon(length pats, t),pats,rule,cases)}
411 :			| mergeAndor (CONpat(k,t), CASE{bindings,
412 :			cases, constraints, sign}, rule) =
413 :			if abstract k then
414 :			CASE {bindings=bindings, cases=cases, sign=sign,
415 :			constraints=addAConstraint((k,t), NONE, rule, constraints)}
416 :			else
417 :			CASE {bindings=bindings, constraints=constraints, sign=sign,
418 :			cases=addACase(DATApcon(k,t), nil, rule, cases)}
419 :			| mergeAndor (APPpat(k,t,pat), CASE{bindings, cases,
420 :			constraints, sign}, rule) =
421 :			if abstract k then
422 :			CASE {bindings=bindings, cases=cases, sign=sign,
423 :			constraints=addAConstraint((k,t), SOME pat, rule, constraints)}
424 :			else
425 :			CASE {bindings=bindings, constraints=constraints, sign=sign,
426 :			cases=addACase(DATApcon(k,t), [pat], rule, cases)}
427 :			| mergeAndor (CONpat(k,t), AND{bindings, constraints, subtrees}, rule) =
428 :			if abstract k then
429 :			AND {bindings=bindings, subtrees=subtrees,
430 :			constraints=addAConstraint((k,t), NONE, rule, constraints)}
431 :			else bug "concrete constructor can't match record"
432 :			| mergeAndor (APPpat(k,t,pat), AND{bindings,subtrees,constraints}, rule) =
433 :			if abstract k then
434 :			AND {bindings=bindings, subtrees=subtrees,
435 :			constraints=addAConstraint((k,t), SOME pat, rule, constraints)}
436 :			else bug "concrete constructor application can't match record"
437 :			| mergeAndor _ =
438 :			bug "bad pattern merge"
439 :
440 :			and addACase (pcon, pats, rule, nil) =
441 :			[(pcon, [rule], multiGen(pats, rule))]
442 :			| addACase (pcon, pats, rule,
443 :			(aCase as (pcon', rules,subtrees))::rest) =
444 :			if constantEq(pcon, pcon') then
445 :			(pcon, rule::rules, multiMerge(pats, subtrees, rule))::rest
446 :			else
447 :			aCase::(addACase(pcon, pats, rule, rest))
448 :
449 :			and multiMerge (nil, nil, rule) = nil
450 :			| multiMerge (pat::pats, subtree::subtrees, rule) =
451 :			(mergeAndor(pat, subtree, rule))::(multiMerge(pats, subtrees, rule))
452 :			| multiMerge _ = bug "list length mismatch in multiMerge"
453 :
454 :
455 :			fun mergePatWithAndorList(path, pat, nil, n) =
456 :			[(path, genAndor(pat, n))]
457 :			| mergePatWithAndorList(path, pat, (path',andor)::rest, n) =
458 :			if pathEq(path, path') then (path, mergeAndor(pat, andor, n))::rest
459 :			else (path',andor)::(mergePatWithAndorList(path, pat, rest, n))
460 :
461 :			fun genAndorList (nil, n) = bug "no patterns (gen)"
462 :			| genAndorList ([(path, pat)], n) = [(path, genAndor(pat, n))]
463 :			| genAndorList ((path, pat)::rest, n) =
464 :			mergePatWithAndorList(path, pat, genAndorList(rest, n), n)
465 :
466 :			fun mergeAndorList (nil, aol, n) = bug "no patterns (merge)"
467 :			| mergeAndorList ([(path, pat)], aol, n) =
468 :			mergePatWithAndorList(path, pat, aol, n)
469 :			| mergeAndorList ((path, pat)::rest, aol, n) =
470 :			mergePatWithAndorList(path, pat, mergeAndorList(rest, aol, n), n)
471 :
472 :			fun makeAndor' (nil, n) = bug "no rules (makeAndor')"
473 :			| makeAndor' ([(pats, _, _)], n) =
474 :			genAndorList (pats, n)
475 :			| makeAndor' (([(_, NOpat)], env, bindings)::rest, n) =
476 :			makeAndor'(rest, n+1)
477 :			| makeAndor' ((pats, env, bindings)::rest, n) =
478 :			mergeAndorList(pats, makeAndor'(rest, n+1), n)
479 :
480 :			in makeAndor' (matchRep,0) (* handle Foo => raise (Internal 99) *)
481 :			end (* fun makeAndor *)
482 :
483 :			fun addABinding (path, rule, nil) = [BINDDEC(path, [rule])]
484 :			| addABinding (path, rule, (bind as BINDDEC(path', rules))::rest) =
485 :			if pathEq(path, path') then BINDDEC(path, rule::rules)::rest
486 :			else bind::(addABinding(path, rule, rest))
487 :			| addABinding _ = bug "non BINDDEC in binding list"
488 :
489 :			fun flattenBindings (nil, path, active) = nil
490 :			| flattenBindings (((rule, v)::rest), path, active) =
491 :			if isthere(rule, active) then
492 :			addABinding(path, rule, flattenBindings(rest, path,active))
493 :			else
494 :			flattenBindings(rest, path, active)
495 :
496 :			fun flattenConstraints (nil, path, active) = nil
497 :			| flattenConstraints ((di,rules,NONE)::rest, path, active) =
498 :			let val yesActive = intersect(active, rules)
499 :			val noActive = setDifference(active, rules)
500 :			val rest' = flattenConstraints(rest, path, active)
501 :			in (ABSCONDEC(path, di, yesActive, nil, noActive))::rest'
502 :			end
503 :			| flattenConstraints ((di,rules,SOME andor)::rest, path, active) =
504 :			let val yesActive = intersect(active, rules)
505 :			val noActive = setDifference(active, rules)
506 :			val rest' = flattenConstraints(rest, path, active)
507 :			val andor' =
508 :			flattenAndor(andor, DELTAPATH(DATApcon di, path), active)
509 :			in (ABSCONDEC(path, di, yesActive, andor', noActive))::rest'
510 :			end
511 :
512 :			and flattenAndor (AND {bindings, subtrees, constraints}, path, active) =
513 :			let val btests = flattenBindings(bindings, path, active)
514 :			fun dotree (n, nil) =
515 :			flattenConstraints(constraints, path, active)
516 :			| dotree (n, subtree::rest) =
517 :			let val othertests = dotree(n + 1, rest)
518 :			in (flattenAndor(subtree,PIPATH(n,path),active))@othertests
519 :			end
520 :			in btests@(dotree(0, subtrees))
521 :			end
522 :			| flattenAndor (CASE {bindings, cases, constraints,sign}, path, active) =
523 :			let val btests = flattenBindings(bindings, path, active)
524 :			val ctests = flattenConstraints(constraints, path, active)
525 :			in btests@((flattenCases(cases, path, active,sign))::ctests)
526 :			end
527 :			| flattenAndor (LEAF {bindings, constraints}, path, active) =
528 :			let val btests = flattenBindings(bindings, path, active)
529 :			in btests@(flattenConstraints(constraints, path, active))
530 :			end
531 :
532 :			and flattenACase((VLENpcon(n, t), rules, subtrees),path,active,defaults) =
533 :			let val stillActive = intersect(union(rules, defaults), active)
534 :			val ruleActive = intersect(rules, active)
535 :			fun flattenVSubs (n, nil) = nil
536 :			| flattenVSubs (n, subtree::rest) =
537 :			(flattenAndor(subtree, VPIPATH(n,t,path), stillActive))
538 :			@ (flattenVSubs(n + 1, rest))
539 :			in (INTpcon n, ruleActive, flattenVSubs(0, subtrees))
540 :			end
541 :			| flattenACase((k as DATApcon (_,t), rules,[subtree]),path,active,defaults) =
542 :			let val stillActive = intersect(union(rules, defaults), active)
543 :			val ruleActive = intersect(rules, active)
544 :			val newPath = DELTAPATH(k,path)
545 :			in (k,ruleActive,flattenAndor(subtree,newPath,stillActive))
546 :			end
547 :			| flattenACase((constant,rules,nil),path,active,defaults) =
548 :			(constant, intersect(rules, active), nil)
549 :			| flattenACase _ =
550 :			bug "illegal subpattern in a case"
551 :
552 :			and flattenCases(cases, path, active,sign) =
553 :			let fun calcDefaults (nil, active) = active
554 :			| calcDefaults ((_,rules,_)::rest, active) =
555 :			calcDefaults(rest, setDifference(active, rules))
556 :			val defaults = calcDefaults(cases, active)
557 :			fun doit nil = nil
558 :			| doit (aCase::rest) =
559 :			((flattenACase(aCase, path, active, defaults))
560 :			:: (doit(rest)))
561 :			in case cases
562 :			of (VLENpcon (_,t), _, _)::_ =>
563 :			CASEDEC(VLENPATH(path, t), sign, doit cases, defaults)
564 :			| cases => CASEDEC(path, sign, doit cases, defaults)
565 :			end
566 :
567 :			fun bindings (n, l) = case (List.nth(l, n)) of (_,_,x) => x
568 :
569 :			fun pathConstraints (RECORDPATH paths) =
570 :			List.concat (map pathConstraints paths)
571 :			| pathConstraints path = [path]
572 :
573 :			fun flattenAndors(nil, allrules) = nil
574 :			| flattenAndors((path, andor)::rest, allrules) =
575 :			(pathConstraints path, flattenAndor(andor, path, allrules))
576 :			:: (flattenAndors(rest, allrules))
577 :
578 :			fun removePath(path, path1::rest) =
579 :			if pathEq(path, path1) then rest
580 :			else path1::(removePath(path, rest))
581 :			| removePath (path, nil) = nil
582 :
583 :			fun fireConstraint (path, (needPaths, decisions)::rest, ready, delayed) =
584 :			(case removePath(path, needPaths)
585 :			of nil => fireConstraint(path, rest, decisions@ready, delayed)
586 :			| x => fireConstraint(path, rest, ready, (x,decisions)::delayed))
587 :			| fireConstraint (path, nil, ready, delayed) =
588 :			(ready, delayed)
589 :
590 :			fun mkAllRules (nil,_) = nil
591 :			| mkAllRules(([(ROOTPATH, NOpat)],_,_)::b, n) = (mkAllRules(b, n + 1))
592 :			| mkAllRules(_::b, n) = n::(mkAllRules(b, n + 1))
593 :
594 :			exception PickBest
595 :
596 :			fun relevent (CASEDEC(_,_,_,defaults), rulenum) =
597 :			not (isthere(rulenum, defaults))
598 :			| relevent (ABSCONDEC (_,_,_,_,defaults), rulenum) =
599 :			not (isthere(rulenum, defaults))
600 :			| relevent (BINDDEC _, _) =
601 :			bug "BINDDEC not fired"
602 :
603 :			fun metric (CASEDEC(_,_,cases, defaults)) = (length defaults, length cases)
604 :			| metric (ABSCONDEC (_,_,_,_,defaults)) = (length defaults, 2)
605 :			| metric (BINDDEC _) = bug "BINDDEC not fired (metric)"
606 :
607 :			fun metricBetter((a:int,b:int),(c,d)) = a < c orelse (a = c andalso b < d)
608 :
609 :			fun doPickBest(nil, _, _, _, NONE) = raise PickBest
610 :			| doPickBest(nil, _, _, _, SOME n) = n
611 :			| doPickBest((BINDDEC _)::rest, _, n, _, _) = n
612 :			| doPickBest((CASEDEC(_, DA.CSIG(1,0), _, _))::rest, _, n, _, _) = n
613 :			| doPickBest((CASEDEC(_, DA.CSIG(0,1), _, _))::rest, _, n, _, _) = n
614 :			| doPickBest(aCase::rest, active as act1::_, n, NONE, NONE) =
615 :			if relevent (aCase, act1) then
616 :			doPickBest(rest, active, n + 1, SOME(metric aCase), SOME n)
617 :			else
618 :			doPickBest(rest, active, n + 1, NONE, NONE)
619 :			| doPickBest(aCase::rest, active as act1::_, n, SOME m, SOME i) =
620 :			if relevent (aCase, act1) then
621 :			let val myMetric = metric aCase
622 :			in
623 :			if metricBetter(myMetric, m) then
624 :			doPickBest(rest, active, n + 1, SOME(myMetric), SOME n)
625 :			else
626 :			doPickBest(rest, active, n + 1, SOME m, SOME i)
627 :			end
628 :			else
629 :			doPickBest(rest, active, n + 1, SOME m, SOME i)
630 :			| doPickBest _ = bug "bug situation in doPickBest"
631 :
632 :			fun pickBest (l, active) = doPickBest(l, active, 0, NONE, NONE)
633 :
634 :			fun extractNth(0, a::b) = (a, b)
635 :			| extractNth(n, a::b) =
636 :			let val (c,d) = extractNth(n - 1, b) in (c, a::d) end
637 :			| extractNth _ = bug "extractNth called with too big n"
638 :
639 :			fun filter (f, nil) = nil |
640 :			filter (f, a::b) = if f a then a::(filter(f,b)) else filter(f,b)
641 :
642 :			fun genDecisionTree((decisions, delayed), active as active1::_) =
643 :			((case extractNth(pickBest(decisions, active), decisions)
644 :			of (BINDDEC(path, _), rest) =>
645 :			genDecisionTree(fireConstraint(path,delayed,rest,nil),active)
646 :			(*
647 :			| (CASEDEC(path, DA.CSIG(1,0),
648 :			[(_,_,guarded)], defaults), rest) =>
649 :			genDecisionTree((rest@guarded, delayed), active)
650 :			| (CASEDEC(path, DA.CSIG(0,1),
651 :			[(_,_,guarded)], defaults), rest) =>
652 :			genDecisionTree((rest@guarded, delayed), active)
653 :			*)
654 :			| (CASEDEC(path, sign, cases, defaults), rest) =>
655 :			let fun isActive(_,rules,_) = intersect(rules, active) <> []
656 :			val activeCases = filter(isActive, cases)
657 :			val caseTrees =
658 :			gencases(activeCases, rest, delayed, defaults, active)
659 :			val defActive = intersect(active, defaults)
660 :			fun len (DA.CSIG(i,j)) = i+j
661 :			| len (DA.CNIL) = 0
662 :			val defTree =
663 :			if length activeCases = len sign then NONE
664 :			else SOME (genDecisionTree((rest, delayed), defActive))
665 :			in CASETEST(path, sign, caseTrees, defTree)
666 :			end
667 :			| (ABSCONDEC(path, con, yes, guarded, defaults), rest) =>
668 :			let val yesActive = intersect(active, union(yes, defaults))
669 :			val noActive = intersect(active,defaults)
670 :			val yesTree =
671 :			genDecisionTree((rest@guarded, delayed), yesActive)
672 :			val defTree = genDecisionTree((rest, delayed), noActive)
673 :			in if unary con then ABSTEST1(path, con, yesTree, defTree)
674 :			else ABSTEST0(path, con, yesTree, defTree)
675 :			end)
676 :			handle PickBest => (RHS active1))
677 :			| genDecisionTree (_,active) = bug "nothing active"
678 :
679 :			and gencases (nil, decs, delayed, defaults, active) = nil
680 :			| gencases ((pcon,rules,guarded)::rest,decs,delayed,defaults,active)=
681 :			let val rActive = intersect(union(defaults, rules), active)
682 :			in (pcon, genDecisionTree((decs@guarded, delayed),rActive))
683 :			:: (gencases(rest,decs,delayed,defaults,active))
684 :			end
685 :
686 :			local open PrintUtil
687 :			val printDepth = Control.Print.printDepth
688 :			in
689 :
690 :			fun matchPrint (env,rules,unused) ppstrm =
691 :			let fun matchPrint' ([],_,_) = ()
692 :			| matchPrint' ([(pat,_)],_,_) = () (* never print last rule *)
693 :			| matchPrint' ((pat,_)::more,[],_) =
694 :			(add_string ppstrm " ";
695 :			PPAbsyn.ppPat env ppstrm (pat,!printDepth);
696 :			add_string ppstrm " => ...";
697 :			add_newline ppstrm;
698 :			matchPrint' (more,[],0))
699 :			| matchPrint' ((pat,_)::more,(taglist as (tag::tags)),i) =
700 :			if i = tag then
701 :			(add_string ppstrm " --> ";
702 :			PPAbsyn.ppPat env ppstrm (pat,!printDepth);
703 :			add_string ppstrm " => ...";
704 :			add_newline ppstrm;
705 :			matchPrint'(more,tags,i+1))
706 :			else
707 :			(add_string ppstrm " ";
708 :			PPAbsyn.ppPat env ppstrm (pat,!printDepth);
709 :			add_string ppstrm " => ...";
710 :			add_newline ppstrm;
711 :			matchPrint'(more,taglist,i+1))
712 :			in add_newline ppstrm;
713 :			begin_block ppstrm CONSISTENT 0;
714 :			matchPrint'(rules,unused,0);
715 :			end_block ppstrm
716 :			end
717 :
718 :			fun bindPrint (env,(pat,_)::_) ppstrm =
719 :			(add_newline ppstrm; add_string ppstrm " ";
720 :			PPAbsyn.ppPat env ppstrm (pat,!printDepth);
721 :			add_string ppstrm " = ...")
722 :			| bindPrint _ _ = bug "bindPrint in mc"
723 :
724 :			end (* local printutil *)
725 :
726 :			fun rulesUsed (RHS n) = [n]
727 :			| rulesUsed (BIND(_, dt)) = rulesUsed dt
728 :			| rulesUsed (CASETEST(_, _, cases, NONE)) =
729 :			foldr (fn((_,a), b) => union(rulesUsed a, b)) nil cases
730 :			| rulesUsed (CASETEST(_, _, cases, SOME dt)) =
731 :			foldr (fn((_,a), b) => union(rulesUsed a, b)) (rulesUsed dt) cases
732 :			| rulesUsed (ABSTEST0(_, _, yes, no)) =
733 :			union(rulesUsed yes, rulesUsed no)
734 :			| rulesUsed (ABSTEST1(_, _, yes, no)) =
735 :			union(rulesUsed yes, rulesUsed no)
736 :
737 :			fun fixupUnused(nil, _, _, _, out) = out
738 :			| fixupUnused(unused, (nil, _)::rest, n, m, out) =
739 :			fixupUnused(unused, rest, n, m + 1, out)
740 :			| fixupUnused(unused::urest, (rule::rules, x)::mrest, n, m, nil) =
741 :			if unused = n then
742 :			fixupUnused(urest, (rules, x)::mrest, n + 1, m, [m])
743 :			else
744 :			fixupUnused(unused::urest, (rules, x)::mrest, n + 1, m, nil)
745 :			| fixupUnused(unused::urest, (rule::rules, z)::mrest, n, m, x::y) =
746 :			if unused = n then
747 :			(if m <> x then
748 :			fixupUnused(urest, (rules, z)::mrest, n + 1, m, m::x::y)
749 :			else fixupUnused(urest, (rules, z)::mrest, n + 1, m, x::y))
750 :			else fixupUnused(unused::urest, (rules, z)::mrest, n + 1, m, x::y)
751 :			| fixupUnused _ = bug "bad fixup"
752 :
753 :			fun redundant (nil, n) = false
754 :			| redundant (a::b, n) = a <> n orelse redundant (b, n)
755 :
756 :			fun complement(n, m, a::b) =
757 :			if n < a then n::(complement(n + 1, m, a::b))
758 :			else complement(n + 1, m, b)
759 :			| complement(n, m, nil) =
760 :			if n < m then n::(complement(n + 1, m, nil)) else nil
761 :
762 :			fun dividePathList(pred, nil, accyes, accno) = (accyes, accno)
763 :			| dividePathList(pred, path::rest, accyes, accno) =
764 :			if pred path then dividePathList(pred, rest, path::accyes, accno)
765 :			else dividePathList(pred, rest, accyes, path::accno)
766 :
767 :			fun addPathToPathList (path, path1::rest) =
768 :			if pathEq(path, path1) then path1::rest
769 :			else path1::(addPathToPathList(path, rest))
770 :			| addPathToPathList (path, nil) = [path]
771 :
772 :			fun unitePathLists(paths1, nil) = paths1
773 :			| unitePathLists(nil, paths2) = paths2
774 :			| unitePathLists(path1::rest1, paths2) =
775 :			addPathToPathList(path1, unitePathLists(rest1, paths2))
776 :
777 :			fun onPathList (path1, nil) = false
778 :			| onPathList (path1, path2::rest) =
779 :			pathEq(path1, path2) orelse onPathList(path1, rest)
780 :
781 :			fun intersectPathLists(paths1, nil) = nil
782 :			| intersectPathLists(nil, paths2) = nil
783 :			| intersectPathLists(path1::rest1, paths2) =
784 :			if onPathList(path1,paths2) then
785 :			path1::(intersectPathLists(rest1, paths2))
786 :			else
787 :			intersectPathLists(rest1, paths2)
788 :
789 :			fun differencePathLists(paths1, nil) = paths1
790 :			| differencePathLists(nil, paths2) = nil
791 :			| differencePathLists(path1::rest1, paths2) =
792 :			if onPathList(path1,paths2) then
793 :			differencePathLists(rest1, paths2)
794 :			else
795 :			path1::(differencePathLists(rest1, paths2))
796 :
797 :			fun intersectPathsets(pathset1, nil) = nil
798 :			| intersectPathsets(nil, pathset2) = nil
799 :			| intersectPathsets(pathset1 as (n1:int, paths1)::rest1,
800 :			pathset2 as (n2, paths2)::rest2) =
801 :			if n1 = n2 then
802 :			case intersectPathLists(paths1, paths2)
803 :			of nil => intersectPathsets(rest1, rest2)
804 :			| pl => (n1, pl)::(intersectPathsets(rest1, rest2))
805 :			else if n1 < n2 then
806 :			intersectPathsets(rest1, pathset2)
807 :			else
808 :			intersectPathsets(pathset1, rest2)
809 :
810 :			fun unitePathsets(pathset1, nil) = pathset1
811 :			| unitePathsets(nil, pathset2) = pathset2
812 :			| unitePathsets(pathset1 as (n1:int, paths1)::rest1,
813 :			pathset2 as (n2, paths2)::rest2) =
814 :			if n1 = n2 then
815 :			(n1, unitePathLists(paths1, paths2))
816 :			:: (unitePathsets(rest1, rest2))
817 :			else if n1 < n2 then
818 :			(n1, paths1)::(unitePathsets(rest1, pathset2))
819 :			else
820 :			(n2, paths2)::(unitePathsets(pathset1, rest2))
821 :
822 :			fun differencePathsets(pathset1, nil) = pathset1
823 :			| differencePathsets(nil, pathset2) = nil
824 :			| differencePathsets(pathset1 as (n1:int, paths1)::rest1,
825 :			pathset2 as (n2, paths2)::rest2) =
826 :			if n1 = n2 then
827 :			case differencePathLists(paths1, paths2)
828 :			of nil => differencePathsets(rest1, rest2)
829 :			| pl => (n1, pl)::(differencePathsets(rest1, rest2))
830 :			else if n1 < n2 then
831 :			(n1, paths1)::(differencePathsets(rest1, pathset2))
832 :			else
833 :			differencePathsets(pathset1, rest2)
834 :
835 :			fun doPathsetMember(path, metric, (n:int, paths)::rest) =
836 :			(n < metric andalso doPathsetMember(path, metric, rest))
837 :			orelse (n = metric andalso onPathList(path, paths))
838 :			| doPathsetMember(path, metric, nil) = false
839 :
840 :			fun doAddElementToPathset(path, metric, nil) = [(metric, [path])]
841 :			| doAddElementToPathset(path, metric, (n:int, paths)::rest) =
842 :			if n = metric then (n, addPathToPathList(path, paths))::rest
843 :			else if n < metric then
844 :			(n,paths)::(doAddElementToPathset(path, metric, rest))
845 :			else (metric, [path])::(n, paths)::rest
846 :
847 :			fun dividePathset(pred, nil) = (nil, nil)
848 :			| dividePathset(pred, (n, pathlist)::rest) =
849 :			let val (yesSet, noSet) = dividePathset(pred, rest)
850 :			in case dividePathList(pred, pathlist, nil, nil)
851 :			of (nil, nil) => bug "paths dissappeared during divide"
852 :			| (nil, no) => (yesSet, (n,no)::noSet)
853 :			| (yes, nil) => ((n, yes)::yesSet, noSet)
854 :			| (yes, no) => ((n, yes)::yesSet, (n,no)::noSet)
855 :			end
856 :
857 :			fun pathDepends path1 ROOTPATH = pathEq(path1, ROOTPATH)
858 :			| pathDepends path1 (path2 as RECORDPATH paths) =
859 :			foldl (fn (a, b) => (pathDepends path1 a) orelse b)
860 :			(pathEq(path1, path2)) paths
861 :			| pathDepends path1 (path2 as PIPATH(_, subpath)) =
862 :			pathEq(path1, path2) orelse pathDepends path1 subpath
863 :			| pathDepends path1 (path2 as VPIPATH(_,_,subpath)) =
864 :			pathEq(path1, path2) orelse pathDepends path1 subpath
865 :			| pathDepends path1 (path2 as DELTAPATH(_,subpath)) =
866 :			pathEq(path1, path2) orelse pathDepends path1 subpath
867 :			| pathDepends path1 (path2 as (VLENPATH (subpath, _))) =
868 :			pathEq(path1, path2) orelse pathDepends path1 subpath
869 :
870 :			fun pathMetric (ROOTPATH) = 0
871 :			| pathMetric (RECORDPATH paths) =
872 :			foldr (fn (a, b) => pathMetric a + b) 1 paths
873 :			| pathMetric (PIPATH(_, subpath)) =
874 :			1 + pathMetric subpath
875 :			| pathMetric (VPIPATH(_,_,subpath)) =
876 :			1 + pathMetric subpath
877 :			| pathMetric (DELTAPATH(_,subpath)) =
878 :			1 + pathMetric subpath
879 :			| pathMetric (VLENPATH (subpath, _)) =
880 :			1 + pathMetric subpath
881 :
882 :			fun pathsetMember path pathset =
883 :			doPathsetMember(path, pathMetric path, pathset)
884 :
885 :			fun addPathToPathset(path, pathset) =
886 :			doAddElementToPathset(path, pathMetric path, pathset)
887 :
888 :
889 :			fun doDoBindings(nil, rhs) = rhs
890 :			| doDoBindings(path::rest, rhs) = BIND(path, doDoBindings(rest, rhs))
891 :
892 :			fun doBindings (nil, rhs) = rhs
893 :			| doBindings ((n,paths)::morepaths, rhs) =
894 :			doDoBindings(paths, doBindings(morepaths, rhs))
895 :
896 :			fun subPaths (ROOTPATH) = [(0, [ROOTPATH])]
897 :			| subPaths (path as RECORDPATH paths) =
898 :			foldr unitePathsets [(pathMetric path, [path])] (map subPaths paths)
899 :			| subPaths (path as (VLENPATH (subpath, _))) =
900 :			(subPaths subpath)@[(pathMetric path, [path])]
901 :			| subPaths (path as VPIPATH (n,_,subpath)) =
902 :			(subPaths subpath)@[(pathMetric path, [path])]
903 :			| subPaths (path as PIPATH (n, subpath)) =
904 :			(subPaths subpath)@[(pathMetric path, [path])]
905 :			| subPaths (path as DELTAPATH (_,subpath)) =
906 :			(subPaths subpath)@[(pathMetric path, [path])]
907 :
908 :			fun rhsbindings (n, ruleDesc) =
909 :			let val (_, paths, _) = List.nth(ruleDesc, n)
910 :			in foldr unitePathsets [] (map subPaths paths)
911 :			end
912 :
913 :			fun pass1cases((pcon,subtree)::rest, envin, SOME envout, rhs, path) =
914 :			let val (subtree', myEnvout) = pass1(subtree, envin, rhs)
915 :			val (mustBindHere, otherBindings) =
916 :			dividePathset(pathDepends(DELTAPATH(pcon,path)),myEnvout)
917 :			val envoutSoFar = intersectPathsets(envout, otherBindings)
918 :			val (rest', envout') =
919 :			pass1cases(rest, envin, SOME envoutSoFar, rhs, path)
920 :			val iBind2 = differencePathsets(otherBindings, envout')
921 :			val subtree'' =
922 :			doBindings(unitePathsets(mustBindHere, iBind2), subtree')
923 :			in ((pcon,subtree'')::rest', envout')
924 :			end
925 :			| pass1cases((pcon,subtree)::rest, envin, NONE, rhs, path) =
926 :			let val (subtree', myEnvout) = pass1(subtree, envin, rhs)
927 :			val (mustBindHere, otherBindings) =
928 :			dividePathset(pathDepends(DELTAPATH(pcon,path)),myEnvout)
929 :			val (rest', envout') =
930 :			pass1cases(rest, envin, SOME otherBindings, rhs, path)
931 :			val iBind2 = differencePathsets(otherBindings, envout')
932 :			val subtree'' =
933 :			doBindings(unitePathsets(mustBindHere, iBind2), subtree')
934 :			in ((pcon,subtree'')::rest', envout')
935 :			end
936 :			| pass1cases(nil, envin, SOME envout, rhs, path) =
937 :			(nil, unitePathsets(envin, envout))
938 :			| pass1cases(nil, envin, NONE, rhs, path) = bug "pass1cases bad"
939 :
940 :			and pass1(RHS n, envin, rhs) = (RHS n, rhsbindings(n, rhs))
941 :			| pass1(CASETEST(path, sign, cases, NONE), envin, rhs) =
942 :			let val (cases', envout') =
943 :			pass1cases(cases, unitePathsets(envin, subPaths path),
944 :			NONE, rhs, path)
945 :			in (CASETEST(path, sign, cases', NONE), envout')
946 :			end
947 :			| pass1(CASETEST(path, sign, cases, SOME subtree), envin, rhs) =
948 :			let val newenv = unitePathsets(envin, subPaths path)
949 :			val (subtree', subEnvout) = pass1(subtree, newenv, rhs)
950 :			val (cases', envout') =
951 :			pass1cases(cases, newenv, SOME subEnvout, rhs, path)
952 :			val subbindings = differencePathsets(subEnvout, envout')
953 :			val subtree'' = doBindings(subbindings, subtree')
954 :			in (CASETEST(path, sign, cases', SOME subtree''), envout')
955 :			end
956 :			| pass1 (ABSTEST0(path, con, subtree1, subtree2), envin, rhs) =
957 :			let val newenv = unitePathsets(envin, subPaths path)
958 :			val (subtree1', subEnvout1) = pass1(subtree1, newenv, rhs)
959 :			val (subtree2', subEnvout2) = pass1(subtree2, newenv, rhs)
960 :			val envout =
961 :			unitePathsets(newenv,intersectPathsets(subEnvout1,subEnvout2))
962 :			val bind1 = differencePathsets(subEnvout1, envout)
963 :			val bind2 = differencePathsets(subEnvout2, envout)
964 :			val subtree1'' = doBindings(bind1, subtree1')
965 :			val subtree2'' = doBindings(bind2, subtree2')
966 :			in (ABSTEST0(path, con, subtree1'', subtree2''), envout)
967 :			end
968 :			| pass1 (ABSTEST1(path, con, subtree1, subtree2), envin, rhs) =
969 :			let val newenv = unitePathsets(envin, subPaths path)
970 :			val yesenv =
971 :			if isAnException con then newenv
972 :			else addPathToPathset(DELTAPATH(DATApcon con, path), envin)
973 :			val (subtree1', subEnvout1) = pass1(subtree1, yesenv, rhs)
974 :			val (subtree2', subEnvout2) = pass1(subtree2, newenv, rhs)
975 :			val envout =
976 :			unitePathsets(newenv,
977 :			intersectPathsets(subEnvout1,subEnvout2))
978 :			val bind1 = differencePathsets(subEnvout1, envout)
979 :			val bind2 = differencePathsets(subEnvout2, envout)
980 :			val subtree1'' = doBindings(bind1, subtree1')
981 :			val subtree2'' = doBindings(bind2, subtree2')
982 :			in (ABSTEST1(path, con, subtree1'', subtree2''), envout)
983 :			end
984 :			| pass1 _ = bug "pass1 bad"
985 :
986 :
987 :			(*
988 :			* Given a decision tree for a match, a list of ?? and the name of the
989 :			* variable bound to the value to be matched, produce code for the match.
990 :			*)
991 :	monnier	45	fun generate (dt, matchRep, rootVar, (toTyc, toLty)) =
992 :	monnier	16	let val (subtree, envout) = pass1(dt, [(0, [ROOTPATH])], matchRep)
993 :	monnier	45	fun mkDcon (DATACON {name, rep, typ, ...}) =
994 :			(name, rep, toDconLty toLty typ)
995 :	monnier	16	fun genpath (RECORDPATH paths, env) =
996 :			RECORD (map (fn path => VAR(lookupPath (path, env))) paths)
997 :			| genpath (PIPATH(n, path), env) =
998 :			SELECT(n, VAR(lookupPath(path, env)))
999 :			| genpath (p as DELTAPATH(pcon, path), env) =
1000 :			VAR(lookupPath(p, env))
1001 :			| genpath (VPIPATH(n, t, path), env) =
1002 :	monnier	45	let val tc = toTyc t
1003 :	monnier	16	val lt_sub =
1004 :			let val x = LT.ltc_vector (LT.ltc_tv 0)
1005 :			in LT.ltc_poly([LT.tkc_mono],
1006 :			[LT.ltc_parrow(LT.ltc_tuple [x, LT.ltc_int], LT.ltc_tv 0)])
1007 :			end
1008 :			in APP(PRIM(PO.SUBSCRIPTV, lt_sub, [tc]),
1009 :			RECORD[VAR(lookupPath(path, env)), INT n])
1010 :			end
1011 :			| genpath (VLENPATH (path, t), env) =
1012 :	monnier	45	let val tc = toTyc t
1013 :	monnier	16	val lt_len = LT.ltc_poly([LT.tkc_mono],
1014 :			[LT.ltc_parrow(LT.ltc_tv 0, LT.ltc_int)])
1015 :			val argtc = LT.tcc_vector tc
1016 :			in APP(PRIM(PO.LENGTH, lt_len, [argtc]),
1017 :			VAR(lookupPath(path, env)))
1018 :			end
1019 :			| genpath (ROOTPATH, env) = VAR(lookupPath(ROOTPATH, env))
1020 :
1021 :			fun genswitch(sv, sign, [(DATAcon((_, DA.REF, lt), ts, x), e)], NONE) =
1022 :			LET(x, APP (PRIM (PrimOp.DEREF, LT.lt_swap lt, ts), sv), e)
1023 :			| genswitch(sv, sign, [(DATAcon((_, DA.SUSP(SOME(_, DA.LVAR f)), lt),
1024 :			ts, x), e)], NONE) =
1025 :			let val v = mkv()
1026 :			in LET(x, LET(v, TAPP(VAR f, ts), APP(VAR v, sv)), e)
1027 :			end
1028 :			| genswitch x = SWITCH x
1029 :
1030 :			fun pass2rhs (n, env, ruleDesc) =
1031 :			(case List.nth(ruleDesc, n)
1032 :			of (_, [path], fname) => APP(VAR fname, VAR(lookupPath(path, env)))
1033 :			| (_, paths, fname) =>
1034 :			APP(VAR fname,
1035 :			RECORD (map (fn path => VAR(lookupPath(path, env))) paths)))
1036 :
1037 :			fun pass2 (BIND(DELTAPATH _, subtree), env, rhs) =
1038 :			pass2(subtree, env, rhs)
1039 :			(** we no longer generate explicit DECON anymore, instead,
1040 :			we add a binding at each switch case. *)
1041 :			| pass2 (BIND(path, subtree), env, rhs) =
1042 :			let val newvar = mkv()
1043 :			val subcode = pass2(subtree, (path, newvar)::env, rhs)
1044 :			in LET(newvar, genpath(path, env), subcode)
1045 :			end
1046 :			| pass2 (CASETEST(path, sign, [], NONE), _, _) =
1047 :			bug "unexpected empty cases in matchcomp"
1048 :			| pass2 (CASETEST(path, sign, [], SOME subtree), env, rhs) =
1049 :			pass2(subtree,env,rhs)
1050 :			| pass2 (CASETEST(path, sign, cases, dft), env, rhs) =
1051 :			let val sv = VAR(lookupPath(path, env))
1052 :			in genswitch(sv, sign, pass2cases(path,cases,env,rhs),
1053 :			(case dft
1054 :			of NONE => NONE
1055 :			| SOME subtree => SOME(pass2(subtree,env,rhs))))
1056 :			end
1057 :			| pass2 (ABSTEST0(path, con as (dc, _), yes, no), env, rhs) =
1058 :			(* if isAnException con
1059 :			then genswitch(VAR(lookupPath(path, env)), DA.CNIL,
1060 :	monnier	45	[(DATAcon(mkDcon dc), pass2(yes, env, rhs))],
1061 :	monnier	16	SOME(pass2(no, env, rhs)))
1062 :			else *)
1063 :			abstest0(path, con, pass2(yes,env,rhs), pass2(no,env,rhs))
1064 :			| pass2 (ABSTEST1(path, con as (dc, _), yes, no), env, rhs) =
1065 :			(* if isAnException con
1066 :			then genswitch(VAR(lookupPath(path, env)), DA.CNIL,
1067 :	monnier	45	[(DATAcon(mkDcon dc), pass2(yes, env, rhs))],
1068 :	monnier	16	SOME(pass2(no, env, rhs)))
1069 :			else *)
1070 :			abstest1(path, con, pass2(yes,env,rhs), pass2(no,env,rhs))
1071 :			| pass2 (RHS n, env, rhs) = pass2rhs(n, env, rhs)
1072 :
1073 :			and pass2cases(path, nil, env, rhs) = nil
1074 :			| pass2cases(path, (pcon,subtree)::rest, env, rhs) =
1075 :			let (** always implicitly bind a new variable at each branch. *)
1076 :	monnier	45	val (ncon, nenv) = pconToCon(pcon, path, env)
1077 :	monnier	16	val res = (ncon, pass2(subtree, nenv, rhs))
1078 :			in res::(pass2cases(path, rest, env, rhs))
1079 :			end
1080 :
1081 :	monnier	45	and pconToCon(pcon, path, env) =
1082 :	monnier	16	(case pcon
1083 :			of DATApcon (dc, ts) =>
1084 :			let val newvar = mkv()
1085 :	monnier	45	val nts = map toTyc ts
1086 :	monnier	16	val nenv = (DELTAPATH(pcon, path), newvar)::env
1087 :	monnier	45	in (DATAcon (mkDcon dc, nts, newvar), nenv)
1088 :	monnier	16	end
1089 :			| VLENpcon(i, t) => (VLENcon i, env)
1090 :			| INTpcon i => (INTcon i, env)
1091 :			| INT32pcon i => (INT32con i, env)
1092 :			| WORDpcon w => (WORDcon w, env)
1093 :			| WORD32pcon w => (WORD32con w, env)
1094 :			| REALpcon r => (REALcon r, env)
1095 :			| STRINGpcon s => (STRINGcon s, env))
1096 :
1097 :			in case doBindings(envout, subtree)
1098 :			of BIND(ROOTPATH, subtree') =>
1099 :			pass2(subtree', [(ROOTPATH, rootVar)], matchRep)
1100 :			| _ => pass2(subtree, [], matchRep)
1101 :			end
1102 :
1103 :	monnier	45	fun doMatchCompile(rules, finish, rootvar, toTcLt as (_, toLty), err) =
1104 :	monnier	16	let val lastRule = length rules - 1
1105 :	monnier	45	val matchReps = map (preProcessPat toLty) rules
1106 :	monnier	16	val (matchRep,rhsRep) =
1107 :			foldr (fn ((a,b),(c,d)) => (a@c,b::d)) ([], []) matchReps
1108 :
1109 :			val allRules = mkAllRules(matchRep,0)
1110 :			val flattened = flattenAndors(makeAndor(matchRep,err),allRules)
1111 :			val ready = fireConstraint(ROOTPATH,flattened,nil,nil)
1112 :			val dt = genDecisionTree(ready,allRules)
1113 :			val numRules = length matchRep
1114 :			val rawUnusedRules = complement(0,numRules,rulesUsed dt)
1115 :			val unusedRules = rev(fixupUnused(rawUnusedRules,matchReps,0,0,nil))
1116 :			val exhaustive = isthere(lastRule,unusedRules)
1117 :			val redundantF = redundant(unusedRules, lastRule)
1118 :
1119 :			fun g((fname, fbody), body) = LET(fname, fbody, body)
1120 :	monnier	45	val code = foldr g (generate(dt, matchRep, rootvar, toTcLt)) rhsRep
1121 :	monnier	16
1122 :			in (finish(code), unusedRules, redundantF, exhaustive)
1123 :			end
1124 :
1125 :			(*
1126 :			* Test pat, the guard pattern of the first match rule of a match,
1127 :			* for the occurence of variables (including layering variables)
1128 :			* or wildcards. Return true if any are present, false otherwise.
1129 :			*)
1130 :			fun noVarsIn ((pat,_)::_) =
1131 :			let fun var WILDpat = true (* might want to flag this *)
1132 :			| var (VARpat _) = true
1133 :			| var (LAYEREDpat _) = true
1134 :			| var (CONSTRAINTpat(p,_)) = var p
1135 :			| var (APPpat(_,_,p)) = var p
1136 :			| var (RECORDpat{fields,...}) = List.exists (var o #2) fields
1137 :			| var (VECTORpat(pats,_)) = List.exists var pats
1138 :			| var (ORpat (pat1,pat2)) = var pat1 orelse var pat2
1139 :			| var _ = false
1140 :			in not(var pat)
1141 :			end
1142 :			| noVarsIn _ = bug "noVarsIn in mc"
1143 :
1144 :
1145 :			(*
1146 :			* The three entry points for the match compiler.
1147 :			*
1148 :			* They take as arguments an environment (env); a match represented
1149 :			* as a list of pattern--lambda expression pairs (match); and a
1150 :			* function to use in printing warning messages (warn).
1151 :			*
1152 :			* env and warn are only used in the printing of diagnostic information.
1153 :			*
1154 :			* If the control flag Control.MC.printArgs is set, they print match.
1155 :			*
1156 :			* They call doMatchCompile to actually compile match.
1157 :			* This returns a 4-tuple (code, unused, redundant, exhaustive).
1158 :			* code is lambda code that implements match. unused
1159 :			* is a list of the indices of the unused rules. redundant
1160 :			* and exhaustive are boolean flags which are set if
1161 :			* match is redundant or exhaustive respectively.
1162 :			*
1163 :			* They print warning messages as appropriate, as described below.
1164 :			* If the control flag Control.MC.printRet is set, they print code.
1165 :			*
1166 :			* They return code.
1167 :			*
1168 :			* They assume that match has one element for each rule of the match
1169 :			* to be compiled, in order, plus a single, additional, final element.
1170 :			* This element must have a pattern that is always matched
1171 :			* (in practice, it is either a variable or wildcard), and a
1172 :			* lambda expression that implements the appropriate behavior
1173 :			* for argument values that satisfy none of the guard patterns.
1174 :			* A pattern is exhaustive if this dummy rule is never used,
1175 :			* and is irredundant if all of the other rules are used.
1176 :			*)
1177 :
1178 :			local open Control.MC (* make various control flags visible *)
1179 :			in
1180 :
1181 :			(*
1182 :			* Entry point for compiling matches induced by val declarations
1183 :			* (e.g., val listHead::listTail = list). match is a two
1184 :			* element list. If the control flag Control.MC.bindExhaustive
1185 :			* is set, and match is inexhaustive a warning is printed. If the control
1186 :			* flag Control.MC.bindContainsVar is set, and the first pattern
1187 :			* (i.e., the only non-dummy pattern) of match contains no variables or
1188 :			* wildcards, a warning is printed. Arguably, a pattern containing no
1189 :			* variables, but one or more wildcards, should also trigger a warning,
1190 :			* but this would cause warnings on constructions like
1191 :			* val _ = <exp> and val _:<ty> = <exp>.
1192 :			*)
1193 :	monnier	45	fun bindCompile (env, rules, finish, rootv, toTcLt, err) =
1194 :	monnier	16	let val _ =
1195 :			if !printArgs then (say "MC called with:"; MP.printMatch env rules)
1196 :			else ()
1197 :			val (code, _, _, exhaustive) =
1198 :	monnier	45	doMatchCompile(rules, finish, rootv, toTcLt, err)
1199 :	monnier	16
1200 :			val inexhaustiveF = !bindExhaustive andalso not exhaustive
1201 :			val noVarsF = !bindContainsVar andalso noVarsIn rules
1202 :
1203 :			in if inexhaustiveF
1204 :			then err EM.WARN "binding not exhaustive" (bindPrint(env,rules))
1205 :			else if noVarsF
1206 :			then err EM.WARN "binding contains no variables"
1207 :			(bindPrint(env,rules))
1208 :			else ();
1209 :
1210 :			if !printRet then
1211 :			(say "MC: returns with\n"; MP.printLexp code)
1212 :			else ();
1213 :			code
1214 :			end
1215 :
1216 :			(*
1217 :			* Entry point for compiling matches induced by exception handlers.
1218 :			* (e.g., handle Bind => Foo). If the control flag
1219 :			* Control.MC.matchRedundantWarn is set, and match is redundant,
1220 :			* a warning is printed. If Control.MC.matchRedundantError is also
1221 :			* set, the warning is promoted to an error message.
1222 :			*)
1223 :	monnier	45	fun handCompile (env, rules, finish, rootv, toTcLt, err) =
1224 :	monnier	16	let val _ =
1225 :			if !printArgs then (say "MC called with: "; MP.printMatch env rules)
1226 :			else ()
1227 :			val (code, unused, redundant, _) =
1228 :	monnier	45	doMatchCompile(rules, finish, rootv, toTcLt, err)
1229 :	monnier	16	val redundantF= !matchRedundantWarn andalso redundant
1230 :
1231 :			in if redundantF
1232 :			then err
1233 :			(if !matchRedundantError then EM.COMPLAIN else EM.WARN)
1234 :			"redundant patterns in match"
1235 :			(matchPrint(env,rules,unused))
1236 :			else ();
1237 :
1238 :			if !printRet
1239 :			then (say "MC: returns with\n"; MP.printLexp code)
1240 :			else ();
1241 :			code
1242 :			end
1243 :
1244 :			(*
1245 :			* Entry point for compiling matches induced by function expressions
1246 :			* (and thus case expression, if-then-else expressions, while expressions
1247 :			* and fun declarations) (e.g., fn (x::y) => ([x],y)). If the control flag
1248 :			* Control.MC.matchRedundantWarn is set, and match is redundant, a warning
1249 :			* is printed; if Control.MC.matchRedundantError is also set, the warning
1250 :			* is promoted to an error. If the control flag Control.MC.matchExhaustive
1251 :			* is set, and match is inexhaustive, a warning is printed.
1252 :			*)
1253 :	monnier	45	fun matchCompile (env, rules, finish, rootv, toTcLt, err) =
1254 :	monnier	16	let val _ =
1255 :			if !printArgs then (say "MC called with: "; MP.printMatch env rules)
1256 :			else ()
1257 :			val (code, unused, redundant, exhaustive) =
1258 :	monnier	45	doMatchCompile(rules, finish, rootv, toTcLt, err)
1259 :	monnier	16
1260 :			val nonexhaustiveF =
1261 :			not exhaustive andalso
1262 :			(!matchNonExhaustiveError orelse !matchNonExhaustiveWarn)
1263 :			val redundantF =
1264 :			redundant andalso (!matchRedundantError orelse !matchRedundantWarn)
1265 :			in case (nonexhaustiveF,redundantF)
1266 :			of (true, true) =>
1267 :			err (if !matchRedundantError orelse !matchNonExhaustiveError
1268 :			then EM.COMPLAIN else EM.WARN)
1269 :			"match redundant and nonexhaustive"
1270 :			(matchPrint(env, rules, unused))
1271 :
1272 :			| (true, false) =>
1273 :			err (if !matchNonExhaustiveError then EM.COMPLAIN else EM.WARN)
1274 :			"match nonexhaustive"
1275 :			(matchPrint(env, rules, unused))
1276 :
1277 :			| (false, true) =>
1278 :			err (if !matchRedundantError then EM.COMPLAIN else EM.WARN)
1279 :			"match redundant" (matchPrint(env, rules, unused))
1280 :
1281 :			| _ => ();
1282 :
1283 :			if (!printRet)
1284 :			then (say "MatchComp: returns with\n"; MP.printLexp code) else ();
1285 :			code
1286 :			end
1287 :
1288 :
1289 :			val matchCompile =
1290 :			Stats.doPhase(Stats.makePhase "Compiler 045 matchcomp") matchCompile
1291 :
1292 :			end (* local Control.MC *)
1293 :
1294 :			end (* topleve local *)
1295 :			end (* structure MatchComp *)
1296 :
1297 :			(*
1298 :	monnier	113	* $Log$
1299 :	monnier	16	*)

---

root@smlnj-gforge.cs.uchicago.edu	ViewVC Help
Powered by ViewVC 1.0.0