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/compiler/CodeGen/alpha32/alpha32CG.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/CodeGen/alpha32/alpha32CG.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 106 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/CodeGen/alpha32/alpha32CG.sml

1 : monnier 16 (* alpha32CG.sml --- 32 bit DEC alpha code generator
2 :     *
3 :     * COPYRIGHT (c) 1996 Bell Laboratories.
4 :     *
5 :     *)
6 :     functor Alpha32CG(structure Emitter : EMITTER_NEW
7 :     where I = Alpha32Instr
8 :     where F = Alpha32FlowGraph) :
9 :     sig
10 :     structure MLTreeGen : CPSGEN
11 :     val finish : unit -> unit
12 :     end =
13 :     struct
14 :    
15 :     structure I = Alpha32Instr
16 :     structure C = Alpha32Cells
17 :     structure R = Alpha32CpsRegs
18 :     structure MLTree = Alpha32MLTree
19 :     structure CG = Control.CG
20 :    
21 :     fun error msg = ErrorMsg.impossible ("Alpha32CG." ^ msg)
22 :    
23 :     val stack = Alpha32Instr.Region.stack
24 :    
25 :     structure Alpha32Rewrite = Alpha32Rewrite(Alpha32Instr)
26 :    
27 :     (* properties of instruction set *)
28 :     structure Alpha32Props =
29 : monnier 106 Alpha32Props(structure Alpha32Instr= I
30 :     structure Shuffle=Alpha32Shuffle)
31 : monnier 16
32 :     (* Label backpatching and basic block scheduling *)
33 :     structure BBSched =
34 :     BBSched2(structure Flowgraph = Alpha32FlowGraph
35 :     structure Jumps =
36 :     Alpha32Jumps(structure Instr=Alpha32Instr
37 :     structure Shuffle=Alpha32Shuffle)
38 :     structure Emitter = Emitter)
39 :    
40 :     (* flow graph pretty printing routine *)
41 :     structure PrintFlowGraph =
42 :     PrintFlowGraphFn (structure FlowGraph = Alpha32FlowGraph
43 :     structure Emitter = Alpha32AsmEmitter)
44 :    
45 :     (* register allocation *)
46 :     structure RegAllocation :
47 :     sig
48 :     val ra : Alpha32FlowGraph.cluster -> Alpha32FlowGraph.cluster
49 :     end =
50 :     struct
51 :    
52 :     (* spill area management *)
53 :     val initialSpillOffset = 128
54 :     val spillOffset = ref initialSpillOffset
55 :     fun newOffset n =
56 :     if n > 4096
57 :     then error "newOffset - spill area is too small"
58 :     else spillOffset := n
59 :     exception RegSpills and FregSpills
60 :    
61 :     val regSpills : int Intmap.intmap ref = ref(Intmap.new(0, RegSpills))
62 :     val fregSpills : int Intmap.intmap ref = ref(Intmap.new(0, FregSpills))
63 :    
64 :     (* get spill location for general registers *)
65 :     fun getRegLoc reg = Intmap.map (!regSpills) reg
66 :     handle RegSpills => let
67 :     val offset = !spillOffset
68 :     in
69 :     newOffset(offset+4);
70 :     Intmap.add (!regSpills) (reg, offset);
71 :     offset
72 :     end
73 :    
74 :     (* get spill location for floating registers *)
75 :     fun getFregLoc freg = Intmap.map (!fregSpills) freg
76 :     handle FregSpills => let
77 :     val offset = !spillOffset
78 :     val fromInt = Word.fromInt
79 :     val aligned = Word.toIntX(Word.andb(fromInt offset+0w7, fromInt ~8))
80 :     in
81 :     newOffset(aligned+8);
82 :     Intmap.add (!fregSpills) (freg, aligned);
83 :     aligned
84 :     end
85 :    
86 :     fun mvInstr(rd, rs) = I.OPERATE{oper=I.BIS, ra=rs, rb=I.REGop 31, rc=rd}
87 :     fun fmvInstr(fd, fs) = I.FOPERATE{oper=I.CPYS, fa=fs, fb=fs, fc=fd}
88 :    
89 :    
90 :     fun spill (stClass, stOp, getLoc, newReg, rewrite) {regmap,instr,reg} = let
91 :     val offset = I.IMMop (getLoc(reg))
92 :     fun spillInstr(src) =
93 :     [stClass{stOp=stOp, r=src, b=C.stackptrR, d=offset, mem=stack}]
94 :     in
95 :     case instr
96 :     of I.COPY{dst as [rd], src as [rs], tmp, impl} =>
97 :     if rd=reg then
98 :     {code=spillInstr(rs), instr=NONE, proh=[]:int list}
99 :     else (case tmp
100 :     of SOME(I.Direct r) => let
101 :     val loc = I.Displace{base=C.stackptrR, disp=getLoc(r)}
102 :     val instr=I.COPY{dst=dst, src=src, tmp=SOME(loc), impl=impl}
103 :     in {code=[], instr=SOME instr, proh=[]}
104 :     end
105 :     | _ => error "spill: COPY"
106 :     (*esac*))
107 :     | I.FCOPY{dst as [fd], src as [fs], tmp, impl} => (* reg = fd *)
108 :     if reg=fd then
109 :     {code=spillInstr(fs), instr=NONE, proh=[]}
110 :     else (case tmp
111 :     of SOME(I.FDirect r) => let
112 :     val loc = I.Displace{base=C.stackptrR, disp=getLoc(r)}
113 :     val instr=I.FCOPY{dst=dst, src=src, tmp=SOME(loc), impl=impl}
114 :     in {code=[], instr=SOME instr, proh=[]}
115 :     end
116 :     | _ => error "spill: COPY"
117 :     (*esac*))
118 :     | _ => let
119 :     val newR = newReg()
120 :     val instr' = rewrite(regmap, instr, reg, newR)
121 :     in {code=spillInstr(newR), instr=SOME instr', proh=[newR]}
122 :     end
123 :     end
124 :    
125 :     fun reload (ldClass, ldOp, getLoc, newReg, rewrite) {regmap,instr,reg} = let
126 :     val offset = I.IMMop (getLoc(reg))
127 :     fun reloadInstr(dst, rest) =
128 :     ldClass{ldOp=ldOp, r=dst, b=C.stackptrR, d=offset, mem=stack}::rest
129 :     in
130 :     case instr
131 :     of I.COPY{dst=[rd], src=[rs], ...} => (* reg = rs *)
132 :     {code=reloadInstr(rd, []), proh=[]:int list}
133 :     | I.FCOPY{dst=[fd], src=[fs], ...} => (* reg = fs *)
134 :     {code=reloadInstr(fd, []), proh=[]}
135 :     | _ => let
136 :     val newR = newReg()
137 :     val instr' = rewrite(regmap, instr, reg, newR)
138 :     in {code=reloadInstr(newR, [instr']), proh=[newR]}
139 :     end
140 :     end
141 :    
142 :     fun spillInit () =
143 :     (spillOffset := initialSpillOffset;
144 :     regSpills := Intmap.new(8, RegSpills);
145 :     fregSpills := Intmap.new(8, FregSpills))
146 :    
147 :     structure GR = GetReg(val nRegs=32 val available=R.availR)
148 :     structure FR = GetReg(val nRegs=32 val available=R.availF)
149 :    
150 :     structure Alpha32Ra =
151 :     Alpha32RegAlloc(structure P = Alpha32Props
152 :     structure I = Alpha32Instr
153 :     structure F = Alpha32FlowGraph
154 :     structure Asm = Alpha32AsmEmitter)
155 :    
156 :     (* register allocation for general purpose registers *)
157 :     structure IntRa =
158 :     Alpha32Ra.IntRa
159 :     (structure RaUser = struct
160 :     structure I = Alpha32Instr
161 :    
162 :     val getreg = GR.getreg
163 :     val spill = spill(I.STORE,I.STL, getRegLoc, C.newReg,
164 :     Alpha32Rewrite.rewriteDef)
165 :     val reload = reload(I.LOAD, I.LDL, getRegLoc, C.newReg,
166 :     Alpha32Rewrite.rewriteUse)
167 :     val nFreeRegs = length R.availR
168 :     val dedicated = R.dedicatedR
169 :     fun copyInstr((rds, rss), I.COPY{tmp, ...}) =
170 :     I.COPY{dst=rds, src=rss, impl=ref NONE, tmp=tmp}
171 :     end)
172 :    
173 :     (* register allocation for floating point registers *)
174 :     structure FloatRa =
175 :     Alpha32Ra.FloatRa
176 :     (structure RaUser = struct
177 :     structure I = Alpha32Instr
178 :    
179 :     val getreg = FR.getreg
180 :     val spill = spill (I.FSTORE, I.STT, getFregLoc, C.newFreg,
181 :     Alpha32Rewrite.frewriteDef)
182 :     val reload = reload (I.FLOAD, I.LDT, getFregLoc, C.newFreg,
183 :     Alpha32Rewrite.frewriteUse)
184 :     val nFreeRegs = length R.availF
185 :     val dedicated = R.dedicatedF
186 :     fun copyInstr((fds, fss), I.FCOPY{tmp, ...}) =
187 :     I.FCOPY{dst=fds, src=fss, impl=ref NONE, tmp=tmp}
188 :     end)
189 :    
190 :     val iRegAlloc = IntRa.ra IntRa.REGISTER_ALLOCATION
191 :     val fRegAlloc = FloatRa.ra FloatRa.REGISTER_ALLOCATION
192 :     val iCopyProp = IntRa.ra IntRa.COPY_PROPAGATION
193 :    
194 :     fun ra cluster = let
195 :     val pg = PrintFlowGraph.printCluster TextIO.stdOut
196 :     fun intRa cluster = (GR.reset(); iRegAlloc cluster)
197 :     fun floatRa cluster = (FR.reset(); fRegAlloc cluster)
198 :     in spillInit(); (floatRa o intRa) cluster
199 :     end
200 :     end (* RegAllocation *)
201 :    
202 :     fun codegen cluster = let
203 :     fun phaseToMsg(CG.AFTER_INSTR_SEL) = "After instruction selection"
204 :     | phaseToMsg(CG.AFTER_RA) = "After register allocation"
205 :     | phaseToMsg(CG.AFTER_SCHED) = "After instruction scheduling"
206 :     | phaseToMsg _ = error "phaseToMsg"
207 :     val printGraph = PrintFlowGraph.printCluster (!CG.printFlowgraphStream)
208 :     fun doPhase (phase, f) cluster = let
209 :     fun show(CG.PHASES(ph1, ph2)) = show ph1 orelse show ph2
210 :     | show(ph) = (ph = phase)
211 :     val newCluster = f cluster
212 :     in
213 :     if show (!CG.printFlowgraph) then
214 :     printGraph (phaseToMsg phase) newCluster
215 :     else ();
216 :     newCluster
217 :     end
218 :     val instrSel = doPhase (CG.AFTER_INSTR_SEL, fn x => x)
219 :     val regAlloc = doPhase (CG.AFTER_RA, RegAllocation.ra)
220 :     in
221 :     case !CG.printFlowgraph
222 :     of CG.NO_PHASE => (BBSched.bbsched o RegAllocation.ra) cluster
223 :     | phase => (BBSched.bbsched o regAlloc o instrSel) cluster
224 :     end
225 :    
226 :     (* primitives for generation of DEC alpha instruction flowgraphs *)
227 :     structure FlowGraphGen =
228 :     FlowGraphGen(structure Flowgraph = Alpha32FlowGraph
229 :     structure InsnProps = Alpha32Props
230 :     structure MLTree = MLTree
231 :     val codegen = codegen)
232 :    
233 :     (* compilation of CPS to MLRISC *)
234 :     structure MLTreeGen =
235 :     MLRiscGen(structure MachineSpec=Alpha32Spec
236 :     structure MLTreeComp=
237 :     Alpha32(structure Flowgen=FlowGraphGen
238 :     structure Alpha32Instr=Alpha32Instr
239 :     structure Alpha32MLTree=Alpha32MLTree
240 :     structure PseudoInstrs=Alpha32PseudoInstrs)
241 :     structure Cells=Alpha32Cells
242 :     structure C=Alpha32CpsRegs
243 :     structure ConstType=Alpha32Const
244 :     structure PseudoOp=Alpha32PseudoOps)
245 :    
246 :     val finish = BBSched.finish
247 :     end
248 :    
249 :    
250 :     (*
251 :     * $Log: alpha32CG.sml,v $
252 : monnier 106 * Revision 1.2 1998/05/19 15:32:42 george
253 :     * instruction properties is no longer parameterized over the exnptrR
254 :     *
255 : monnier 93 * Revision 1.1.1.1 1998/04/08 18:39:54 george
256 :     * Version 110.5
257 : monnier 16 *
258 :     *)

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