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 3349 - (view) (download)

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

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