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/MLRISC/Tools/MatchCompiler/match-gen.sml
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/Tools/MatchCompiler/match-gen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1079 - (view) (download)

1 : leunga 744 (*
2 :     * Interface with the match compiler to generate ML code.
3 :     *)
4 :     functor MatchGen
5 :     (structure AstPP : MDL_AST_PRETTY_PRINTER
6 :     structure AstUtil : MDL_AST_UTIL
7 :     structure AstRewriter : MDL_AST_REWRITER
8 :     sharing AstPP.Ast = AstUtil.Ast = AstRewriter.Ast
9 :     ) : MATCH_GEN =
10 :     struct
11 :     structure Ast = AstPP.Ast
12 :     structure A = Ast
13 :     structure R = AstRewriter
14 :    
15 :     val NO = R.noRewrite
16 : leunga 775 val rw = R.rewrite
17 : leunga 752 val ++ = PP.++
18 :    
19 :     infix ++
20 : leunga 744
21 :     val i2s = Int.toString
22 :    
23 :     structure Guard =
24 :     struct
25 : leunga 775 type guard = int * A.exp
26 :     fun toString(_,e) = PP.text(AstPP.exp e)
27 :     fun compare((i,_),(j,_)) = Int.compare(i,j)
28 :     val counter = ref 0
29 :     fun guard e = (!counter,e) before counter := !counter + 1
30 :     fun logicalAnd((_,x),(_,y)) = guard(AstUtil.ANDALSO(x,y))
31 :     end
32 :    
33 :     structure Exp =
34 :     struct
35 :     type exp = A.exp
36 : leunga 744 val toString = PP.text o AstPP.exp
37 :     end
38 :    
39 :     structure Literal =
40 :     struct
41 :     type literal = A.literal
42 :     val toString = PP.text o AstPP.literal
43 :     val compare = AstUtil.compareLiteral
44 : leunga 775 val bools = SOME{known=[A.BOOLlit false, A.BOOLlit true],others=false}
45 :     fun variants(A.BOOLlit _) = bools
46 :     | variants _ = NONE
47 :     structure Map = RedBlackMapFn(type ord_key = literal
48 :     val compare = compare)
49 : leunga 744 end
50 : leunga 775 structure LitMap = Literal.Map
51 : leunga 744
52 :     datatype conrep = CONREP of A.id list * A.consbind * A.datatypebind
53 : leunga 775 | EXN of A.id list * A.id * A.ty option
54 : leunga 744
55 :     structure Con =
56 :     struct
57 :     type con = conrep
58 :    
59 :     fun toString(CONREP(path,A.CONSbind{id, ...},_)) =
60 :     PP.text(AstPP.ident(A.IDENT(path,id)))
61 : leunga 775 | toString(EXN(path,id,ty)) =
62 :     PP.text(AstPP.ident(A.IDENT(path,id)))
63 : leunga 744
64 : leunga 775 fun compare(CONREP(_,A.CONSbind{id=x,...},_),
65 :     CONREP(_,A.CONSbind{id=y,...},_)) = String.compare(x,y)
66 :     | compare(EXN(_,x,_),EXN(_,y,_)) = String.compare(x,y)
67 :     | compare(CONREP _, EXN _) = LESS
68 :     | compare(EXN _, CONREP _) = GREATER
69 : leunga 744
70 : leunga 775 fun variants(CONREP(path,_,dt as A.DATATYPEbind{cbs, ...})) =
71 :     {known=map (fn c => CONREP(path,c,dt)) cbs, others=false}
72 :     | variants(EXN _) = {known=[], others=true}
73 : leunga 744
74 :     fun arity(CONREP(_,A.CONSbind{ty=NONE, ...},_)) = 0
75 :     | arity(CONREP(_,A.CONSbind{ty=SOME ty, ...},_)) = 1
76 : leunga 775 | arity(EXN(_,_,NONE)) = 0
77 :     | arity(EXN(_,_,SOME _)) = 1
78 : leunga 744 end
79 :    
80 :     structure Var =
81 :     struct
82 :     type var = A.id
83 :     val compare = String.compare
84 :     fun toString x = x
85 :     structure Map = RedBlackMapFn(type ord_key = var
86 :     val compare = compare)
87 : george 909 structure Set = RedBlackSetFn(type ord_key = var
88 :     val compare = compare)
89 : leunga 744 end
90 :    
91 : george 909 structure Action =
92 :     struct
93 :     type action = A.exp
94 :     val toString = PP.text o AstPP.exp
95 :     fun freeVars e =
96 :     let val fvs = ref Var.Set.empty
97 :     fun exp _ (e as A.IDexp(A.IDENT([],x))) =
98 :     (fvs := Var.Set.add(!fvs,x); e)
99 :     | exp _ e = e
100 :     in #exp(R.rewrite{pat=NO,exp=exp,decl=NO,sexp=NO,ty=NO}) e;
101 :     Var.Set.listItems(!fvs)
102 :     end
103 :     end
104 :    
105 : leunga 744 structure MC =
106 :     MatchCompiler(structure Guard = Guard
107 : leunga 775 structure Exp = Exp
108 : leunga 744 structure Literal = Literal
109 :     structure Con = Con
110 :     structure Var = Var
111 :     structure Action = Action
112 :     )
113 :    
114 :     fun ID x = A.IDexp(A.IDENT([],x))
115 :     fun STATE x = "state_"^(i2s x)
116 :    
117 :     exception MatchCompiler = MC.MatchCompiler
118 :    
119 : leunga 775 structure Env =
120 :     struct
121 :     datatype env = ENV of {cons:conrep Var.Map.map, sigs:env Var.Map.map}
122 :     fun insertCons(ENV{cons,sigs}, id, conrep) =
123 :     ENV{cons=Var.Map.insert(cons, id, conrep), sigs=sigs}
124 :     fun insertSig(ENV{cons,sigs}, id, env) =
125 :     ENV{cons=cons,sigs=Var.Map.insert(sigs, id, env)}
126 :     fun lookupSig(ENV{sigs,...}, id) = Var.Map.find(sigs,id)
127 :     fun lookupCons(ENV{cons, ...}, id) = Var.Map.find(cons,id)
128 :     val empty = ENV{cons=Var.Map.empty,sigs=Var.Map.empty}
129 :     end
130 :     type compiled_type_info = Env.env
131 : leunga 744
132 : leunga 775 (* enter all datatypes definitions into a list *)
133 :     fun compileTypes ds =
134 :     let fun dbind(t as A.DATATYPEbind{cbs, ...}, env) =
135 :     List.foldr (fn (c as A.CONSbind{id,...},env) =>
136 :     Env.insertCons(env, id, CONREP([],c,t)))
137 :     env cbs
138 :     | dbind(_, env) = env
139 :     and dbinds(dbs,env) = List.foldr dbind env dbs
140 :     and ebind(A.EXCEPTIONbind(id,ty), env) =
141 :     Env.insertCons(env, id, EXN([], id, ty))
142 :     | ebind(_, env) = env
143 :     and ebinds(ebs,env) = List.foldr ebind env ebs
144 :     and decl(A.DATATYPEdecl(dbs, _), env) = dbinds(dbs, env)
145 :     | decl(A.EXCEPTIONdecl ebs, env) = ebinds(ebs, env)
146 :     | decl(A.MARKdecl(_,d), env) = decl(d, env)
147 :     | decl(A.SIGNATUREdecl(id,A.DECLsig ds),env) = decls(ds, env)
148 :     | decl(A.STRUCTUREdecl(id,_,_,A.DECLsexp ds),env) = nested(id,ds,env)
149 :     | decl(A.SEQdecl ds, env) = decls(ds, env)
150 :     | decl(_,env) = env
151 :     and decls(ds,env) = List.foldr decl env ds
152 :     and nested(id,ds,env) =
153 :     let val env' = decls(ds,Env.empty)
154 :     in Env.insertSig(env,id,env')
155 :     end
156 :     in decls(ds,Env.empty)
157 :     end
158 : leunga 744
159 : leunga 752 fun prClause(p, g) =
160 :     PP.text(AstPP.pat p ++ PP.sp ++
161 :     (case g of NONE => PP.! "=> ..."
162 :     | SOME e => PP.! "where ... => ..."))
163 :    
164 : leunga 775 fun compile env clauses =
165 : leunga 744 let (* rename all rules *)
166 :    
167 : leunga 775 fun hasCon x = isSome(Env.lookupCons(env, x))
168 : leunga 744
169 : leunga 775 fun lookup(env,path,[],x) =
170 :     (case Env.lookupCons(env, x) of
171 :     SOME(CONREP(_,c,t)) => CONREP(path,c,t)
172 :     | SOME(EXN(_,id,t)) => EXN(path,id,t)
173 :     | NONE => raise MatchCompiler("undefined constructor "^x)
174 :     )
175 :     | lookup(env,path,p::ps,x) =
176 :     (case Env.lookupSig(env, p) of
177 :     SOME env => lookup(env,path,ps,x)
178 :     | NONE => raise MatchCompiler("undefined structure "^p^" in "^
179 :     PP.text(AstPP.ident(A.IDENT(path,x))))
180 :     )
181 :     fun lookupCon (A.IDENT(p,x)) = lookup(env,p,p,x)
182 :    
183 : leunga 744 (* Rewrite list patterns *)
184 :     fun transListPat p =
185 :     let fun Cons(x,y) = A.CONSpat(A.IDENT([],"::"), SOME(A.TUPLEpat[x,y]))
186 :     val Nil = A.CONSpat(A.IDENT([],"nil"),NONE)
187 :    
188 :     fun listify([], SOME p) = p
189 :     | listify([], NONE) = Nil
190 :     | listify(p::ps, t) = Cons(p, listify(ps, t))
191 :     fun pat _ (A.LISTpat(ps, t)) = listify(ps, t)
192 :     | pat _ p = p
193 :     in #pat(R.rewrite{pat=pat,exp=NO,decl=NO,sexp=NO,ty=NO}) p
194 :     end
195 :    
196 : leunga 752 val rule_no = ref 0
197 : leunga 744
198 :     fun renameRule(c as A.CLAUSE([pat],guard,e)) =
199 : leunga 775 let val (e,cont) = case e of
200 :     A.CONTexp(e,x) => (e,SOME x)
201 :     | _ => (e, NONE)
202 :     in MC.rename
203 : leunga 744 (fn {idPat, asPat, consPat, wildPat,
204 : leunga 775 tuplePat, recordPat, litPat,
205 :     orPat, andPat, notPat, wherePat, nestedPat, ...} =>
206 :     fn A.IDpat id =>
207 : leunga 744 if hasCon id then consPat(lookupCon(A.IDENT([],id)),[])
208 :     else idPat id
209 :     | A.ASpat(id,p) => asPat(id,p)
210 :     | A.WILDpat => wildPat()
211 :     | A.CONSpat(c,NONE) => consPat(lookupCon c,[])
212 :     | A.CONSpat(c,SOME(p)) => consPat(lookupCon c,[p])
213 :     | A.TUPLEpat ps => tuplePat ps
214 :     | A.RECORDpat(lps,_) => recordPat lps
215 :     | A.LITpat lit => litPat lit
216 : leunga 752 | A.ORpat ps => orPat ps
217 : leunga 775 | A.ANDpat ps => andPat ps
218 :     | A.NOTpat p => notPat p
219 :     | A.WHEREpat(p,e) => wherePat(p,Guard.guard e)
220 :     | A.NESTEDpat(p,e,p') => nestedPat(p,Guard.guard e,p')
221 : leunga 744 | p => raise MC.MatchCompiler("illegal pattern "^
222 :     PP.text(AstPP.pat p))
223 : leunga 775 ) {number= !rule_no,
224 :     pats=[transListPat pat],
225 :     guard=Option.map Guard.guard guard,
226 :     cont=cont,
227 :     action=e
228 :     }
229 :     before rule_no := !rule_no + 1
230 :     end handle MC.MatchCompiler msg =>
231 : leunga 752 raise MC.MatchCompiler(msg^" in "^ prClause(pat,guard))
232 : leunga 744
233 :     val rules = map renameRule clauses
234 :    
235 :     (* compile the rules into a dfa *)
236 :     val dfa = MC.compile{compiled_rules=rules, compress=true}
237 :     in dfa
238 :     end
239 :    
240 : leunga 752 (* Report errors *)
241 :     fun report {warning, error, log, dfa, rules} =
242 :     let val red = MC.redundant dfa
243 :     val ex = MC.exhaustive dfa
244 :     val bad = IntListSet.numItems red > 0
245 :     val error = if bad then error else warning
246 :     val message = if ex then
247 :     if bad then "redundant matches"
248 :     else ""
249 :     else
250 :     if bad then "non-exhaustive and redundant matches"
251 :     else "non-exhaustive matches"
252 :     fun dumpRules(i, []) = ()
253 :     | dumpRules(i, r::rules) =
254 :     let val tab = if IntListSet.member(red,i) then "---> " else " "
255 :     val A.CLAUSE([p], g, _) = r
256 :     val text = prClause(p, g)
257 :     in log(tab^text);
258 :     dumpRules(i+1, rules)
259 :     end
260 :     in if not ex orelse bad then
261 :     (error message;
262 :     dumpRules(0, rules)
263 :     )
264 :     else ()
265 :     end
266 : leunga 775
267 :     exception GenReal and GenIntInf
268 : george 909
269 :     local
270 :     val intInfCompare = A.IDexp(A.IDENT(["IntInf"],"compare"))
271 :     val realEq = A.IDexp(A.IDENT(["Real"],"=="))
272 :     val eq = A.IDexp(A.IDENT([],"="))
273 :     val equal = A.IDexp(A.IDENT([],"EQUAL"))
274 :     in
275 :    
276 :     fun makeIntInfEq(x,y) = A.APPexp(eq,
277 :     A.TUPLEexp[A.APPexp(intInfCompare,
278 :     A.TUPLEexp[x,y]),
279 :     equal])
280 :     fun makeRealEq(x,y) = A.APPexp(realEq,A.TUPLEexp[x,y])
281 :     end
282 : leunga 752
283 : leunga 1079 val nameCounter = ref 0
284 :     fun newName() = !nameCounter before nameCounter := !nameCounter + 1
285 :     fun init() = nameCounter := 0
286 :    
287 : leunga 752 (* Generate ML code *)
288 : leunga 775 fun codeGen {root, dfa, fail=genFail, literals} =
289 : leunga 744 let (* make unique name for path variables *)
290 :     val nameTbl = ref MC.Path.Map.empty
291 :    
292 : leunga 775 fun genLit (l as A.INTINFlit _) =
293 :     (case Literal.Map.find(!literals, l) of
294 :     SOME v => AstUtil.ID v
295 :     | NONE => let val v = "lit_"^i2s(newName())
296 :     in literals := Literal.Map.insert(!literals, l, v);
297 :     AstUtil.ID v
298 :     end
299 :     )
300 :     | genLit l = A.LITexp l
301 :    
302 : leunga 744 fun getName path =
303 :     case MC.Path.Map.find(!nameTbl, path) of
304 :     SOME name => name
305 :     | NONE =>
306 : leunga 775 let val v = "v_"^i2s(newName())
307 :     in nameTbl := MC.Path.Map.insert(!nameTbl, path, v);
308 : leunga 744 v
309 :     end
310 :    
311 :     (* Now generate the code; we just have to hook things up with the MC *)
312 :     fun genVar path = getName path
313 : leunga 775 fun genPath path = ID(genVar path)
314 : leunga 744 fun genBind [] = []
315 :     | genBind bindings =
316 : leunga 775 [A.VALdecl(map (fn (v,e) => A.VALbind(A.IDpat v,e)) bindings )]
317 : leunga 744 fun genOk(e) = e
318 :     fun pathToPat(path) = A.IDpat(getName path)
319 :     fun arg NONE = A.WILDpat
320 :     | arg (SOME p) = A.IDpat(getName p)
321 :     fun fromRep(CONREP(path,A.CONSbind{id, ...},_)) = A.IDENT(path,id)
322 : leunga 775 | fromRep(EXN(path,id,_)) = A.IDENT(path,id)
323 : leunga 744 fun genConPat(MC.CON con, []) = A.CONSpat(fromRep con,NONE)
324 :     | genConPat(MC.CON con, paths) =
325 :     A.CONSpat(fromRep con, SOME(A.TUPLEpat(map arg paths)))
326 : leunga 775 | genConPat(MC.LIT(A.REALlit _), _) = raise GenReal
327 :     | genConPat(MC.LIT(A.INTINFlit _), _) = raise GenIntInf
328 : leunga 744 | genConPat(MC.LIT lit, _) = A.LITpat lit
329 :     fun genCase(v, cases, default) =
330 :     A.CASEexp(ID v,
331 :     map (fn (con, paths, e) =>
332 :     A.CLAUSE([genConPat(con, paths)],NONE,e)) cases @
333 :     (case default of
334 :     NONE => []
335 :     | SOME default => [A.CLAUSE([A.WILDpat], NONE, default)]
336 :     )
337 :     )
338 : george 909 handle GenReal => genLitCmp(makeRealEq,v,cases, default)
339 :     | GenIntInf => genLitCmp(makeIntInfEq, v,cases,default)
340 : leunga 775 and genLitCmp(eq, v, cases, SOME default) =
341 :     let val x = ID v
342 : george 909 fun equal lit = eq(x, genLit lit)
343 : leunga 775 in List.foldr(fn ((MC.LIT lit, _, e),rest) =>
344 :     A.IFexp(equal lit,e,rest)) default cases
345 :     end
346 :     fun genIf((_,e), y, n) = A.IFexp(e, y, n)
347 : leunga 744 fun genGoto(f, args) = A.APPexp(ID(STATE f), A.TUPLEexp(map ID args))
348 :     fun genFun(f, args, body) =
349 :     A.FUNdecl[A.FUNbind(STATE f,
350 :     [A.CLAUSE([A.TUPLEpat(map A.IDpat args)],NONE,body)])
351 :     ]
352 :     fun genLet([], e) = e
353 :     | genLet(d, e) = A.LETexp(d,[e])
354 :     fun genVal(v, e) = A.VALdecl[A.VALbind(A.IDpat v, e)]
355 :     fun genProj(path, bindings) =
356 :     let val pat = case bindings of
357 :     [] => A.WILDpat
358 :     | (p, MC.INT _)::ps =>
359 :     A.TUPLEpat(map (fn (p,_) => arg p) bindings)
360 :     | (p, MC.LABEL _)::ps =>
361 :     A.RECORDpat(map (fn (p,MC.LABEL l) =>
362 :     (l, arg p)) bindings, true)
363 :     in A.VALdecl[A.VALbind(pat,ID(getName path))]
364 :     end
365 : leunga 775
366 :     fun genCont(k, f, vars) =
367 :     A.FUNdecl[A.FUNbind(k,[A.CLAUSE([A.TUPLEpat []], NONE,
368 :     A.APPexp(ID(STATE f),
369 :     A.TUPLEexp(map ID vars)))])]
370 :    
371 : leunga 744 in MC.codeGen
372 :     {genFail = genFail,
373 :     genOk = genOk,
374 : leunga 775 genPath = genPath,
375 : leunga 744 genBind = genBind,
376 :     genCase = genCase,
377 :     genIf = genIf,
378 :     genGoto = genGoto,
379 : leunga 775 genCont = genCont,
380 : leunga 744 genFun = genFun,
381 :     genLet = genLet,
382 :     genVar = genVar,
383 :     genVal = genVal,
384 :     genProj = genProj
385 :     } (root, dfa)
386 :     end
387 :    
388 : leunga 775 fun complexPat p =
389 :     let val complex = ref false
390 :     fun pat _ (p as A.WHEREpat _) = (complex := true; p)
391 :     | pat _ (p as A.NESTEDpat _) = (complex := true; p)
392 :     | pat _ (p as A.ANDpat _) = (complex := true; p)
393 :     | pat _ (p as A.NOTpat _) = (complex := true; p)
394 :     | pat _ (p as A.ORpat _) = (complex := true; p)
395 :     | pat _ (p as A.LITpat(A.REALlit _)) = (complex := true; p)
396 :     | pat _ (p as A.LITpat(A.INTINFlit _)) = (complex := true; p)
397 :     | pat _ p = p
398 :     val _ = #pat(rw{exp=NO,ty=NO,pat=pat,decl=NO,sexp=NO}) p
399 :     in !complex end
400 :    
401 :     (* Are clauses conditional *)
402 :     val isComplex =
403 :     List.exists (fn A.CLAUSE(p,g,_) => isSome g orelse
404 :     List.exists complexPat p)
405 : leunga 744 end

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