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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3051 - (view) (download)

1 : mrainey 3009 (*
2 : mrainey 3010 * User defined constant type. Dummy for now.
3 :     * In practice, you'll want to use this type to implement constants with
4 :     * values that cannot be determined until final code generation, e.g.
5 :     * stack frame offset.
6 :     *)
7 :     structure UserConst =
8 :     struct
9 :     type const = unit
10 :     fun toString() = ""
11 :     fun hash() = 0w0
12 :     fun valueOf _ = 0
13 :     fun == _ = true
14 :     end
15 :    
16 :     (*
17 :     * User defined datatype for representing aliasing. Dummy for now.
18 :     * You'll need this to represent aliasing information.
19 :     *)
20 :     structure UserRegion =
21 :     struct
22 :     type region = unit
23 :     fun toString () = ""
24 :     val memory = ()
25 :     val stack = ()
26 :     val readonly = ()
27 :     val spill = ()
28 :     end
29 :    
30 :     (*
31 :     * User defined datatype for representing pseudo assembly operators.
32 :     * Dummy for now.
33 :     *
34 :     * You'll need this to represent assembler directives.
35 :     *)
36 :     structure UserPseudoOps =
37 :     struct
38 :     type pseudo_op = unit
39 :     fun toString () = ""
40 :     fun emitValue _ = ()
41 :     fun sizeOf _ = 0
42 :     fun adjustLabels _ = true
43 :     end
44 :    
45 :    
46 :    
47 :     (*
48 : mrainey 3009 * Client defined extensions. None for now.
49 :     * You'll need this only if you need to extend the set of MLTREE operators
50 :     *)
51 :     structure UserExtension =
52 :     struct
53 :    
54 :     type ('s,'r,'f,'c) sx = ('s,'r,'f,'c) AMD64InstrExt.sext
55 :     type ('s,'r,'f,'c) rx = unit
56 :     type ('s,'r,'f,'c) fx = unit
57 :     type ('s,'r,'f,'c) ccx = unit
58 :    
59 :     end
60 :    
61 :     (*
62 :     * This module controls how we handle user extensions. Since we don't
63 :     * have any yet. This is just a bunch of dummy routines.
64 :     *)
65 :     functor UserMLTreeExtComp
66 :     ( structure I : AMD64INSTR where T.Extension = UserExtension
67 :     structure TS : MLTREE_STREAM where T = I.T
68 :     structure CFG : CONTROL_FLOW_GRAPH where I = I and P = TS.S.P
69 :     ) : MLTREE_EXTENSION_COMP =
70 :     struct
71 :     structure T = TS.T
72 :     structure TS = TS
73 :     structure I = I
74 :     structure CFG = CFG
75 :     structure C = I.C
76 :    
77 :     structure CompInstrExt = AMD64CompInstrExt (
78 :     structure I = I
79 :     structure TS = TS
80 :     structure CFG = CFG)
81 :    
82 :     type reducer =
83 :     (I.instruction,C.cellset,I.operand,I.addressing_mode,CFG.cfg) TS.reducer
84 :    
85 :     val compileSext = CompInstrExt.compileSext
86 :    
87 :     fun compileRext _ = raise Fail "AMD64CompExtFn.compileRext"
88 :     fun compileFext _ = raise Fail "AMD64CompExtFn.compileFext"
89 :     fun compileCCext _ = raise Fail "AMD64CompExtFn.compileCCext"
90 :    
91 :     end
92 :    
93 : mrainey 2990 val floats16ByteAligned = true
94 :    
95 :     structure AMD64MLTree =
96 :     MLTreeF (structure Constant = UserConst
97 :     structure Region = UserRegion
98 :     structure Extension = UserExtension)
99 :    
100 :     structure AMD64MLTreeEval =
101 :     MLTreeEval (structure T = AMD64MLTree
102 :     fun eq _ _ = false
103 :     val eqRext = eq val eqFext = eq
104 :     val eqCCext = eq val eqSext = eq)
105 :    
106 :     (*
107 :     structure AMD64PseudoOps =
108 :     struct
109 :     structure Client =
110 :     struct
111 :     datatype pseudo_op_ext = COMM of (Label.label * int)
112 :     structure AsmPseudoOps = AMD64GasPseudoOps (
113 :     structure T = AMD64MLTree
114 :     structure MLTreeEval = AMD64MLTreeEval)
115 :     type pseudo_op = pseudo_op_ext
116 :     fun toString (COMM(lab, sz)) = concat[
117 :     "\t.comm\t"(*, P.lexpToString(P.T.LABEL lab)*),
118 :     ",", Int.toString sz]
119 :     fun emitValue {pOp, loc, emit} = raise Fail "emitValue"
120 :     fun sizeOf _ = 0
121 :     fun adjustLabels _ = false
122 :     end (* Client *)
123 :    
124 :     structure T = AMD64MLTree
125 :     type pseudo_op = (T.labexp, Client.pseudo_op) PseudoOpsBasisTyp.pseudo_op
126 :     fun toString _ = ""
127 :     fun emitValue _ = ()
128 :     fun sizeOf _ = 0
129 :     fun adjustLabels _ = false
130 :     end (* AMD64PseudoOps *)
131 :     *)
132 :    
133 : mrainey 3051
134 : mrainey 2990 functor AMD64PseudoOpsFn (
135 :     structure T : MLTREE
136 :     structure MLTreeEval : MLTREE_EVAL where T = T
137 : mrainey 2993 ) : PSEUDO_OPS_BASIS = AMD64GasPseudoOps (
138 :     structure T = T
139 :     structure MLTreeEval = MLTreeEval)
140 :    
141 : mrainey 3051 (*
142 : mrainey 2993 functor AMD64PseudoOpsFn (
143 :     structure T : MLTREE
144 :     structure MLTreeEval : MLTREE_EVAL where T = T
145 : mrainey 2990 ) : PSEUDO_OPS_BASIS = AMD64DarwinPseudoOps (
146 :     structure T = T
147 :     structure MLTreeEval = MLTreeEval)
148 : mrainey 3051 *)
149 : mrainey 2990
150 :     structure AMD64PseudoOps = AMD64PseudoOpsFn(
151 :     structure T = AMD64MLTree
152 :     structure MLTreeEval = AMD64MLTreeEval)
153 :    
154 :     structure PseudoOps =
155 :     struct
156 :    
157 :     structure Client =
158 :     struct
159 :     structure AsmPseudoOps = AMD64PseudoOps
160 :     type pseudo_op = unit
161 :    
162 :     fun toString () = ""
163 :    
164 :     fun emitValue _ = raise Fail "todo"
165 :     fun sizeOf _ = raise Fail "todo"
166 :     fun adjustLabels _ = raise Fail "todo"
167 :     end (* Client *)
168 :    
169 :     structure PseudoOps = PseudoOps (structure Client = Client)
170 :     end
171 :    
172 :     structure AMD64Stream = InstructionStream(PseudoOps.PseudoOps)
173 :     structure AMD64Instr = AMD64Instr (AMD64MLTree)
174 :     structure AMD64Shuffle = AMD64Shuffle(AMD64Instr)
175 :    
176 :     structure AMD64MLTreeHash =
177 :     MLTreeHash (structure T = AMD64MLTree
178 :     fun h _ _ = 0w0
179 :     val hashRext = h val hashFext = h
180 :     val hashCCext = h val hashSext = h)
181 :    
182 :     structure AMD64Asm = AMD64AsmEmitter
183 :     (structure Instr = AMD64Instr
184 :     structure S = AMD64Stream
185 :     structure MLTreeEval = AMD64MLTreeEval
186 :     structure Shuffle = AMD64Shuffle
187 :     )
188 :    
189 :     structure AMD64InsnProps = AMD64Props
190 :     (structure Instr = AMD64Instr
191 :     structure MLTreeHash = AMD64MLTreeHash
192 :     structure MLTreeEval = AMD64MLTreeEval)
193 :    
194 :     structure AMD64CFG = ControlFlowGraph (
195 :     structure I = AMD64Asm.I
196 :     structure GraphImpl = DirectedGraph
197 :     structure InsnProps = AMD64InsnProps
198 :     structure Asm = AMD64Asm)
199 :    
200 :     structure AMD64MLTStream = MLTreeStream (
201 :     structure T = AMD64MLTree
202 :     structure S = AMD64Stream)
203 :    
204 :     structure CompInstrExt = AMD64CompInstrExt (
205 :     structure I = AMD64Instr
206 :     structure TS = AMD64MLTStream
207 :     structure CFG = AMD64CFG)
208 :    
209 :     structure AMD64MTC = struct
210 :     structure T = AMD64MLTree
211 :     structure TS = AMD64MLTStream
212 :     structure I = AMD64Instr
213 :     structure CFG = AMD64CFG
214 :     structure C = I.C
215 :     type reducer =
216 :     (I.instruction,C.cellset,I.operand,I.addressing_mode,AMD64CFG.cfg) TS.reducer
217 :     fun unimplemented _ = MLRiscErrorMsg.impossible "UserMLTreeExtComp"
218 :     val compileSext = CompInstrExt.compileSext
219 :     val compileRext = unimplemented
220 :     val compileFext = unimplemented
221 :     val compileCCext = unimplemented
222 :    
223 :     structure AMD64MLTreeUtils : MLTREE_UTILS =
224 :     struct
225 :     structure T = AMD64MLTree
226 :     structure IX = AMD64InstrExt
227 :     structure U = MLTreeUtils (
228 :     structure T = T
229 :     fun hashSext _ _ = 0w0
230 :     fun hashRext _ _ = 0w0
231 :     fun hashFext _ _ = 0w0
232 :     fun hashCCext _ _ = 0w0
233 :     fun eqSext _ _ = raise Fail "eqSext"
234 :     fun eqRext _ _ = raise Fail "eqRext"
235 :     fun eqFext _ _ = raise Fail "eqFext"
236 :     fun eqCCext _ _ = raise Fail "eqCCext"
237 :     fun showSext (prt : T.printer) ext = raise Fail "todo"
238 :     fun showRext _ _ = raise Fail "showRext"
239 :     fun showFext _ _ = raise Fail "showFext"
240 :     fun showCCext _ _ = raise Fail "showCCext")
241 :     open U
242 :     end
243 :     end
244 :    
245 :     structure AMD64 = AMD64Gen (
246 :     structure I = AMD64Instr
247 :     structure MLTreeUtils = AMD64MTC.AMD64MLTreeUtils
248 :     structure ExtensionComp = AMD64MTC
249 :     val floats16ByteAligned = floats16ByteAligned
250 :     fun signBit _ = raise Fail "todo"
251 :     fun negateSignBit _ = raise Fail "todo"
252 :     )
253 :    
254 :     structure AMD64Emit = CFGEmit (
255 :     structure CFG = AMD64CFG
256 :     structure E = AMD64Asm)
257 :    
258 :    
259 :     structure AMD64FlowGraph = BuildFlowgraph
260 :     (structure Props = AMD64InsnProps
261 :     structure Stream = AMD64Stream
262 :     structure CFG = AMD64CFG)
263 :    
264 :     structure AMD64Expand = CFGExpandCopies (structure CFG=AMD64CFG
265 :     structure Shuffle = AMD64Shuffle)
266 :     structure AMD64BlockPlacement = DefaultBlockPlacement(AMD64CFG)
267 :    
268 :     structure RASpill = RASpillWithRenaming (
269 :     structure Asm = AMD64Asm
270 :     structure InsnProps = AMD64InsnProps
271 :     val max_dist = ref 4
272 :     val keep_multiple_values = ref false)
273 :    
274 :     structure C = AMD64Cells
275 :    
276 :     datatype spill_operand_kind = SPILL_LOC
277 :     | CONST_VAL
278 :    
279 :     datatype ra_phase = SPILL_PROPAGATION
280 :     | SPILL_COLORING
281 :    
282 :     structure IntRA =
283 :     struct
284 :     val dedicated = [C.rsp, C.rbp]
285 :     val allRegs = C.Regs CellsBasis.GP {from=0, to=15, step=1}
286 :     val allRegsSet = foldl C.addReg C.empty allRegs
287 :     val avail = let
288 :     val availSet = foldl C.rmvReg allRegsSet dedicated
289 :     in
290 :     C.getReg availSet
291 :     end
292 :     fun spillInit _ = ()
293 :     fun spillLoc {info=frame, an, cell, id=loc} =
294 : mrainey 2995 raise Fail ""
295 :     (* {opnd = AMD64Instr.Immed 0, kind = SPILL_LOC}*)
296 : mrainey 2990 val phases = [SPILL_PROPAGATION, SPILL_COLORING]
297 :     end (* IntRA *)
298 :    
299 :     structure FloatRA =
300 :     struct
301 :     val avail = C.Regs CellsBasis.FP {from=0, to=15, step=1}
302 :     val dedicated = []
303 :     fun spillInit _ = ()
304 : mrainey 2995 fun spillLoc (info, ans, id) = raise Fail ""
305 : mrainey 2990 val phases = [SPILL_PROPAGATION, SPILL_COLORING]
306 :     end (* FloatRA *)
307 :    
308 :     (* register allocation *)
309 :     structure AMD64RA = AMD64RegAlloc (
310 :     structure I = AMD64Instr
311 :     structure CFG = AMD64CFG
312 :     structure Asm = AMD64Asm
313 :     structure SpillHeur = ChowHennessySpillHeur
314 :     structure Spill = RASpill
315 :     structure Props = AMD64InsnProps
316 :     val floats16ByteAligned = floats16ByteAligned
317 :     type spill_info = unit
318 :     fun beforeRA (Graph.GRAPH graph) = ()
319 :     datatype spill_operand_kind = datatype spill_operand_kind
320 :     datatype ra_phase = datatype ra_phase
321 :     structure Int = IntRA
322 :     structure Float = FloatRA)
323 :    
324 :     structure AMD64Expand = CFGExpandCopies (
325 :     structure CFG=AMD64CFG
326 :     structure Shuffle = AMD64Shuffle)
327 :    
328 : mrainey 3038 structure CCalls = AMD64SVIDFn (
329 : mrainey 3037 structure T = AMD64MLTree)
330 :    
331 : mrainey 3038 (*
332 : mrainey 2990 structure CCalls = AMD64SVID (
333 :     structure T = AMD64MLTree
334 :     val frameAlign = 16)
335 : mrainey 3038 *)
336 : mrainey 3000
337 :     structure RA2 =
338 :     RISC_RA
339 :     (structure I = AMD64Instr
340 :     structure Asm = AMD64Asm
341 :     structure CFG = AMD64CFG
342 :     structure InsnProps = AMD64InsnProps
343 :     structure Rewrite =
344 :     struct
345 :     structure I = AMD64Instr
346 : mrainey 3008 structure C=I.C
347 :     structure CB = CellsBasis
348 :     fun error msg = MLRiscErrorMsg.error("X86Rewrite", msg)
349 :    
350 :     fun operand (rs,rt) opnd =
351 :     (case opnd
352 :     of I.Direct (sz, r) => if CB.sameColor(r,rs) then I.Direct (sz, rt) else opnd
353 :     | I.Displace{base, disp, mem} =>
354 :     if CB.sameColor(base,rs) then I.Displace{base=rt, disp=disp, mem=mem}
355 :     else opnd
356 :     | I.Indexed{base as SOME b, index, scale, disp, mem} => let
357 :     val base'= if CB.sameColor(b,rs) then SOME rt else base
358 :     val index'=if CB.sameColor(index,rs) then rt else index
359 :     in I.Indexed{base=base', index=index', scale=scale, disp=disp, mem=mem}
360 :     end
361 :     | I.Indexed{base, index, scale, disp, mem=mem} =>
362 :     if CB.sameColor(index,rs) then
363 :     I.Indexed{base=base, index=rt, scale=scale, disp=disp, mem=mem}
364 :     else opnd
365 :     | _ => opnd
366 :     (*end case*))
367 :    
368 :    
369 :     fun rewriteDef (instr, rs, rt) = let
370 :     fun operand(opnd as I.Direct (sz, r)) =
371 :     if CB.sameColor(r,rs) then I.Direct (sz, rt) else opnd
372 :     | operand _ = error "operand: not I.Direct"
373 :     fun replace r = if CB.sameColor(r,rs) then rt else r
374 :     fun rewriteX86Def(instr) =
375 :     (case instr
376 :     of I.CALL{opnd, defs, uses, return, cutsTo, mem, pops} =>
377 :     I.CALL{opnd=opnd, cutsTo=cutsTo,
378 :     return=CB.CellSet.map {from=rs,to=rt} return, pops=pops,
379 :     defs=CB.CellSet.map {from=rs,to=rt} defs, uses=uses, mem=mem}
380 :     | I.MOVE{mvOp, src, dst} => I.MOVE{mvOp=mvOp, src=src, dst=operand dst}
381 :     | I.LEAL{r32, addr} => I.LEAL{r32=replace r32, addr=addr}
382 :     | I.LEAQ{r64, addr} => I.LEAQ{r64=replace r64, addr=addr}
383 :     | I.BINARY{binOp, src, dst} =>
384 :     I.BINARY{binOp=binOp, src=src, dst=operand dst}
385 :     | I.SHIFT{shiftOp, src, dst, count} =>
386 :     I.SHIFT{shiftOp=shiftOp, src=src, count=count, dst=operand dst}
387 :     | I.UNARY{unOp, opnd} => I.UNARY{unOp=unOp, opnd=operand opnd}
388 :     | I.SET{cond, opnd} => I.SET{cond=cond, opnd=operand opnd}
389 :     | _ => instr
390 :     (* end case *))
391 :    
392 :     fun f (I.ANNOTATION{a,i}) =
393 :     I.ANNOTATION{i=rewriteDef(i,rs,rt),
394 :     a=(case a of
395 :     CB.DEF_USE{cellkind=CB.GP,defs,uses} =>
396 :     CB.DEF_USE{cellkind=CB.GP,uses=uses,
397 :     defs=map replace defs}
398 :     | _ => a)}
399 :     | f (I.INSTR i) = I.INSTR(rewriteX86Def(i))
400 :     | f (I.COPY{k as CB.GP, sz, dst, src, tmp}) =
401 :     I.COPY{k=k, sz=sz, dst=map replace dst, src=src, tmp=tmp}
402 :     in
403 :     f(instr)
404 :     end
405 :    
406 :    
407 :     fun rewriteUse (instr, rs, rt) = let
408 :     val operand = operand (rs, rt)
409 :     fun replace r = if CB.sameColor(r,rs) then rt else r
410 :     fun rewrite instr = (case instr
411 :     of I.JMP(opnd, labs) => I.JMP(operand opnd, labs)
412 :     | I.JCC{cond, opnd} => I.JCC{cond=cond, opnd = operand opnd}
413 :     | I.CALL{opnd, defs, uses, return, cutsTo, mem, pops} =>
414 :     I.CALL{opnd=operand opnd, defs=defs, return=return,
415 :     uses=CB.CellSet.map {from=rs,to=rt} uses, cutsTo=cutsTo,
416 :     mem=mem, pops=pops}
417 :     | I.MOVE{mvOp, src, dst as I.Direct _} =>
418 :     I.MOVE{mvOp=mvOp, src=operand src, dst=dst}
419 :     | I.MOVE{mvOp, src, dst} =>
420 :     I.MOVE{mvOp=mvOp, src=operand src, dst=operand dst}
421 :     | I.LEAL{r32, addr} => I.LEAL{r32=r32, addr=operand addr}
422 :     | I.LEAQ{r64, addr} => I.LEAQ{r64=r64, addr=operand addr}
423 :     | I.CMPL{lsrc, rsrc} => I.CMPL{lsrc=operand lsrc, rsrc=operand rsrc}
424 :     | I.CMPW{lsrc, rsrc} => I.CMPW{lsrc=operand lsrc, rsrc=operand rsrc}
425 :     | I.CMPB{lsrc, rsrc} => I.CMPB{lsrc=operand lsrc, rsrc=operand rsrc}
426 :     | I.TESTL{lsrc, rsrc} => I.TESTL{lsrc=operand lsrc, rsrc=operand rsrc}
427 :     | I.TESTW{lsrc, rsrc} => I.TESTW{lsrc=operand lsrc, rsrc=operand rsrc}
428 :     | I.TESTB{lsrc, rsrc} => I.TESTB{lsrc=operand lsrc, rsrc=operand rsrc}
429 :     | I.BITOP{bitOp, lsrc, rsrc} =>
430 :     I.BITOP{bitOp=bitOp, lsrc=operand lsrc, rsrc=operand rsrc}
431 :     | I.BINARY{binOp, src, dst} =>
432 :     I.BINARY{binOp=binOp, src=operand src, dst=operand dst}
433 :     | I.SHIFT{shiftOp, src, dst, count} =>
434 :     I.SHIFT{shiftOp=shiftOp, src=operand src, dst=operand dst,
435 :     count=operand src}
436 :     (* end case *))
437 :    
438 :     fun f(I.ANNOTATION{a,i}) =
439 :     I.ANNOTATION{i=rewriteUse(i, rs, rt),
440 :     a = case a of
441 :     CB.DEF_USE{cellkind=CB.GP,defs,uses} =>
442 :     CB.DEF_USE{cellkind=CB.GP,uses=map replace uses,
443 :     defs=defs}
444 :     | _ => a}
445 :     | f(I.INSTR i) = I.INSTR(rewrite(i))
446 :     | f(I.COPY{k as CB.GP, sz, dst, src, tmp}) =
447 :     I.COPY{k=k, sz=sz, dst=dst, src=List.map replace src, tmp=tmp}
448 :     in
449 :     f (instr:I.instruction)
450 :     end
451 :    
452 :    
453 : mrainey 3000 fun frewriteDef _ = raise Fail ""
454 :     fun frewriteUse _ = raise Fail ""
455 :     end
456 :     structure SpillInstr = AMD64SpillInstr (
457 :     structure I = I
458 :     structure Props = AMD64InsnProps
459 :     val floats16ByteAligned = true)
460 :     structure SpillHeur = ChaitinSpillHeur
461 :     structure Spill = RASpill (structure InsnProps = AMD64InsnProps
462 :     structure Asm = AMD64Asm)
463 :    
464 :     datatype spillOperandKind = SPILL_LOC | CONST_VAL
465 :     type spill_info = unit
466 : mrainey 3008 fun beforeRA _ = ()
467 : mrainey 3000
468 :     val architecture = "amd64"
469 :     fun pure _ = true
470 :    
471 :     structure Int =
472 :     struct
473 : mrainey 3042 val allRegs = C.Regs CellsBasis.GP {from=0, to=15, step=1}
474 :     val allRegsSet = List.foldl C.addReg C.empty allRegs
475 : mrainey 3008 val dedicated = [C.rsp, C.rbp]
476 : mrainey 3042 val avail = C.getReg (List.foldl C.rmvReg allRegsSet dedicated)
477 : mrainey 3000 fun spillLoc _ = raise Fail ""
478 :     val mode = RACore.NO_OPTIMIZATION
479 :     end
480 :     structure Float =
481 :     struct
482 : mrainey 3008 val avail = C.Regs CellsBasis.FP {from=0, to=15, step=1}
483 : mrainey 3000 val dedicated = []
484 :     fun spillLoc _ = raise Fail ""
485 : mrainey 3008 val mode = Word.orb (RACore.HAS_PARALLEL_COPIES, RACore.DEAD_COPY_ELIM)
486 : mrainey 3000 end
487 :    
488 :     )
489 :    
490 : mrainey 3009 structure RA = RA2
491 :     structure Cells = AMD64Instr.C
492 :     structure T = AMD64MLTree
493 :     structure CFG = AMD64CFG
494 :     structure FlowGraph = AMD64FlowGraph
495 : mrainey 3038 structure ChkTy = MLTreeCheckTy(structure T = T val intTy = 64)
496 : mrainey 3042 structure Vararg = AMD64VarargCCallFn(structure T = T)
497 : mrainey 3009
498 : mrainey 3049 structure TestSA =
499 : mrainey 3009 struct
500 :    
501 :     val wordTy = 64
502 : mrainey 3042
503 :     fun gen (functionName, stms, result) = let
504 :     val insnStrm = FlowGraph.build()
505 :     val stream as AMD64Stream.STREAM
506 :     { beginCluster, (* start a cluster *)
507 :     endCluster, (* end a cluster *)
508 :     emit, (* emit MLTREE stm *)
509 :     defineLabel, (* define a local label *)
510 :     entryLabel, (* define an external entry *)
511 :     exitBlock, (* mark the end of a procedure *)
512 :     pseudoOp, (* emit a pseudo op *)
513 :     annotation, (* add an annotation *)
514 :     ... } =
515 :     AMD64.selectInstructions insnStrm
516 :     fun doit () = (
517 :     beginCluster 0; (* start a new cluster *)
518 :     pseudoOp PseudoOpsBasisTyp.TEXT;
519 :     pseudoOp (PseudoOpsBasisTyp.EXPORT [functionName]);
520 :     entryLabel functionName; (* define the entry label *)
521 :     List.app emit stms; (* emit all the statements *)
522 :     exitBlock result;
523 :     endCluster [])
524 :     val cfg = doit ()
525 :     val cfg = RA.run cfg
526 :     val cfg = AMD64Expand.run cfg
527 :     in
528 :     (cfg, stream) (* end the cluster *)
529 :     end
530 : mrainey 3009
531 :     fun codegen (functionName, target, proto, initStms, args) = let
532 :     val _ = Label.reset()
533 :    
534 :     val [functionName, target] = List.map Label.global [functionName, target]
535 :    
536 :     (* construct the C call *)
537 :     val {result, callseq} = CCalls.genCall {
538 :     name=T.LABEL target,
539 :     paramAlloc=fn _ => false,
540 :     structRet=fn _ => T.REG (64, Cells.rax),
541 :     saveRestoreDedicated=fn _ => {save=[], restore=[]},
542 :     callComment=NONE,
543 :     proto=proto,
544 :     args=args}
545 :    
546 :     fun wordLit i = T.LI (T.I.fromInt (wordTy, i))
547 :    
548 :     val stms = List.concat [
549 :     [T.EXT(AMD64InstrExt.PUSHQ(T.REG(64, Cells.rbp))),
550 :     T.COPY (wordTy, [Cells.rbp], [Cells.rsp])],
551 :     initStms,
552 :     callseq,
553 :     [T.EXT(AMD64InstrExt.LEAVE)],
554 :     [T.RET []]]
555 : mrainey 3038 val _ = List.all (fn stm => ChkTy.check stm
556 :     orelse raise Fail ("typechecking error: "^AMD64MTC.AMD64MLTreeUtils.stmToString stm))
557 :     stms
558 : mrainey 3042 in
559 :     gen (functionName, stms, result)
560 :     end
561 : mrainey 3009
562 :     fun dumpOutput (cfg, stream) = let
563 :     val (cfg as Graph.GRAPH graph, blocks) =
564 :     AMD64BlockPlacement.blockPlacement cfg
565 :     val CFG.INFO{annotations=an, data, decls, ...} = #graph_info graph
566 :     in
567 :     AMD64Emit.asmEmit (cfg, blocks)
568 :     end (* dumpOutput *)
569 :    
570 : mrainey 3042 fun lit i = T.LI (T.I.fromInt (wordTy, i))
571 :    
572 : mrainey 3049 fun vararg _ = let
573 : mrainey 3042 val lab = Label.global "varargs"
574 :     val tmp = C.newReg()
575 :     val tmpC = C.newReg()
576 :     val stms =
577 :     List.concat [
578 :     [T.EXT(AMD64InstrExt.PUSHQ(T.REG(64, Cells.rbp))),
579 :     T.COPY (wordTy, [Cells.rbp], [Cells.rsp])],
580 :     [T.MV(wordTy, tmp, T.REG(wordTy, C.rsi))],
581 :     [T.MV(wordTy, tmpC, T.REG(wordTy, C.rdi))],
582 : mrainey 3049 Vararg.genVarargs (T.REG(wordTy, tmpC), tmp),
583 : mrainey 3042 [T.EXT(AMD64InstrExt.LEAVE)],
584 :     [T.RET []]
585 :     ]
586 :    
587 :     val asmOutStrm = TextIO.openOut "mlrisc.s"
588 :     fun doit () = dumpOutput(gen(lab, stms, [T.GPR (T.REG (wordTy, C.rax))]))
589 :     val _ = AsmStream.withStream asmOutStrm doit ()
590 :     val _ = TextIO.closeOut asmOutStrm
591 :     in
592 :     0
593 :     end
594 : mrainey 3009 end
595 :    
596 :    
597 :     (* machine-specific data *)
598 :     val wordTy = 64
599 :     val wordSzB = wordTy div 8
600 :     val param0 = T.REG(wordTy, Cells.rdi)
601 :    
602 :     (* maximum argument size in machine words *)
603 :     val maxArgSz = 16
604 :     val maxArgSzB = maxArgSz * wordSzB
605 : mrainey 3043 (*
606 : mrainey 3038 (* unit testing code *)
607 :     structure Test =
608 :     struct
609 :    
610 :     open CCalls
611 :    
612 :     fun li2k (_, k, _) = k
613 :    
614 :     val ty1 = CTy.C_STRUCT [CTy.C_STRUCT [CTy.C_unsigned CTy.I_char, CTy.C_unsigned CTy.I_int]]
615 :     val ty2 = CTy.C_STRUCT [CTy.C_signed CTy.I_short]
616 :     val ty3 = CTy.C_STRUCT [CTy.C_signed CTy.I_short, CTy.C_PTR]
617 :     val ty4 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_PTR]
618 :     val ty4 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_unsigned CTy.I_int], CTy.C_PTR]
619 :     val ty5 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float]]
620 :     val ty6 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
621 :     val ty7 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_STRUCT[CTy.C_float,CTy.C_float],CTy.C_float,CTy.C_float]]
622 :     val ty8 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_STRUCT[CTy.C_float,CTy.C_unsigned CTy.I_int],CTy.C_float,CTy.C_float]]
623 :     val ty9 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
624 :     val ty10 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float, CTy.C_STRUCT[CTy.C_float,CTy.C_unsigned CTy.I_int]]]
625 :     val ty11 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_float, CTy.C_float, CTy.C_float]
626 :    
627 :     fun kindOfEB () = let
628 :     fun test (eb, k) = (kindOfEightByte eb = k) orelse raise Fail "failed test"
629 :     fun eb1 ty = hd (eightBytesOfCTy ty)
630 :     fun eb2 ty = hd(tl (eightBytesOfCTy ty))
631 :     in
632 :     List.all test [(eb1 ty1, K_GPR), (eb1 ty2, K_GPR), (eb2 ty3, K_GPR),
633 :     (eb1 ty5, K_FPR), (eb1 ty6, K_FPR), (eb2 ty6, K_FPR),
634 :     (eb1 ty7, K_FPR), (eb2 ty7, K_FPR),
635 :     (eb1 ty8, K_GPR), (eb2 ty8, K_FPR)]
636 :     end
637 :    
638 :     fun slots () = let
639 :     fun test (lis : SA.slot list, ks2 : location_kind list) = let
640 :     val ks1 = List.map li2k lis
641 :     in
642 :     (List.length ks1 = List.length ks2) andalso (ListPair.all (op =) (ks1, ks2))
643 :     end
644 :     val tests = [
645 :     (ty2, [K_GPR]),
646 :     (ty1, [K_GPR]),
647 :     (ty3, [K_GPR, K_GPR]),
648 :     (ty4, [K_GPR, K_GPR]),
649 :     (ty5, [K_FPR]),
650 :     (ty6, [K_FPR, K_FPR]),
651 :     (ty7, [K_FPR, K_FPR]),
652 :     (ty8, [K_GPR, K_FPR]),
653 :     (ty11, [K_MEM, K_MEM, K_MEM])
654 :     ]
655 :     val (ts, anss) = ListPair.unzip tests
656 :     in
657 :     ListPair.all test (List.map slotsOfCTy ts, anss) orelse raise Fail "failed test"
658 :     end
659 :     end
660 : mrainey 3043 *)
661 :    
662 :     structure Test = struct end

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