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 /MLRISC/trunk/block-placement/check-placement-fn.sml
ViewVC logotype

Annotation of /MLRISC/trunk/block-placement/check-placement-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1166 - (view) (download)
Original Path: sml/trunk/src/MLRISC/block-placement/check-placement-fn.sml

1 : jhr 1160 (* check-placement-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
4 :     *
5 :     * This functor implements code to check that a block placement is
6 :     * correct.
7 :     *)
8 :    
9 : jhr 1163 functor CheckPlacementFn (
10 : jhr 1160
11 :     structure CFG : CONTROL_FLOW_GRAPH
12 : jhr 1163 structure InsnProps : INSN_PROPERTIES
13 :     where I = CFG.I
14 : jhr 1160
15 : jhr 1163 ) : sig
16 :    
17 :     structure CFG : CONTROL_FLOW_GRAPH
18 :    
19 : jhr 1160 val check : (CFG.cfg * CFG.node list) -> unit
20 :    
21 :     end = struct
22 :    
23 :     structure CFG=CFG
24 : jhr 1163 structure IP = InsnProps
25 : jhr 1160 structure G = Graph
26 :    
27 :     val dumpStrm = MLRiscControl.debug_stream
28 :    
29 :     fun blockToString (id', CFG.BLOCK{id, ...}) =
30 :     concat["<", Int.toString id', ":", Int.toString id, ">"]
31 :    
32 :     fun check (cfg as G.GRAPH graph, blocks) = let
33 :     (* an array that maps from block id to position in the placement (starting
34 :     * from 1). Nodes that have no placement have index ~1.
35 :     *)
36 :     val order = let
37 :     val arr = Array.array(#capacity graph (), ~1)
38 :     fun init ((id, _), i) = (Array.update(arr, id, i); i+1)
39 :     in
40 :     ignore (List.foldl init 1 blocks);
41 :     arr
42 :     end
43 :     fun adjacentNodes (a, b) = (Array.sub(order, a) + 1 = Array.sub(order, b))
44 :     val anyErrors = ref false
45 :     (* report an error and dump the cfg *)
46 : jhr 1163 fun reportError msg = let
47 : jhr 1160 fun say s = TextIO.output(!dumpStrm, s)
48 :     in
49 :     if !anyErrors
50 :     then ()
51 :     else (
52 :     anyErrors := true;
53 :     say "********** Bogus block placement **********\n");
54 : jhr 1166 say(concat("** "::msg))
55 : jhr 1163 end
56 :     fun reportNotAdjacent (src, dst) = let
57 :     fun b2s id = concat[
58 :     Int.toString id, "@", Int.toString(Array.sub(order, id))
59 :     ]
60 :     in
61 :     reportError [
62 :     "Blocks ", b2s src, " and ", b2s dst,
63 : jhr 1166 " are not adjacent\n"
64 : jhr 1163 ]
65 : jhr 1160 end
66 :     (* return true if the edge must connect adjacent nodes *)
67 :     fun adjEdge (CFG.EDGE{k=CFG.FALLSTHRU, ...}) = true
68 :     | adjEdge (CFG.EDGE{k=CFG.BRANCH false, ...}) = true
69 :     | adjEdge _ = false
70 : jhr 1163 (* entry and exit nodes *)
71 :     val entryId = CFG.entryId cfg
72 :     val exitId = CFG.exitId cfg
73 :     (* get the jump targets from the last instruction in a block *)
74 :     fun getJumpTargets id = (case #node_info graph id
75 :     of CFG.BLOCK{insns=ref(i::_), ...} => (
76 :     case IP.instrKind i
77 :     of IP.IK_JUMP => IP.branchTargets i
78 :     | _ => []
79 :     (* end case *))
80 :     | _ => []
81 :     (* end case *))
82 : jhr 1160 (* check that FALLSTHRU and BRANCH false edges connect adjacent nodes *)
83 : jhr 1163 fun chkEdge (src, dst, CFG.EDGE{k, ...}) = (case k
84 :     of (CFG.FALLSTHRU | CFG.BRANCH false) =>
85 :     if adjacentNodes(src, dst)
86 :     then ()
87 :     else reportNotAdjacent(src, dst)
88 :     | CFG.BRANCH true => (case getJumpTargets src
89 :     of [IP.FALLTHROUGH, IP.LABELLED _] => ()
90 :     | [IP.LABELLED _, IP.FALLTHROUGH] => ()
91 :     | _ => reportError[
92 :     "Block ", Int.toString src,
93 :     " doesn't end in conditiona branch\n"
94 :     ]
95 :     (* end case *))
96 :     | CFG.JUMP => (case getJumpTargets src
97 :     of [IP.LABELLED _] => ()
98 :     | _ => reportError[
99 :     "Block ", Int.toString src, " doesn't end in jump\n"
100 :     ]
101 :     (* end case *))
102 :     | CFG.ENTRY => if (src <> entryId)
103 :     then reportError[
104 :     "Block ", Int.toString src, " is not ENTRY\n"
105 :     ]
106 :     else ()
107 :     | CFG.EXIT => if (dst <> exitId)
108 : jhr 1166 then reportError[
109 :     "Block ", Int.toString dst, " is not EXIT\n"
110 : jhr 1163 ]
111 : jhr 1166 else (case getJumpTargets src
112 :     of [IP.ESCAPES] => ()
113 :     | _ => reportError [
114 :     "Block ", Int.toString src,
115 :     "doesn't end in an escaping jump\n"
116 :     ]
117 :     (* end case *))
118 : jhr 1163 | _ => () (* no checking for SWITCH or FLOWSTO *)
119 :     (* end case *))
120 : jhr 1160 in
121 :     #forall_edges graph chkEdge;
122 :     if (!anyErrors)
123 :     then let
124 :     fun say s = TextIO.output(!dumpStrm, s)
125 :     val prBlock = CFG.dumpBlock (!dumpStrm, cfg)
126 :     in
127 :     say "Block placement order:\n";
128 :     List.app
129 :     (fn b => say(concat[" ", blockToString b, "\n"]))
130 :     blocks;
131 :     TextIO.output(!dumpStrm, "[ control-flow-graph ]\n");
132 :     List.app prBlock blocks;
133 :     say "**********\n";
134 :     MLRiscErrorMsg.error ("CheckPlacementFn", "bogus placement")
135 :     end
136 :     else ()
137 :     end
138 :    
139 :     end

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