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/cluster/clustergen.sml
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/cluster/clustergen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 409 - (view) (download)

1 : monnier 409 (* flowgen.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     *)
6 :    
7 :     functor ClusterGen
8 :     (structure Flowgraph : FLOWGRAPH
9 :     structure InsnProps : INSN_PROPERTIES
10 :     structure MLTree : MLTREE
11 :     structure Stream : INSTRUCTION_STREAM
12 :    
13 :     val optimize : (Flowgraph.cluster -> Flowgraph.cluster) option ref
14 :     val output : Flowgraph.cluster -> unit
15 :     sharing Flowgraph.I = InsnProps.I
16 :     sharing MLTree.Constant = InsnProps.I.Constant
17 :     sharing MLTree.PseudoOp = Flowgraph.P = Stream.P
18 :     sharing Flowgraph.B = MLTree.BNames = Stream.B
19 :     ) : FLOWGRAPH_GEN =
20 :     struct
21 :    
22 :     structure F = Flowgraph
23 :     structure Props = InsnProps
24 :     structure I = Flowgraph.I
25 :     structure C = I.C
26 :    
27 :     structure T = MLTree
28 :     structure B = MLTree.BNames
29 :     structure P = T.PseudoOp
30 :     structure S = Stream
31 :     structure Control = MLRISC_Control
32 :    
33 :     type label = Label.label
34 :    
35 :     fun error msg = MLRiscErrorMsg.error("ClusterGen",msg)
36 :    
37 :     type flowgraph = F.cluster
38 :    
39 :     fun newStream() =
40 :     let val bblkCnt = ref 0
41 :     val entryLabels = ref ([] : Label.label list)
42 :     val blkName = ref B.default
43 :     val NOBLOCK = F.EXIT{blknum=0,freq=ref 0,pred=ref []}
44 :     val currBlock : F.block ref = ref NOBLOCK
45 :     val blockList : F.block list ref = ref []
46 :    
47 :     fun nextBlkNum () = !bblkCnt before bblkCnt := !bblkCnt + 1
48 :     fun blockName name =
49 :     (case !currBlock
50 :     of blk as F.BBLOCK _ =>
51 :     (currBlock := NOBLOCK; blockList := blk:: !blockList)
52 :     | _ => ()
53 :     (*esac*);
54 :     blkName := name)
55 :    
56 :     (** Note - currBlock will always be a reference to a F.BBLOCK{..} **)
57 :     fun newBasicBlk init =
58 :     F.BBLOCK{blknum=nextBlkNum(),
59 :     freq=ref 0,
60 :     annotations=ref [],
61 :     name= !blkName,
62 :     liveIn=ref C.empty,
63 :     liveOut=ref C.empty,
64 :     succ=ref [],
65 :     pred=ref [],
66 :     insns=ref init}
67 :     local
68 :     fun blockListAdd b = let
69 :     val blocks = !blockList
70 :     in
71 :     case !currBlock
72 :     of blk as F.BBLOCK _ => (blockList:=b::blk::blocks;
73 :     currBlock:=NOBLOCK)
74 :     | _ => blockList := b::blocks
75 :     end
76 :     in
77 :     fun pseudoOp pOp = blockListAdd (F.PSEUDO pOp)
78 :     fun defineLabel lab = blockListAdd(F.LABEL lab)
79 :     fun entryLabel lab =
80 :     (entryLabels := lab::(!entryLabels); blockListAdd(F.LABEL lab))
81 :     (*
82 :     fun ordered(mlts) =
83 :     blockListAdd
84 :     (F.ORDERED(map (fn T.PSEUDO_OP pOp => F.PSEUDO pOp
85 :     | T.DEFINELABEL lab => F.LABEL lab
86 :     | T.ENTRYLABEL lab =>
87 :     (entryLabels := lab :: !entryLabels;
88 :     F.LABEL lab)
89 :     | _ => error "ordered ")
90 :     mlts)) *)
91 :     end (*local*)
92 :    
93 :     (** emitInstr - instructions are always added to currBlock. **)
94 :     fun emitInstr instr = let
95 :     fun addInstr (F.BBLOCK{insns, ...}) = insns := instr::(!insns)
96 :     | addInstr _ = currBlock:=newBasicBlk [instr]
97 :     in addInstr(!currBlock);
98 :     case Props.instrKind instr
99 :     of Props.IK_JUMP =>
100 :     (blockList:= !currBlock :: (!blockList);
101 :     currBlock := NOBLOCK)
102 :     | _ => ()
103 :     (*esac*)
104 :     end
105 :     fun annotation a =
106 :     case !currBlock of
107 :     F.BBLOCK{annotations,...} => annotations := a :: !annotations
108 :     | _ => (currBlock := newBasicBlk []; annotation a)
109 :    
110 :     fun exitBlock liveRegs = let
111 :     val addReg = C.addCell C.GP
112 :     val addFreg = C.addCell C.FP
113 :     val addCCreg = C.addCell C.CC
114 :     (* we don't care about memory locations that may be live. *)
115 :     fun live(T.GPR(T.REG(_,r))::rest, acc) = live(rest, addReg(r, acc))
116 :     | live(T.FPR(T.FREG(_,f))::rest, acc) = live(rest, addFreg(f, acc))
117 :     | live(T.CCR(T.CC c)::rest, acc) = live(rest, addCCreg(c, acc))
118 :     | live(_::rest, acc) = live(rest, acc)
119 :     | live([], acc) = acc
120 :    
121 :     val lout = live(liveRegs, C.empty)
122 :    
123 :     fun findCodeBlock(F.BBLOCK{liveOut,...}::_) = liveOut
124 :     | findCodeBlock(F.LABEL _::blks) = findCodeBlock blks
125 :     | findCodeBlock _ = error "exitBlock.codeBlock"
126 :    
127 :     in
128 :     case !currBlock
129 :     of F.BBLOCK{liveOut, ...} =>
130 :     (liveOut := lout;
131 :     blockList := !currBlock :: (!blockList);
132 :     currBlock := NOBLOCK)
133 :     | _ =>
134 :     let val outRef = findCodeBlock (!blockList)
135 :     in outRef := lout
136 :     end
137 :     (*esac*)
138 :     end
139 :    
140 :     fun endCluster(regmap,annotations) = let
141 :     exception LabTbl
142 :     val labTbl : F.block Intmap.intmap = Intmap.new(16, LabTbl)
143 :     val addLabTbl = Intmap.add labTbl
144 :     val lookupLabTbl = Intmap.map labTbl
145 :    
146 :     (* find next code block *)
147 :     exception NextCodeBlock
148 :     fun nextCodeBlock((blk as F.BBLOCK _)::_) = blk
149 :     | nextCodeBlock(_::rest) = nextCodeBlock rest
150 :     | nextCodeBlock [] = raise NextCodeBlock
151 :    
152 :     (* mapping of labels to code blocks *)
153 :     fun fillLabTbl(F.LABEL lab::blks) =
154 :     (addLabTbl(Label.id lab, nextCodeBlock blks)
155 :     handle NextCodeBlock => ();
156 :     fillLabTbl blks)
157 :     (*| fillLabTbl(F.ORDERED labs::blks) = fillLabTbl(labs@blks)*)
158 :     | fillLabTbl(_::blks) = fillLabTbl(blks)
159 :     | fillLabTbl [] = ()
160 :    
161 :     val exitBlk = F.EXIT{blknum=nextBlkNum(), pred=ref [], freq=ref 0}
162 :    
163 :     (** update successor and predecessor information **)
164 :     fun graphEdges((blk as F.BBLOCK{blknum,insns,succ,...})::blks) = let
165 :     fun updtPred(F.BBLOCK{pred, ...},w) = pred := (blk,w)::(!pred)
166 :     | updtPred(F.EXIT{pred, ...},w) = pred := (blk,w)::(!pred)
167 :    
168 :     fun succBlks([], acc) = acc
169 :     | succBlks(Props.FALLTHROUGH::labs, acc) =
170 :     ((succBlks(labs, (nextCodeBlock blks,ref 0)::acc))
171 :     handle NextCodeBlock => error "graphEdges.succBlks")
172 :     | succBlks(Props.LABELLED lab::labs, acc) =
173 :     ((succBlks(labs,(lookupLabTbl(Label.id lab),ref 0)::acc))
174 :     handle LabTbl =>
175 :     succBlks(labs, (exitBlk,ref 0)::acc))
176 :     | succBlks(Props.ESCAPES::labs,acc) =
177 :     succBlks(labs, (exitBlk,ref 0)::acc)
178 :    
179 :     val lastInstr = ((hd (!insns))
180 :     handle _ => error "endCluster.graphEdges.lastInstr")
181 :    
182 :     fun lastCodeBlock(F.BBLOCK _ :: _) = false
183 :     | lastCodeBlock(_::rest) = lastCodeBlock rest
184 :     | lastCodeBlock [] = true
185 :     in
186 :     case Props.instrKind lastInstr
187 :     of Props.IK_JUMP => succ:=succBlks
188 :     (Props.branchTargets lastInstr,[])
189 :     | _ =>
190 :     if lastCodeBlock blks then
191 :     succ := [(exitBlk,ref 0)]
192 :     (* control must escape via trap *)
193 :     else succ := [(nextCodeBlock blks,ref 0)]
194 :     (*esac*);
195 :     app updtPred (!succ);
196 :     graphEdges(blks)
197 :     end
198 :     | graphEdges(_::blks) = graphEdges(blks)
199 :     | graphEdges [] = ()
200 :    
201 :     fun mkEntryBlock () = let
202 :     val blocks =
203 :     map (fn Label.Label{id,...} => (lookupLabTbl id,ref 0))
204 :     (!entryLabels)
205 :     val entryBlk = F.ENTRY{blknum=nextBlkNum(), freq=ref 0,
206 :     succ=ref blocks}
207 :     in
208 :     app (fn (F.BBLOCK{pred, ...},w) =>
209 :     pred := (entryBlk,w)::(!pred)) blocks;
210 :     entryBlk
211 :     end
212 :    
213 :     val _ = case !currBlock
214 :     of blk as F.BBLOCK _ => blockList := blk :: !blockList
215 :     | _ => ()
216 :    
217 :     val blocks = rev(!blockList) before blockList := []
218 :     val _ = fillLabTbl(blocks)
219 :     val _ = graphEdges(blocks)
220 :     val cluster =
221 :     F.CLUSTER{blocks=blocks, entry=mkEntryBlock(), exit=exitBlk,
222 :     blkCounter=ref(!bblkCnt), regmap=regmap,
223 :     annotations=ref(annotations)}
224 :     val codegen =
225 :     case !optimize of
226 :     NONE => output
227 :     | SOME optimizer => output o optimizer
228 :     in codegen cluster
229 :     end
230 :    
231 :     fun beginCluster _ =
232 :     (entryLabels := [];
233 :     bblkCnt := 0;
234 :     blkName := B.default;
235 :     blockList := [];
236 :     currBlock := NOBLOCK)
237 :    
238 :     fun comment _ = () (* unimplemented *)
239 :    
240 :     in S.STREAM
241 :     { init = beginCluster,
242 :     finish = endCluster,
243 :     emit = fn _ => emitInstr,
244 :     defineLabel = defineLabel,
245 :     entryLabel = entryLabel,
246 :     pseudoOp = pseudoOp,
247 :     exitBlock = exitBlock,
248 :     blockName = blockName,
249 :     annotation = annotation,
250 :     comment = comment
251 :     }
252 :     end
253 :    
254 :     end
255 :    

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