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/trunk/src/compiler/FLINT/trans/matchcomp.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/trans/matchcomp.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (view) (download)

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

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