Home My Page Projects Code Snippets Project Openings diderot
Summary Activity Tracker Tasks SCM

SCM Repository

[diderot] Annotation of /trunk/src/compiler/gen/opt/match.sml
ViewVC logotype

Annotation of /trunk/src/compiler/gen/opt/match.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1484 - (view) (download)

1 : jhr 1484 (* match.sml
2 :     *
3 :     * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     * All rights reserved.
5 :     *)
6 :    
7 :     structure CompileMatch : sig
8 :    
9 :     type 'a state
10 :    
11 :     datatype path = PATH of int list
12 :    
13 :     datatype 'a state_kind
14 :     = SWITCH of (path * (simple_pat * 'a state) list)
15 :     | FINAL of (path CheckSpec.VMap.map * 'a)
16 :     | ERROR
17 :     (*Deleted test and when conditions*)
18 :    
19 :     and simple_pat
20 :     = ANY
21 :     | DECONS of (CheckSpec.oper * path list)
22 :     (*interface*)
23 :     val same : ('a state * 'a state) -> bool
24 :     val kind : 'a state -> 'a state_kind
25 :     val stamp : 'a state -> word
26 :     val refCnt : 'a state -> int
27 :     val holder : 'a state -> PropList.holder
28 :     (*deleted ML.raw_ml option*)
29 :    
30 :     val compile : (CheckSpec.pattern * 'a) list -> 'a state
31 :    
32 :     structure PSet : ORD_SET where type Key.ord_key = path
33 :     structure PMap : ORD_MAP where type Key.ord_key = path
34 :    
35 :     end = struct
36 :    
37 :     (* original.
38 :     structure SP = SpecParser
39 :     structure CS = CheckSpec
40 :     structure S = Sorts
41 :     structure Op = PrimOps
42 :     structure VMap = CS.VMap
43 :     *)
44 :     structure CS = CheckSpec (* rewrite rules*)
45 :     structure VMap = CS.VMap
46 :    
47 :     (******************** Op and constants ********************)
48 :    
49 :     datatype con = OP of CS.oper (*| LIT of IntInf.int*)
50 :    
51 :     fun sameCon (OP c1, OP c2) = CS.sameOp(c1, c2)
52 :     (*
53 :     | sameCon (LIT n1, LIT n2) = (n1 = n2)
54 :     | sameCon _ = raise Fail "mixed operator/literal"
55 :     *)
56 :    
57 :     structure ConSet = RedBlackSetFn (
58 :     struct
59 :     type ord_key = con
60 :     fun compare (OP c1, OP c2) = CS.compareOp(c1, c2)
61 :     (*
62 :     | compare (LIT n1, LIT n2) = IntInf.compare(n1, n2)
63 :     | compare _ = raise Fail "mixed operator/literal"
64 :     *)
65 :     end)
66 :    
67 :    
68 :     (******************** Paths and renamed patterns ********************)
69 :    
70 :     datatype path = PATH of int list
71 :    
72 :     fun extendPath (PATH l, i) = PATH(l @ [i])
73 :    
74 :     (* source patterns after variable renaming and operator lookup *)
75 :     datatype pat
76 :     = P_Wild
77 :     | P_ConApp of (CS.oper * (path * pat) list)
78 :     (*
79 :     | P_IConst of IntInf.int
80 :     *)
81 :    
82 :     (******************** DFA States ********************)
83 :    
84 :     type stamp = Word.word
85 :    
86 :     datatype 'a state = S of {
87 :     refCnt : int ref,
88 :     id : stamp,
89 :     holder : PropList.holder,
90 :     kind : 'a state_kind
91 :     }
92 :    
93 :     and 'a state_kind
94 :     = SWITCH of (path * (simple_pat * 'a state) list)
95 :     | FINAL of (path CS.VMap.map * 'a)
96 :     | ERROR
97 :    
98 :     and simple_pat
99 :     = ANY
100 :     | DECONS of (CS.oper * path list)
101 :    
102 :     local
103 :     val idCnt = ref 0w0
104 :     in
105 :     fun mkState kind = let
106 :     val id = !idCnt
107 :     in
108 :     idCnt := id+0w1;
109 :     S{refCnt=ref 0, id=id, holder = PropList.newHolder(), kind=kind}
110 :     end
111 :     fun initState () = (idCnt := 0w0; mkState ERROR)
112 :     end
113 :    
114 :     (* construct a final state *)
115 :     fun finalState (vMap, exp) = mkState (FINAL(vMap, exp))
116 :    
117 :     (* construct a test state *)
118 :     fun switchState (testVar, arcs) = mkState (SWITCH(testVar, arcs))
119 :    
120 :     (* increment a state's reference count *)
121 :     fun inc (S{refCnt, ...}) = refCnt := !refCnt+1
122 :    
123 :     (* exported accessor functions on states *)
124 :     fun same (S{refCnt=r1, ...}, S{refCnt=r2, ...}) = (r1 = r2)
125 :     fun kind (S{kind, ...}) = kind
126 :     fun stamp (S{id, ...}) = id
127 :     fun refCnt (S{refCnt, ...}) = !refCnt
128 :     fun holder (S{holder, ...}) = holder
129 :    
130 :    
131 :     (******************** Pattern matrix ********************)
132 :     datatype cell
133 :     = NIL
134 :     | CELL of {
135 :     pat : pat,
136 :     right : cell,
137 :     down : cell
138 :     }
139 :    
140 :     type 'a matrix = {
141 :     rows : (cell * 'a state) list,
142 :     (* cells of the first column with the *)
143 :     (* optional "when" clause and the *)
144 :     (* corresponding final state *)
145 :     cols : cell list, (* cells of the top row *)
146 :     vars : path list (* variables being tested (one per *)
147 :     (* column *)
148 :     }
149 :    
150 :     fun mkNilMat vars = {rows = [], cols = List.map (fn _ => NIL) vars, vars = vars}
151 :    
152 :     fun rowToList NIL = []
153 :     | rowToList (cell as CELL{right, ...}) = cell :: rowToList right
154 :    
155 :     (* create a pattern matrix from a list of rows. *)
156 :     fun mkMatrix (match as ((row1, _)::_)) = let
157 :     val vars = map #1 row1
158 :     fun mkRows [] = (List.map (fn _ => NIL) vars, [])
159 :     | mkRows ((row, q)::rows) = let
160 :     fun doCols ([], []) = NIL
161 :     | doCols ((_, pat)::r, cell::right) = CELL{
162 :     pat = pat, right = doCols (r, right), down = cell
163 :     }
164 :     val (topRow, rows) = mkRows rows
165 :     val newRow = doCols (row, topRow)
166 :     in
167 :     (rowToList newRow, (newRow, q)::rows)
168 :     end
169 :     val (topRow, rows) = mkRows match
170 :     in
171 :     { rows = rows, cols = topRow, vars = vars }
172 :     end
173 :    
174 :     (* choose a column of a matrix for splitting; currently we choose the column
175 :     * with a constructor in its first row and the largest number of distinct
176 :     * constructors. If all the columns start with a variable, return NONE.
177 :     *)
178 :     fun chooseCol ({rows, cols, vars} : 'a matrix) = let
179 :     fun count (NIL, cons) = ConSet.numItems cons
180 :     | count (CELL{pat, down, ...}, cons) = let
181 :     val cons = (case pat
182 :     of (P_ConApp(c, _)) => ConSet.add(cons, OP c)
183 :     (*
184 :     | (P_IConst n) => ConSet.add(cons, LIT n)
185 :     *)
186 :     | P_Wild => cons
187 :     (* end case *))
188 :     in
189 :     count (down, cons)
190 :     end
191 :     fun maxRow (curMax, curCnt, _, []) = curMax
192 :     | maxRow (curMax, curCnt, i, CELL{pat=P_Wild, ...}::cols) =
193 :     maxRow (curMax, curCnt, i+1, cols)
194 :     | maxRow (curMax, curCnt, i, col::cols) = let
195 :     val cnt = count(col, ConSet.empty)
196 :     in
197 :     if (cnt > curCnt)
198 :     then maxRow (SOME i, cnt, i+1, cols)
199 :     else maxRow (curMax, curCnt, i+1, cols)
200 :     end
201 :     in
202 :     maxRow (NONE, 0, 0, cols)
203 :     end
204 :    
205 :     (* add a row to the top of a matrix *)
206 :     fun addRow ({rows, cols, vars}, (row, q)) = let
207 :     fun cons (NIL, []) = (NIL, [])
208 :     | cons (CELL{pat, right = r1, ...}, dn::r2) = let
209 :     val (right, cols) = cons(r1, r2)
210 :     val cell = CELL{pat = pat, right = right, down = dn}
211 :     in
212 :     (cell, cell::cols)
213 :     end
214 :     val (row, cols) = cons (row, cols)
215 :     in
216 :     { rows = (row, q) :: rows, cols = cols, vars = vars }
217 :     end
218 :    
219 :     (* replace the ith variable with newVars *)
220 :     fun expandVars (vars, i, newVars) = let
221 :     fun ins (0, _::r) = newVars @ r
222 :     | ins (i, v::r) = v :: ins(i-1, r)
223 :     in
224 :     ins (i, vars)
225 :     end
226 :    
227 :     (* replace the ith cell of a row with the expansion of args *)
228 :     fun expandCols ((row, q), i, args) = let
229 :     fun ins (0, CELL{right, ...}) = let
230 :     fun cons [] = right
231 :     | cons ((_, pat)::r) = CELL{
232 :     pat = pat, down = NIL, right = cons r
233 :     }
234 :     in
235 :     cons args
236 :     end
237 :     | ins (i, CELL{pat, right, ...}) = CELL{
238 :     pat = pat, down = NIL, right = ins (i-1, right)
239 :     }
240 :     in
241 :     (ins (i, row), q)
242 :     end
243 :    
244 :     (* Constructor map *)
245 :     type 'a cons_info = {
246 :     con : con,
247 :     args : path list,
248 :     mat : 'a matrix ref
249 :     }
250 :    
251 :    
252 :     (* split a pattern matrix based on the constructors of the given column.
253 :     * For each constructor in the selected column, we construct a new pattern
254 :     * matrix that contains a row for each row that matches the constructor.
255 :     * This new matrix includes any rows where there is a variable in the selected
256 :     * column.
257 :     * Note that it is important that the order of constructors be preserved
258 :     * and that the order of rows that have the same constructor also be preserved.
259 :     *)
260 :     fun splitAtCol (mat : 'a matrix, i) = let
261 :     val vars = #vars mat
262 :     (* find the entry for a constructor in the conMap *)
263 :     fun findCon (conMap : 'a cons_info list, c) = let
264 :     fun find [] = NONE
265 :     | find ({con, mat, args}::r) = if sameCon(c, con)
266 :     then SOME mat
267 :     else find r
268 :     in
269 :     find conMap
270 :     end
271 :     (* create the initial conMap (one entry per constructor in the
272 :     * column).
273 :     *)
274 :     fun mkConMap NIL = []
275 :     | mkConMap (CELL{down, pat, ...}) = let
276 :     val conMap = mkConMap down
277 :     in
278 :     case pat
279 :     of P_Wild => conMap
280 :     | (P_ConApp(c, args)) => (case findCon(conMap, OP c)
281 :     of NONE => let
282 :     val argVars = map #1 args
283 :     val vars = expandVars(vars, i, argVars)
284 :     val mat = mkNilMat vars
285 :     in
286 :     {con = OP c, args = argVars, mat = ref mat} :: conMap
287 :     end
288 :     | (SOME _) => conMap
289 :     (* end case *))
290 :     (*
291 :     | (P_IConst n) => (case findCon(conMap, LIT n)
292 :     of NONE => let
293 :     val vars = expandVars(vars, i, [])
294 :     val mat = mkNilMat vars
295 :     in
296 :     {con = LIT n, args = [], mat = ref mat} :: conMap
297 :     end
298 :     | (SOME _) => conMap
299 :     (* end case *))
300 :     *)
301 :     (* end case *)
302 :     end
303 :     val splitCol = List.nth(#cols mat, i)
304 :     val conMap = mkConMap splitCol
305 :     (* populate the conMap and build the varMap *)
306 :     fun f ([], _) = mkNilMat vars
307 :     | f (row::rows, CELL{pat, right, down}) = let
308 :     val varMat = f (rows, down)
309 :     in
310 :     case pat
311 :     of P_Wild => let
312 :     fun addVarRow {con, args, mat} =
313 :     mat := addRow(!mat,
314 :     expandCols(row, i,
315 :     map (fn v => (v, P_Wild)) args))
316 :     in
317 :     (* we add the row to all of the sub-matrices *)
318 :     app addVarRow conMap;
319 :     addRow(varMat, row)
320 :     end
321 :     (*
322 :     | (P_IConst n) => let
323 :     val (SOME mat) = findCon (conMap, LIT n)
324 :     in
325 :     mat := addRow(!mat, expandCols(row, i, []));
326 :     varMat
327 :     end
328 :     *)
329 :     | (P_ConApp(c, args)) => let
330 :     val (SOME mat) = findCon (conMap, OP c)
331 :     in
332 :     mat := addRow(!mat, expandCols(row, i, args));
333 :     varMat
334 :     end
335 :     (* end case *)
336 :     end
337 :     val varMat = f (#rows mat, splitCol)
338 :     in
339 :     (List.nth(vars, i), conMap, varMat)
340 :     end
341 :    
342 :     (******************** Translation ********************)
343 :    
344 :     (* NOTE: eventually, we can merge this function with mkMatrix *)
345 :     fun step1 rules = let
346 :     val errState = initState()
347 :     val rootPaths = [PATH[]]
348 :     fun arityMismatch rator =
349 :     raise Fail(CS.opToString rator ^ " arity mismatch in pattern")
350 :     (* convert a pattern to a list of patterns *)
351 :     fun doPat (path, CS.IdPat x, vmap) =
352 :     (path, P_Wild, VMap.insert(vmap, x, path))
353 :     (*
354 :     | doPat (sort, path, CS.P_VarAsPat(x, p), vmap) =
355 :     doPat (sort, path, p, VMap.insert(vmap, x, path))
356 :     *)
357 :     | doPat (path, CS.WildPat, vmap) = (path, P_Wild, vmap)
358 :     (*
359 :     | doPat (sort, path, CS.P_IConst n, vmap) = (path, P_IConst n, vmap)
360 :     *)
361 :     | doPat (path, CS.OpPat(rator, args), vmap) = let
362 :     fun extendPaths (_, []) = []
363 :     | extendPaths (i, _::r) =
364 :     extendPath(path, i) :: extendPaths(i+1, r)
365 :     val (args, vmap) = doPatList(extendPaths(0, args), args, vmap)
366 :     in
367 :     (path, P_ConApp(rator, args), vmap)
368 :     end
369 :     and doPatList ([], [], vmap) = ([], vmap)
370 :     | doPatList (path::r2, pat::r3, vmap) = let
371 :     val (path, pat, vmap) = doPat (path, pat, vmap)
372 :     val (rest, vmap) = doPatList (r2, r3, vmap)
373 :     in
374 :     ((path, pat)::rest, vmap)
375 :     end
376 :     | doPatList _ = raise Fail "arity" (* should never happen *)
377 :     fun doRules [] = []
378 :     | doRules ((pats, exp) :: rest) = let
379 :     val (row, vmap) = doPatList (rootPaths, pats, VMap.empty)
380 :     in
381 :     (row, finalState(vmap, exp)) :: doRules rest
382 :     end
383 :     in
384 :     (doRules rules, errState)
385 :     end
386 :    
387 :     fun step2 (patMatrix : 'a matrix, errState) = let
388 :     fun genDFA (mat as {rows as (row1, q1)::rrows, cols, vars}) = (
389 :     (*DEBUG print(concat["genDFA: ", Int.toString(length rows), " rows, ", *)
390 :     (*DEBUG Int.toString(length cols), " cols\n"]); *)
391 :     case (chooseCol mat)
392 :     of NONE => (inc q1; q1)
393 :     | SOME i => let
394 :     val (splitVar, conMap, varMat) = splitAtCol(mat, i)
395 :     (*DEBUG val _ = print(concat[" split at column ", Int.toString i, "\n"]);*)
396 :     val lastArc = (case varMat
397 :     of {rows=[], ...} => let
398 :     fun mkCell (_, (right, cols)) = let
399 :     val cell = CELL{
400 :     pat = P_Wild, down = NIL,
401 :     right = right
402 :     }
403 :     in
404 :     (cell, cell::cols)
405 :     end
406 :     val (row, cols) = List.foldr mkCell (NIL, []) vars
407 :     val mat = {
408 :     rows=[(row, errState)],
409 :     cols=cols, vars=vars
410 :     }
411 :     in
412 :     (ANY, genDFA mat)
413 :     end
414 :     | mat => (ANY, genDFA mat)
415 :     (* end case *))
416 :     fun mkSwitchArc ({con=OP rator, args, mat}, arcs) =
417 :     (DECONS(rator, args), genDFA(!mat)) :: arcs
418 :     (*
419 :     fun mkTestArc ({con=LIT n, args=[], mat}) = (n, genDFA(!mat))
420 :     *)
421 :     val q = (case conMap
422 :     of [] => switchState(splitVar, [lastArc])
423 :     | ({con=OP _, ...}::_) =>
424 :     switchState (
425 :     splitVar,
426 :     List.foldr mkSwitchArc [lastArc] conMap)
427 :     (*
428 :     | ({con=LIT _, ...}::_) =>
429 :     testState (
430 :     splitVar,
431 :     List.map mkTestArc conMap,
432 :     #2 lastArc)
433 :     *)
434 :     (* end case *))
435 :     in
436 :     inc q; q
437 :     end
438 :     (* end case *))
439 :     in
440 :     genDFA (patMatrix)
441 :     end
442 :    
443 :     (*
444 :     (* In step3 we minimize the DFA by combining identical states *)
445 :     fun step3 (q0 : state) = let
446 :     in
447 :     end
448 :     *)
449 :    
450 :     fun compile match = let
451 :     val match = map (fn (p, e') => ([p], e')) match
452 :     val (rules, errState) = step1 match
453 :     val patMatrix = mkMatrix rules
454 :     val finalStates = map #2 (#rows patMatrix)
455 :     val dfa = step2(patMatrix, errState)
456 :     (*
457 :     val dfa = step3 dfa
458 :     *)
459 :     in
460 :     (* NOTE: final states with zero reference counts are redundant and
461 :     * a non-zero count on the error state means that the match is
462 :     * nonexhaustive.
463 :     *)
464 :     dfa
465 :     end
466 :    
467 :     (* sets and maps of paths *)
468 :     structure K = struct
469 :     type ord_key = path
470 :     fun compare (PATH l1, PATH l2) = let
471 :     fun cmp ([], []) = EQUAL
472 :     | cmp (_, []) = GREATER
473 :     | cmp ([], _) = LESS
474 :     | cmp (i1::r1, i2::r2) = (case Int.compare(i1, i2)
475 :     of EQUAL => cmp(r1, r2)
476 :     | order => order
477 :     (* end case *))
478 :     in
479 :     cmp (l1, l2)
480 :     end
481 :     end
482 :     structure PSet = RedBlackSetFn(K)
483 :     structure PMap = RedBlackMapFn(K)
484 :    
485 :     end

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