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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3349 - (view) (download)

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

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