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/src/MLRISC/IR/mlrisc-cfg-gen.sml
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/IR/mlrisc-cfg-gen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 246 - (view) (download)

1 : monnier 245 functor ControlFlowGraphGenFn
2 :     (structure CFG : CONTROL_FLOW_GRAPH
3 :     structure Emitter : CODE_EMITTER
4 :     structure P : INSN_PROPERTIES
5 :     sharing CFG.I = Emitter.I = P.I
6 :     sharing CFG.P = Emitter.P
7 :     sharing CFG.B = Emitter.B
8 :     ) : CONTROL_FLOW_GRAPH_GEN =
9 :     struct
10 :    
11 :     structure CFG = CFG
12 :     structure Props = P
13 :     structure I = CFG.I
14 :     structure B = CFG.B
15 :     structure P = CFG.P
16 :     structure G = Graph
17 :     structure W = CFG.W
18 :     structure Emitter = Emitter
19 :    
20 :     fun error msg = MLRiscErrorMsg.impossible("ControlFlowGraphGen." ^ msg)
21 :    
22 :     fun warning msg = print("Warning: "^msg^"\n")
23 :    
24 :     fun emitter(CFG as G.GRAPH cfg) =
25 :     let val currentBlock = ref NONE : CFG.block option ref
26 :     val newBlocks = ref [] : CFG.block list ref
27 :     val blkName = ref B.default
28 :     val _ = CFG.init CFG
29 :     val [ENTRY] = #entries cfg ()
30 :     val [EXIT] = #exits cfg ()
31 :     exception NotFound
32 :     val labelMap = Intmap.new(43,NotFound)
33 :     val newLabel = Intmap.add labelMap
34 :    
35 :     fun newBlock() =
36 :     let val id = #new_id cfg ()
37 :     val b = CFG.newBlock(id,!blkName)
38 :     in currentBlock := SOME b;
39 :     newBlocks := b :: !newBlocks;
40 :     #add_node cfg (id,b);
41 :     b
42 :     end
43 :    
44 :     fun getBlock() =
45 :     case !currentBlock of
46 :     NONE => newBlock()
47 :     | SOME b => b
48 :    
49 :     fun newPseudoOpBlock() =
50 :     (case !currentBlock of
51 :     SOME(b as CFG.BLOCK{insns=ref [],...}) => b
52 :     | _ => newBlock()
53 :     )
54 :    
55 :     fun insertOp p =
56 :     let val CFG.BLOCK{data,...} = newPseudoOpBlock()
57 :     in data := !data @ [p] end
58 :    
59 :     fun defineLabel(l as Label.Label{id,...}) =
60 :     let val b as CFG.BLOCK{labels,...} = newPseudoOpBlock()
61 :     in labels := l :: !labels;
62 :     newLabel(id,b)
63 :     end
64 :    
65 :     fun pseudoOp p = insertOp(CFG.PSEUDO p)
66 :    
67 :     fun exitBlock liveOut =
68 :     let val CFG.BLOCK{annotations,...} = getBlock()
69 :     in annotations := CFG.LIVEOUT liveOut :: !annotations
70 :     end
71 :    
72 :     fun comment msg =
73 :     let val CFG.BLOCK{annotations,...} = getBlock()
74 :     in annotations := Annotations.COMMENT msg :: !annotations
75 :     end
76 :    
77 :     fun blockName name = blkName := name
78 :    
79 :     fun blockName name = blkName := name
80 :    
81 :     fun entryLabel(l as Label.Label{id,...}) =
82 :     let val b as CFG.BLOCK{id=j,labels,...} = newPseudoOpBlock()
83 :     in labels := l :: !labels;
84 :     newLabel(id,b);
85 :     #add_edge cfg (ENTRY,j,CFG.EDGE{k=CFG.ENTRY,a=ref [],
86 :     w=ref W.zero})
87 :     end
88 :     fun emitInstr i =
89 :     let val CFG.BLOCK{insns,...} = getBlock()
90 :     in insns := i :: !insns;
91 :     if Props.instrKind i = Props.IK_JUMP then
92 :     currentBlock := NONE
93 :     else ()
94 :     end
95 :     fun finish() =
96 :     let fun nextBlock(CFG.BLOCK{id,data=ref [],...}::_) = id
97 :     | nextBlock _ = error "nextBlock"
98 :     fun target (Label.Label{id,...}) =
99 :     let val CFG.BLOCK{id,...} = Intmap.map labelMap id
100 :     in id end
101 :     fun addEdges [] = ()
102 :     | addEdges(CFG.BLOCK{id,insns,...}::blocks) =
103 :     (case !insns of
104 :     [] => fallsThru(id,blocks)
105 :     | instr::_ =>
106 :     if Props.instrKind instr = Props.IK_JUMP then
107 :     jump(id,Props.branchTargets instr,blocks)
108 :     else
109 :     fallsThru(id,blocks);
110 :     addEdges blocks
111 :     )
112 :     and fallsThru(i,CFG.BLOCK{id=j,data,...}::_) =
113 :     (case !data of
114 :     [] => ()
115 :     | _ => warning("falls thru into pseudo ops: "^
116 :     Int.toString i^" -> "^Int.toString j)
117 :     ;
118 :     #add_edge cfg (i,j,CFG.EDGE{k=CFG.FALLSTHRU,
119 :     w=ref W.zero,
120 :     a=ref []
121 :     })
122 :     )
123 :     | fallsThru(i,[]) =
124 :     error("missing return in block "^Int.toString i)
125 :     and jump(i,[Props.ESCAPES],_) =
126 :     #add_edge cfg (i,EXIT,CFG.EDGE{k=CFG.EXIT,
127 :     w=ref W.zero,
128 :     a=ref []
129 :     })
130 :     | jump(i,[Props.LABELLED L],_) =
131 :     #add_edge cfg (i,target L,CFG.EDGE{k=CFG.JUMP,
132 :     w=ref W.zero,
133 :     a=ref []})
134 :     | jump(i,[Props.LABELLED L,Props.FALLTHROUGH],bs) =
135 :     (#add_edge cfg (i,target L,CFG.EDGE{k=CFG.BRANCH true,
136 :     w=ref W.zero,
137 :     a=ref []
138 :     });
139 :     #add_edge cfg (i,nextBlock bs,CFG.EDGE
140 :     {k=CFG.BRANCH false,
141 :     w=ref W.zero,
142 :     a=ref []
143 :     })
144 :     )
145 :     | jump(i,targets,_) =
146 :     let fun f(n,[]) = ()
147 :     | f(n,Props.LABELLED L::targets) =
148 :     (#add_edge cfg (i,target L,CFG.EDGE
149 :     {k=CFG.SWITCH n,
150 :     w=ref W.zero,
151 :     a=ref []});
152 :     f(n+1,targets))
153 :     | f _ = error "jump"
154 :     in f(0,targets) end
155 :     in addEdges(rev(!newBlocks))
156 :     end
157 :    
158 :     in
159 :     { init = fn _ => (),
160 :     defineLabel = defineLabel,
161 :     entryLabel = entryLabel,
162 :     pseudoOp = pseudoOp,
163 :     emitInstr = emitInstr,
164 :     exitBlock = exitBlock,
165 :     blockName = blockName,
166 :     comment = comment,
167 :     finish = finish
168 :     }
169 :     end
170 :    
171 :     end
172 :    
173 :     (*
174 :     * $Log$
175 :     *)

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