Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/SMLNJ/src/compiler/FLINT/trans/matchcomp.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 45 - (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 :     * $Log: matchcomp.sml,v $
1299 :     * Revision 1.8 1997/07/15 16:23:16 dbm
1300 :     * Added matchRedundantError flag, which is used to promote match redundant
1301 :     * warning into an error.
1302 :     *
1303 :     * Revision 1.7 1997/05/05 20:00:13 george
1304 :     * Change the term language into the quasi-A-normal form. Added a new round
1305 :     * of lambda contraction before and after type specialization and
1306 :     * representation analysis. Type specialization including minimum type
1307 :     * derivation is now turned on all the time. Real array is now implemented
1308 :     * as realArray. A more sophisticated partial boxing scheme is added and
1309 :     * used as the default.
1310 :     *
1311 :     * Revision 1.6 1997/04/14 21:40:55 dbm
1312 :     * Rearranged code to get err parameter to wordCon function so that a
1313 :     * proper error message could be generated for out of range literal
1314 :     * constants. Fixes bug 1178.
1315 :     *
1316 :     * Revision 1.5 1997/03/22 18:24:10 dbm
1317 :     * Changed order of opens to open Lambda after Types, because Types now
1318 :     * has INT, WORD, etc. constructors (for type litKind).
1319 :     *
1320 :     * Revision 1.4 1997/02/26 21:54:29 george
1321 :     * *** empty log message ***
1322 :     *
1323 :     *)

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