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) = 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 :     fun bodyName b = let
89 :     fun find ([], _) = raise Fail "bodyNd"
90 :     | find (b'::r, i) = if (b = b') then i else find(r, i+1)
91 :     in
92 :     find (bodies, 0)
93 :     end
94 :     fun bodyNd (i, id, b) =
95 :     print ("%s nd%d [label=\"%d\", shape=ellipse, height=0.2, width=0.3];\n", [
96 :     indent i, Format.INT id, Format.INT(bodyName b)
97 :     ])
98 :     fun cellNd (i, id) =
99 :     print ("%s nd%d [label=\"\", shape=box, height=0.1, width=0.4];\n", [
100 :     indent i, Format.INT id
101 :     ])
102 :     fun edge (i, fromId, toId) = print ("%s nd%d -> nd%d;\n", [
103 :     indent i, Format.INT fromId, Format.INT toId
104 :     ])
105 :     val levels = Array.array(32, [] : int list)
106 :     fun addNd (lvl, id) =
107 :     Array.update(levels, lvl, id :: Array.sub(levels, lvl))
108 :     fun prLevels () = let
109 :     fun loop i = (case Array.sub(levels, i)
110 :     of [] => ()
111 :     | l => (
112 :     print (" { rank = same;", []);
113 :     app (fn id => print(" nd%d;", [Format.INT id])) l;
114 :     print ("};\n", []);
115 :     loop (i+1))
116 :     (* end case *))
117 :     in
118 :     loop 0
119 :     end
120 :     fun walk (_, _, S.Empty, nextId) = nextId
121 :     | walk (lvl, parentId, S.Node{proc, cell, ...}, nextId) = (
122 :     addNd (lvl, nextId);
123 :     edge (lvl, parentId, nextId);
124 :     case cell
125 :     of (S.BodyCell b) => (
126 :     bodyNd(lvl+1, nextId, b);
127 :     color (lvl+1, nextId, !proc);
128 :     nextId+1)
129 :     | (S.Cell a) => (
130 :     cellNd(lvl+1, nextId);
131 :     color (lvl+1, nextId, !proc);
132 :     walkCell(lvl+1, a, nextId))
133 :     (* end case *))
134 :     and walkCell (lvl, a, parentId) = let
135 :     fun lp (i, nextId') = if (i < S.nsub)
136 :     then lp (i+1, walk (lvl, parentId, Array.sub(a, i), nextId'))
137 :     else nextId'
138 :     in
139 :     lp (0, parentId+1)
140 :     end
141 :     in
142 :     print ("digraph tree {\n", []);
143 :     print (" orientation = land;\n", []);
144 :     print (" size = \"10,7\";\n", []);
145 :     print (" ordering = out;\n", []);
146 :     print (" fontsize = 8\n", []);
147 :     print (" ranksep = 2\n", []);
148 :     case root
149 :     of S.Empty => ()
150 :     | (S.Node{cell=S.BodyCell b, ...}) => (
151 :     addNd (0, 0); bodyNd(0, 0, b); ())
152 :     | (S.Node{cell=S.Cell a, ...}) => (
153 :     addNd (0, 0); cellNd (0, 0); walkCell(1, a, 0); ())
154 :     (* end case *);
155 :     prLevels ();
156 :     print ("}\n", []);
157 :     IO.close_out strm
158 :     end
159 :    
160 :     fun dumpTest {fname, nbodies, nprocs} = let
161 :     val _ = M.srand 123
162 :     val data = M.testdata nbodies
163 :     val S.Space{root, ...} =
164 :     M.L.makeTree (data, V.tabulate (fn _ => ~2.0), 4.0);
165 :     in
166 :     assignProcs' (root, nbodies, nprocs);
167 :     dumpTree (fname, root, data)
168 :     end
169 :    
170 :     end;
171 :    

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