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/benchmarks/todo/barnes-but/dump.sml
ViewVC logotype

Annotation of /sml/trunk/benchmarks/todo/barnes-but/dump.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 193 - (view) (download)

1 : monnier 193 (* dump.sml
2 :     *
3 :     * COPYRIGHT (c) 1993, AT&T Bell Laboratories.
4 :     *
5 :     * Code to dump out the tree as a ``dot'' specification.
6 :     *)
7 :    
8 :     functor Dump (V : VECTOR) =
9 :     struct
10 :     structure M = Main(V)
11 :     structure S = M.S
12 :     structure V = M.V
13 :    
14 :     fun assignProcs (root, nbodies, nprocs) = let
15 :     val bodiesPerProc = nbodies quot nprocs
16 :     fun assignBody (S.Body{proc, ...}, cnt) = (
17 :     proc := (cnt quot bodiesPerProc);
18 :     cnt+1)
19 :     fun assignNode (S.Empty, cnt) = cnt
20 :     | assignNode (S.Node{cell = S.BodyCell b, ...}, cnt) =
21 :     assignBody (b, cnt)
22 :     | assignNode (S.Node{proc, cell = S.Cell a, ...}, cnt) = let
23 :     fun assign1 i = (case Array.sub(a, i)
24 :     of S.Empty => assign1 (i+1)
25 :     | (nd as S.Node{proc=p, ...}) => let
26 :     val cnt' = assignNode (nd, cnt)
27 :     in
28 :     proc := !p;
29 :     assign (i+1, cnt')
30 :     end
31 :     (* end case *))
32 :     and assign (i, cnt) = if (i < S.nsub)
33 :     then assign (i+1, assignNode(Array.sub(a, i), cnt))
34 :     else cnt
35 :     in
36 :     assign1 0
37 :     end
38 :     in
39 :     assignNode (root, 0)
40 :     end
41 :    
42 :     fun assignProcs' (root, nbodies, nprocs) = let
43 :     val bodiesPerProc = nbodies quot nprocs
44 :     fun assignBody (S.Body{proc, ...}, p) = proc := p
45 :     fun assignNode (S.Empty, cnt, level, proc) = cnt
46 :     | assignNode (S.Node{cell = S.BodyCell b, ...}, cnt, 0, p) = (
47 :     assignBody (b, p); cnt+1)
48 :     | assignNode (S.Node{cell = S.BodyCell b, ...}, cnt, _, _) = (
49 :     assignBody (b, cnt quot bodiesPerProc); cnt+1)
50 :     | assignNode (S.Node{proc, cell = S.Cell a, ...}, cnt, level, p) = let
51 :     val p' = if (level <> 1) then p else (cnt quot bodiesPerProc)
52 :     val level = max(0, level-1)
53 :     fun assign1 i = (case Array.sub(a, i)
54 :     of S.Empty => assign1 (i+1)
55 :     | nd => let
56 :     val cnt' = assignNode (nd, cnt, level, p')
57 :     in
58 :     proc := p;
59 :     assign (i+1, cnt')
60 :     end
61 :     (* end case *))
62 :     and assign (i, cnt) = if (i < S.nsub)
63 :     then assign (i+1, assignNode(Array.sub(a, i), cnt, level, p'))
64 :     else cnt
65 :     in
66 :     assign1 0
67 :     end
68 :     in
69 :     assignNode (root, 0, 4, 0)
70 :     end
71 :    
72 :     val ctable = #[
73 :     "yellow", "blue", "green", "red",
74 :     "lightgrey", "yellowgreen", "navyblue", "coral"
75 :     ]
76 :    
77 :     fun dumpTree (fname, root, bodies, colorNodes) = let
78 :     val strm = IO.open_out fname
79 :     fun print (fmt, items) = IO.output (strm, Format.format fmt items)
80 :     (**
81 :     fun indent i = Format.LEFT(i+i, Format.STR "")
82 :     **)
83 :     fun indent i = Format.STR "" (* because of a bug in Format *)
84 :     fun color (i, id, proc) =
85 :     print ("%s nd%d [style=filled, color=%s];\n", [
86 :     indent i, Format.INT id, Format.STR(Vector.sub(ctable, proc))
87 :     ])
88 :     val color = if colorNodes then color else (fn _ => ())
89 :     fun bodyName b = let
90 :     fun find ([], _) = raise Fail "bodyNd"
91 :     | find (b'::r, i) = if (b = b') then i else find(r, i+1)
92 :     in
93 :     find (bodies, 0)
94 :     end
95 :     fun bodyNd (i, id, b) =
96 :     print ("%s nd%d [label=\"%d\", shape=ellipse, height=0.2, width=0.3];\n", [
97 :     indent i, Format.INT id, Format.INT(bodyName b)
98 :     ])
99 :     fun cellNd (i, id) =
100 :     print ("%s nd%d [label=\"\", shape=box, height=0.1, width=0.4];\n", [
101 :     indent i, Format.INT id
102 :     ])
103 :     fun edge (i, fromId, toId) = print ("%s nd%d -> nd%d;\n", [
104 :     indent i, Format.INT fromId, Format.INT toId
105 :     ])
106 :     val levels = Array.array(32, [] : int list)
107 :     fun addNd (lvl, id) =
108 :     Array.update(levels, lvl, id :: Array.sub(levels, lvl))
109 :     fun prLevels () = let
110 :     fun loop i = (case Array.sub(levels, i)
111 :     of [] => ()
112 :     | l => (
113 :     print (" { rank = same;", []);
114 :     app (fn id => print(" nd%d;", [Format.INT id])) l;
115 :     print ("};\n", []);
116 :     loop (i+1))
117 :     (* end case *))
118 :     in
119 :     loop 0
120 :     end
121 :     fun walk (_, _, S.Empty, nextId) = nextId
122 :     | walk (lvl, parentId, S.Node{proc, cell, ...}, nextId) = (
123 :     addNd (lvl, nextId);
124 :     edge (lvl, parentId, nextId);
125 :     case cell
126 :     of (S.BodyCell b) => (
127 :     bodyNd(lvl+1, nextId, b);
128 :     color (lvl+1, nextId, !proc);
129 :     nextId+1)
130 :     | (S.Cell a) => (
131 :     cellNd(lvl+1, nextId);
132 :     color (lvl+1, nextId, !proc);
133 :     walkCell(lvl+1, a, nextId))
134 :     (* end case *))
135 :     and walkCell (lvl, a, parentId) = let
136 :     fun lp (i, nextId') = if (i < S.nsub)
137 :     then lp (i+1, walk (lvl, parentId, Array.sub(a, i), nextId'))
138 :     else nextId'
139 :     in
140 :     lp (0, parentId+1)
141 :     end
142 :     in
143 :     print ("digraph tree {\n", []);
144 :     print (" orientation = land;\n", []);
145 :     print (" size = \"10,7\";\n", []);
146 :     print (" ordering = out;\n", []);
147 :     print (" fontsize = 8\n", []);
148 :     print (" ranksep = 2\n", []);
149 :     case root
150 :     of S.Empty => ()
151 :     | (S.Node{proc, cell=S.BodyCell b, ...}) => (
152 :     addNd (0, 0); bodyNd(0, 0, b); color (0, 0, !proc); ())
153 :     | (S.Node{proc, cell=S.Cell a, ...}) => (
154 :     addNd (0, 0); cellNd (0, 0); color (0, 0, !proc);
155 :     walkCell(1, a, 0); ())
156 :     (* end case *);
157 :     prLevels ();
158 :     print ("}\n", []);
159 :     IO.close_out strm
160 :     end
161 :    
162 :     fun dumpTest mkData {fname, nbodies, nprocs} = let
163 :     val _ = M.srand 123
164 :     val data = mkData nbodies
165 :     val S.Space{root, ...} =
166 :     M.L.makeTree (data, V.tabulate (fn _ => ~2.0), 4.0);
167 :     in
168 :     if (nprocs <= 1)
169 :     then dumpTree (fname, root, data, false)
170 :     else (
171 :     assignProcs' (root, nbodies, nprocs);
172 :     dumpTree (fname, root, data, true))
173 :     end
174 :    
175 :     end;
176 :    

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