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

SCM Repository

[diderot] Annotation of /trunk/src/compiler/gen/opt/dump-dfa.sml
ViewVC logotype

Annotation of /trunk/src/compiler/gen/opt/dump-dfa.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1484 - (view) (download)

1 : jhr 1484 (* dump-dfa.sml
2 :     *
3 :     * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     * All rights reserved.
5 :     *
6 :     * Routines to print out the internal data structures in the pattern-match
7 :     * compiler.
8 :     *)
9 :    
10 :     structure DumpDFA =
11 :     struct
12 :    
13 :     local
14 :     structure CM = CompileMatch
15 :     structure CS = CheckSpec
16 :     structure Q = Queue
17 :     structure F = Format
18 :     fun path2str (CM.PATH l) =
19 :     concat ("root"
20 :     :: (List.foldr (fn(i, l) => "$"::Int.toString i::l) [] l))
21 :     structure PP = TextIOPP
22 :    
23 :     datatype 'a stateQ = SQ of {q : 'a CM.state Q.queue, marked : word list ref}
24 :     fun mkQueue s0 = let
25 :     val q = Q.mkQueue()
26 :     in
27 :     Q.enqueue(q, s0);
28 :     SQ{q = q, marked = ref []}
29 :     end
30 :     fun insert (SQ{q, ...}, s) = Q.enqueue(q, s)
31 :     fun getState (sq as SQ{q, marked}) =
32 :     if Q.isEmpty q
33 :     then NONE
34 :     else let
35 :     val s = Q.dequeue q
36 :     val id = CM.stamp s
37 :     in
38 :     if (List.exists (fn id' => (id = id')) (!marked))
39 :     then getState sq
40 :     else (
41 :     marked := id :: !marked;
42 :     SOME s)
43 :     end
44 :     in
45 :    
46 :     fun ppDFA ppRHS (ppStrm, q0 : 'a CM.state) = let
47 :     val stateQ = mkQueue q0
48 :     val str = PP.string ppStrm
49 :     val tok = PP.token ppStrm
50 :     val sp = PP.space ppStrm
51 :     fun ppStateId s = str("state"^Word.toString(CM.stamp s))
52 :     fun ppArgs [] = ()
53 :     | ppArgs [p] = str (path2str p)
54 :     | ppArgs (p::r) = (str (path2str p); str ","; sp 1; ppArgs r)
55 :     fun ppArc (pat, q) = (
56 :     PP.newline ppStrm;
57 :     PP.openHBox ppStrm;
58 :     case pat
59 :     of CM.ANY => str "_"
60 :     | CM.DECONS(con, []) => str(CS.opToString con)
61 :     | CM.DECONS(con, args) => (
62 :     str(CS.opToString con); str "(";
63 :     ppArgs args;
64 :     str ")")
65 :     (* end case *);
66 :     sp 1; str "=>"; sp 1;
67 :     ppNextState q;
68 :     PP.closeBox ppStrm)
69 :     and ppNextState q =
70 :     if ((CM.refCnt q) > 1)
71 :     then (str "goto"; sp 1; ppStateId q; insert(stateQ, q))
72 :     else ppState(false, q)
73 :     and ppState (doLabel, q) = (
74 :     PP.openHBox ppStrm;
75 :     if doLabel
76 :     then (
77 :     ppStateId q; str "["; str(Int.toString(CM.refCnt q)); str "]";
78 :     str ":"; sp 1)
79 :     else ();
80 :     case (CM.kind q)
81 :     of CM.SWITCH(v, arcs) => (
82 :     str "switch"; sp 1; str(path2str v);
83 :     PP.openVBox ppStrm (PP.Abs 2);
84 :     app ppArc arcs;
85 :     PP.closeBox ppStrm)
86 :     | CM.FINAL(vMap, e) => let
87 :     fun pVar (x, path) = (
88 :     str(path2str path); str "/"; str(CS.varToString x))
89 :     fun pVar' vp = (str ","; sp 1; pVar vp)
90 :     in
91 :     str "execute"; sp 1;
92 :     PP.openHBox ppStrm;
93 :     ppRHS(ppStrm, e);
94 :     case CheckSpec.VMap.listItemsi vMap
95 :     of [] => ()
96 :     | (item::r) => (
97 :     sp 1;
98 :     str "[";
99 :     pVar item;
100 :     List.app pVar' r;
101 :     str "]")
102 :     (* end case *);
103 :     PP.closeBox ppStrm
104 :     end
105 :     | CM.ERROR => str "error"
106 :     (* end case *);
107 :     PP.closeBox ppStrm)
108 :     fun ppStates () = (case getState stateQ
109 :     of NONE => ()
110 :     | (SOME s) => (ppState(true, s); PP.newline ppStrm; ppStates())
111 :     (* end case *))
112 :     in
113 :     PP.openVBox ppStrm (PP.Abs 0);
114 :     ppStates ();
115 :     PP.closeBox ppStrm
116 :     end
117 :    
118 :     end (* local *)
119 :    
120 :     end;
121 :    

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