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/x86/staged-allocation/test.sml
ViewVC logotype

Annotation of /MLRISC/trunk/x86/staged-allocation/test.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3064 - (view) (download)

1 : mrainey 3054 val fast_floating_point = ref true
2 :    
3 : mrainey 3010 (*
4 :     * User defined constant type. Dummy for now.
5 :     * In practice, you'll want to use this type to implement constants with
6 :     * values that cannot be determined until final code generation, e.g.
7 :     * stack frame offset.
8 :     *)
9 :     structure UserConst =
10 :     struct
11 :     type const = unit
12 :     fun toString() = ""
13 :     fun hash() = 0w0
14 :     fun valueOf _ = 0
15 :     fun == _ = true
16 :     end
17 :    
18 :     (*
19 :     * User defined datatype for representing aliasing. Dummy for now.
20 :     * You'll need this to represent aliasing information.
21 :     *)
22 :     structure UserRegion =
23 :     struct
24 :     type region = unit
25 :     fun toString () = ""
26 :     val memory = ()
27 :     val stack = ()
28 :     val readonly = ()
29 :     val spill = ()
30 :     end
31 :    
32 :     (*
33 :     * User defined datatype for representing pseudo assembly operators.
34 :     * Dummy for now.
35 :     *
36 :     * You'll need this to represent assembler directives.
37 :     *)
38 :     structure UserPseudoOps =
39 :     struct
40 :     type pseudo_op = unit
41 :     fun toString () = ""
42 :     fun emitValue _ = ()
43 :     fun sizeOf _ = 0
44 :     fun adjustLabels _ = true
45 :     end
46 :    
47 :    
48 :    
49 : mrainey 3009 structure C = X86Cells
50 :     structure Cells = C
51 :    
52 :     (*
53 :     * Client defined extensions. None for now.
54 :     * You'll need this only if you need to extend the set of MLTREE operators
55 :     *)
56 :     structure UserExtension =
57 :     struct
58 :    
59 :     type ('s,'r,'f,'c) sx = ('s,'r,'f,'c) X86InstrExt.sext
60 :     type ('s,'r,'f,'c) rx = unit
61 :     type ('s,'r,'f,'c) fx = unit
62 :     type ('s,'r,'f,'c) ccx = unit
63 :    
64 :     end
65 :    
66 :     (*
67 :     * This module controls how we handle user extensions. Since we don't
68 :     * have any yet. This is just a bunch of dummy routines.
69 :     *)
70 :     functor UserMLTreeExtComp
71 :     ( structure I : X86INSTR where T.Extension = UserExtension
72 :     structure TS : MLTREE_STREAM where T = I.T
73 :     structure CFG : CONTROL_FLOW_GRAPH where I = I and P = TS.S.P
74 :     ) : MLTREE_EXTENSION_COMP =
75 :     struct
76 :     structure T = TS.T
77 :     structure TS = TS
78 :     structure I = I
79 :     structure CFG = CFG
80 :     structure C = I.C
81 :    
82 :     structure CompInstrExt = X86CompInstrExt (
83 :     structure I = I
84 :     structure TS = TS
85 :     structure CFG = CFG)
86 :    
87 :     type reducer =
88 :     (I.instruction,C.cellset,I.operand,I.addressing_mode,CFG.cfg) TS.reducer
89 :    
90 :     val compileSext = CompInstrExt.compileSext
91 :    
92 : mrainey 3054 fun compileRext _ = raise Fail "CompExtFn.compileRext"
93 :     fun compileFext _ = raise Fail "CompExtFn.compileFext"
94 :     fun compileCCext _ = raise Fail "CompExtFn.compileCCext"
95 : mrainey 3009
96 :     end
97 :    
98 :     structure X86MLTree =
99 :     MLTreeF (structure Constant = UserConst
100 :     structure Region = UserRegion
101 :     structure Extension = UserExtension)
102 :    
103 :     structure X86MLTreeEval =
104 :     MLTreeEval (structure T = X86MLTree
105 :     fun eq _ _ = false
106 :     val eqRext = eq val eqFext = eq
107 :     val eqCCext = eq val eqSext = eq)
108 :    
109 :     structure X86GasPseudoOps =
110 :     X86GasPseudoOps(structure T=X86MLTree
111 :     structure MLTreeEval=X86MLTreeEval)
112 :    
113 : mrainey 3064
114 : mrainey 3009 functor X86PseudoOpsFn (
115 :     structure T : MLTREE
116 :     structure MLTreeEval : MLTREE_EVAL where T = T
117 :     ) : PSEUDO_OPS_BASIS = X86GasPseudoOps (
118 :     structure T = T
119 :     structure MLTreeEval = MLTreeEval)
120 :    
121 : mrainey 3064 (*
122 : mrainey 3009 functor X86PseudoOpsFn (
123 :     structure T : MLTREE
124 :     structure MLTreeEval : MLTREE_EVAL where T = T
125 :     ) : PSEUDO_OPS_BASIS = X86DarwinPseudoOps (
126 :     structure T = T
127 :     structure MLTreeEval = MLTreeEval)
128 : mrainey 3064 *)
129 : mrainey 3009
130 : mrainey 3063
131 : mrainey 3009 structure X86PseudoOps = X86PseudoOpsFn(
132 :     structure T = X86MLTree
133 :     structure MLTreeEval = X86MLTreeEval)
134 :    
135 :     structure PseudoOps =
136 :     struct
137 :    
138 :     structure Client =
139 :     struct
140 :     structure AsmPseudoOps = X86PseudoOps
141 :     type pseudo_op = unit
142 :    
143 :     fun toString () = ""
144 :    
145 :     fun emitValue _ = raise Fail "todo"
146 :     fun sizeOf _ = raise Fail "todo"
147 :     fun adjustLabels _ = raise Fail "todo"
148 :     end (* Client *)
149 :    
150 :     structure PseudoOps = PseudoOps (structure Client = Client)
151 :     end
152 :    
153 :     structure X86Stream = InstructionStream(PseudoOps.PseudoOps)
154 :     structure X86Instr = X86Instr (X86MLTree)
155 :     structure X86Shuffle = X86Shuffle(X86Instr)
156 :    
157 :     structure X86MLTreeHash =
158 :     MLTreeHash (structure T = X86MLTree
159 :     fun h _ _ = 0w0
160 :     val hashRext = h val hashFext = h
161 :     val hashCCext = h val hashSext = h)
162 :    
163 :    
164 :     functor X86MemRegs(X86Instr:X86INSTR) = struct
165 :     structure I = X86Instr
166 :     structure CB = CellsBasis
167 :    
168 :     fun memReg{reg, base} = raise Fail ""
169 :     end
170 :    
171 :     structure X86MemRegs = X86MemRegs(X86Instr)
172 :    
173 :     structure X86Asm = X86AsmEmitter
174 :     (structure Instr = X86Instr
175 :     structure S = X86Stream
176 :     val memRegBase = NONE
177 :     structure MemRegs = X86MemRegs
178 :     structure MLTreeEval = X86MLTreeEval
179 :     structure Shuffle = X86Shuffle
180 :     )
181 :    
182 :     structure X86InsnProps = X86Props
183 :     (structure Instr = X86Instr
184 :     structure MLTreeHash = X86MLTreeHash
185 :     structure MLTreeEval = X86MLTreeEval)
186 :    
187 :     structure X86CFG = ControlFlowGraph (
188 :     structure I = X86Asm.I
189 :     structure GraphImpl = DirectedGraph
190 :     structure InsnProps = X86InsnProps
191 :     structure Asm = X86Asm)
192 :    
193 :     structure X86MLTStream = MLTreeStream (
194 :     structure T = X86MLTree
195 :     structure S = X86Stream)
196 :    
197 :     structure CompInstrExt = X86CompInstrExt (
198 :     structure I = X86Instr
199 :     structure TS = X86MLTStream
200 :     structure CFG = X86CFG)
201 :    
202 :     structure X86MTC = struct
203 :     structure T = X86MLTree
204 :     structure TS = X86MLTStream
205 :     structure I = X86Instr
206 :     structure CFG = X86CFG
207 :     structure C = I.C
208 :     type reducer =
209 :     (I.instruction,C.cellset,I.operand,I.addressing_mode,X86CFG.cfg) TS.reducer
210 :     fun unimplemented _ = MLRiscErrorMsg.impossible "UserMLTreeExtComp"
211 :     val compileSext = CompInstrExt.compileSext
212 :     val compileRext = unimplemented
213 :     val compileFext = unimplemented
214 :     val compileCCext = unimplemented
215 :    
216 :     structure X86MLTreeUtils : MLTREE_UTILS =
217 :     struct
218 :     structure T = X86MLTree
219 :     structure IX = X86InstrExt
220 :     structure U = MLTreeUtils (
221 :     structure T = T
222 :     fun hashSext _ _ = 0w0
223 :     fun hashRext _ _ = 0w0
224 :     fun hashFext _ _ = 0w0
225 :     fun hashCCext _ _ = 0w0
226 :     fun eqSext _ _ = raise Fail "eqSext"
227 :     fun eqRext _ _ = raise Fail "eqRext"
228 :     fun eqFext _ _ = raise Fail "eqFext"
229 :     fun eqCCext _ _ = raise Fail "eqCCext"
230 :     fun showSext (prt : T.printer) ext = raise Fail "todo"
231 :     fun showRext _ _ = raise Fail "showRext"
232 :     fun showFext _ _ = raise Fail "showFext"
233 :     fun showCCext _ _ = raise Fail "showCCext")
234 :     open U
235 :     end
236 :     end
237 :    
238 :     structure X86 = X86 (
239 :     structure X86Instr = X86Instr
240 :     structure MLTreeUtils = X86MTC.X86MLTreeUtils
241 :     structure ExtensionComp = X86MTC
242 :     structure MLTreeStream = X86MLTStream
243 :     datatype arch = Pentium | PentiumPro | PentiumII | PentiumIII
244 :     val arch = ref Pentium (* Lowest common denominator *)
245 :    
246 :     fun cvti2f _ = raise Fail ""
247 : mrainey 3054 val fast_floating_point = fast_floating_point
248 : mrainey 3009 )
249 :    
250 :     structure X86Emit = CFGEmit (
251 :     structure CFG = X86CFG
252 :     structure E = X86Asm)
253 :    
254 :    
255 :     structure X86FlowGraph = BuildFlowgraph
256 :     (structure Props = X86InsnProps
257 :     structure Stream = X86Stream
258 :     structure CFG = X86CFG)
259 :    
260 :     structure X86Expand = CFGExpandCopies (structure CFG=X86CFG
261 :     structure Shuffle = X86Shuffle)
262 :     structure X86BlockPlacement = DefaultBlockPlacement(X86CFG)
263 :    
264 :     structure RASpill = RASpillWithRenaming (
265 :     structure Asm = X86Asm
266 :     structure InsnProps = X86InsnProps
267 :     val max_dist = ref 4
268 :     val keep_multiple_values = ref false)
269 :    
270 :     structure C = X86Cells
271 :    
272 :     datatype spill_operand_kind = SPILL_LOC
273 :     | CONST_VAL
274 :    
275 :     datatype ra_phase = SPILL_PROPAGATION
276 :     | SPILL_COLORING
277 :    
278 :     fun upto(from, to) = if from>to then [] else from::(upto (from+1,to))
279 :     infix upto
280 :    
281 :     structure CB = CellsBasis
282 : mrainey 3064 structure I = X86Instr
283 : mrainey 3009
284 :     structure IntRA =
285 :     struct
286 :     val dedicated = [C.esp, C.ebp]
287 :     val allRegs = C.Regs CellsBasis.GP {from=0, to=7, step=1}
288 :     val allRegsSet = foldl C.addReg C.empty allRegs
289 :     val avail = let
290 :     val availSet = List.foldl C.rmvReg allRegsSet dedicated
291 :     in
292 :     C.getReg availSet
293 :     end
294 :     fun spillInit _ = ()
295 :     val memRegs = C.Regs CB.GP {from=8,to=31,step=1}
296 : mrainey 3064 fun spillLoc {info=frame, an, cell, id=loc} = let
297 :     val spillLoc = ~(loc*4)
298 :     val opnd = I.Displace {
299 :     base = C.ebp,
300 :     disp = I.Immed (Int32.fromInt spillLoc),
301 :     mem = ()
302 :     }
303 :     in
304 :     {opnd = opnd, kind = SPILL_LOC}
305 :     end
306 : mrainey 3009 val phases = [SPILL_PROPAGATION, SPILL_COLORING]
307 :     end (* IntRA *)
308 :    
309 :     structure FloatRA =
310 :     struct
311 :     val avail = List.map C.FPReg (0 upto 31)
312 :     val dedicated = []
313 :     fun spillInit _ = ()
314 :     val fastMemRegs = C.Regs CB.FP {from=8, to=31, step=1}
315 :     val fastPhases = [SPILL_PROPAGATION,SPILL_COLORING]
316 :     val memRegs = []
317 :     fun spillLoc (info, ans, id) = raise Fail ""
318 :     val phases = [SPILL_PROPAGATION]
319 :     end (* FloatRA *)
320 :    
321 :     (* register allocation *)
322 :     structure X86RA = X86RA (
323 :     structure I = X86Instr
324 :     structure InsnProps = X86InsnProps
325 :     structure CFG = X86CFG
326 :     structure Asm = X86Asm
327 :     structure SpillHeur = ChowHennessySpillHeur
328 :     structure Spill = RASpill
329 :     structure Props = X86InsnProps
330 :     type spill_info = unit
331 :     fun beforeRA (Graph.GRAPH graph) = ()
332 :     datatype spillOperandKind = datatype spill_operand_kind
333 :     datatype raPhase = datatype ra_phase
334 : mrainey 3054 val fast_floating_point = fast_floating_point
335 : mrainey 3009 structure Int = IntRA
336 :     structure Float = FloatRA)
337 :    
338 :     structure X86Expand = CFGExpandCopies (
339 :     structure CFG=X86CFG
340 :     structure Shuffle = X86Shuffle)
341 :    
342 :    
343 :     structure CCalls = IA32SVIDFn (
344 :     structure T = X86MLTree
345 :     fun ix x = x
346 : mrainey 3054 val fast_floating_point = fast_floating_point
347 : mrainey 3009 val abi = "")
348 :    
349 :    
350 :     structure C = X86Instr.C
351 :     structure T = X86MLTree
352 :     structure CFG = X86CFG
353 :     structure FlowGraph = X86FlowGraph
354 : mrainey 3049 structure Vararg = IA32VarargCCallFn(
355 :     structure T = X86MLTree
356 :     fun ix x = x
357 : mrainey 3054 val fast_floating_point = fast_floating_point
358 :     val abi = ""
359 :     fun push e = T.EXT(X86InstrExt.PUSHL e)
360 :     val leave = T.EXT X86InstrExt.LEAVE
361 :     )
362 : mrainey 3009
363 : mrainey 3049 structure TestSA =
364 : mrainey 3009 struct
365 :    
366 : mrainey 3054 val wordTy = 32
367 : mrainey 3009
368 : mrainey 3054 fun gen (functionName, stms, result) = let
369 : mrainey 3009 val insnStrm = FlowGraph.build()
370 :     val stream as X86Stream.STREAM
371 :     { beginCluster, (* start a cluster *)
372 :     endCluster, (* end a cluster *)
373 :     emit, (* emit MLTREE stm *)
374 :     defineLabel, (* define a local label *)
375 :     entryLabel, (* define an external entry *)
376 :     exitBlock, (* mark the end of a procedure *)
377 :     pseudoOp, (* emit a pseudo op *)
378 :     annotation, (* add an annotation *)
379 :     ... } =
380 :     X86.selectInstructions insnStrm
381 : mrainey 3054 fun doit () = (
382 : mrainey 3009 beginCluster 0; (* start a new cluster *)
383 :     pseudoOp PseudoOpsBasisTyp.TEXT;
384 :     pseudoOp (PseudoOpsBasisTyp.EXPORT [functionName]);
385 :     entryLabel functionName; (* define the entry label *)
386 :     List.app emit stms; (* emit all the statements *)
387 :     exitBlock result;
388 :     endCluster [])
389 :     val cfg = doit ()
390 :     val cfg = X86RA.run cfg
391 :     val cfg = X86Expand.run cfg
392 : mrainey 3054 in
393 :     (cfg, stream)
394 :     end (* gen *)
395 :    
396 :     fun codegen (functionName, target, proto, initStms, args) = let
397 :     val [functionName, target] = List.map Label.global [functionName, target]
398 :    
399 :     (* construct the C call *)
400 :     val {result, callseq} = CCalls.genCall {
401 :     name=T.LABEL target,
402 :     paramAlloc=fn _ => false,
403 :     structRet=fn _ => T.REG (32, Cells.eax),
404 :     saveRestoreDedicated=fn _ => {save=[], restore=[]},
405 :     callComment=NONE,
406 :     proto=proto,
407 :     args=args}
408 :    
409 :     fun wordLit i = T.LI (T.I.fromInt (wordTy, i))
410 :    
411 :     val stms = List.concat [
412 :     [T.EXT(X86InstrExt.PUSHL(T.REG(32, Cells.ebp))),
413 :     T.COPY (wordTy, [Cells.ebp], [Cells.esp])],
414 :     initStms,
415 :     callseq,
416 :     [T.EXT(X86InstrExt.LEAVE)],
417 :     [T.RET []]]
418 :    
419 :    
420 : mrainey 3009 in
421 : mrainey 3054 gen(functionName, stms, result)
422 :     end (* codegen *)
423 : mrainey 3009
424 :     fun dumpOutput (cfg, stream) = let
425 :     val (cfg as Graph.GRAPH graph, blocks) =
426 :     X86BlockPlacement.blockPlacement cfg
427 :     val CFG.INFO{annotations=an, data, decls, ...} = #graph_info graph
428 :     in
429 :     X86Emit.asmEmit (cfg, blocks)
430 :     end (* dumpOutput *)
431 :    
432 : mrainey 3054 fun vararg _ = let
433 :     val _ = Label.reset()
434 :     val (lab, stms) = Vararg.genVarargs()
435 :     val asmOutStrm = TextIO.openOut "mlrisc.s"
436 :     fun doit () = dumpOutput(gen(lab, stms, [T.GPR (T.REG (wordTy, C.eax))]))
437 :     val _ = AsmStream.withStream asmOutStrm doit ()
438 :     val _ = TextIO.closeOut asmOutStrm
439 :     in
440 :     0
441 :     end
442 :    
443 : mrainey 3009 end
444 :    
445 :     (* machine-specific data *)
446 :     val wordTy = 32
447 :     val wordSzB = wordTy div 8
448 : mrainey 3010 fun li i = T.LI (T.I.fromInt (wordTy, i))
449 :     val param0 = T.LOAD(wordTy, T.ADD(32, li 8, T.REG(32,Cells.ebp)), ())
450 : mrainey 3009
451 :     structure CSizes = IA32CSizes
452 :    

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