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 3042 - (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 3038 (*
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 : mrainey 3038 *)
141 : mrainey 2993
142 :     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 :    
149 : mrainey 3038
150 : mrainey 2990 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 AMD64Stream = InstructionStream(AMD64PseudoOps)*)
201 :     structure AMD64MLTStream = MLTreeStream (
202 :     structure T = AMD64MLTree
203 :     structure S = AMD64Stream)
204 :    
205 :     structure CompInstrExt = AMD64CompInstrExt (
206 :     structure I = AMD64Instr
207 :     structure TS = AMD64MLTStream
208 :     structure CFG = AMD64CFG)
209 :    
210 :     structure AMD64MTC = struct
211 :     structure T = AMD64MLTree
212 :     structure TS = AMD64MLTStream
213 :     structure I = AMD64Instr
214 :     structure CFG = AMD64CFG
215 :     structure C = I.C
216 :     type reducer =
217 :     (I.instruction,C.cellset,I.operand,I.addressing_mode,AMD64CFG.cfg) TS.reducer
218 :     fun unimplemented _ = MLRiscErrorMsg.impossible "UserMLTreeExtComp"
219 :     val compileSext = CompInstrExt.compileSext
220 :     val compileRext = unimplemented
221 :     val compileFext = unimplemented
222 :     val compileCCext = unimplemented
223 :    
224 :     structure AMD64MLTreeUtils : MLTREE_UTILS =
225 :     struct
226 :     structure T = AMD64MLTree
227 :     structure IX = AMD64InstrExt
228 :     structure U = MLTreeUtils (
229 :     structure T = T
230 :     fun hashSext _ _ = 0w0
231 :     fun hashRext _ _ = 0w0
232 :     fun hashFext _ _ = 0w0
233 :     fun hashCCext _ _ = 0w0
234 :     fun eqSext _ _ = raise Fail "eqSext"
235 :     fun eqRext _ _ = raise Fail "eqRext"
236 :     fun eqFext _ _ = raise Fail "eqFext"
237 :     fun eqCCext _ _ = raise Fail "eqCCext"
238 :     fun showSext (prt : T.printer) ext = raise Fail "todo"
239 :     fun showRext _ _ = raise Fail "showRext"
240 :     fun showFext _ _ = raise Fail "showFext"
241 :     fun showCCext _ _ = raise Fail "showCCext")
242 :     open U
243 :     end
244 :     end
245 :    
246 :     structure AMD64 = AMD64Gen (
247 :     structure I = AMD64Instr
248 :     structure MLTreeUtils = AMD64MTC.AMD64MLTreeUtils
249 :     structure ExtensionComp = AMD64MTC
250 :     val floats16ByteAligned = floats16ByteAligned
251 :     fun signBit _ = raise Fail "todo"
252 :     fun negateSignBit _ = raise Fail "todo"
253 :     )
254 :    
255 :     structure AMD64Emit = CFGEmit (
256 :     structure CFG = AMD64CFG
257 :     structure E = AMD64Asm)
258 :    
259 :    
260 :     structure AMD64FlowGraph = BuildFlowgraph
261 :     (structure Props = AMD64InsnProps
262 :     structure Stream = AMD64Stream
263 :     structure CFG = AMD64CFG)
264 :    
265 :     structure AMD64Expand = CFGExpandCopies (structure CFG=AMD64CFG
266 :     structure Shuffle = AMD64Shuffle)
267 :     structure AMD64BlockPlacement = DefaultBlockPlacement(AMD64CFG)
268 :    
269 :     structure RASpill = RASpillWithRenaming (
270 :     structure Asm = AMD64Asm
271 :     structure InsnProps = AMD64InsnProps
272 :     val max_dist = ref 4
273 :     val keep_multiple_values = ref false)
274 :    
275 :     structure C = AMD64Cells
276 :    
277 :     datatype spill_operand_kind = SPILL_LOC
278 :     | CONST_VAL
279 :    
280 :     datatype ra_phase = SPILL_PROPAGATION
281 :     | SPILL_COLORING
282 :    
283 :     structure IntRA =
284 :     struct
285 :     val dedicated = [C.rsp, C.rbp]
286 :     val allRegs = C.Regs CellsBasis.GP {from=0, to=15, step=1}
287 :     val allRegsSet = foldl C.addReg C.empty allRegs
288 :     val avail = let
289 :     val availSet = foldl C.rmvReg allRegsSet dedicated
290 :     in
291 :     C.getReg availSet
292 :     end
293 :     fun spillInit _ = ()
294 :     fun spillLoc {info=frame, an, cell, id=loc} =
295 : mrainey 2995 raise Fail ""
296 :     (* {opnd = AMD64Instr.Immed 0, kind = SPILL_LOC}*)
297 : mrainey 2990 val phases = [SPILL_PROPAGATION, SPILL_COLORING]
298 :     end (* IntRA *)
299 :    
300 :     structure FloatRA =
301 :     struct
302 :     val avail = C.Regs CellsBasis.FP {from=0, to=15, step=1}
303 :     val dedicated = []
304 :     fun spillInit _ = ()
305 : mrainey 2995 fun spillLoc (info, ans, id) = raise Fail ""
306 : mrainey 2990 val phases = [SPILL_PROPAGATION, SPILL_COLORING]
307 :     end (* FloatRA *)
308 :    
309 :     (* register allocation *)
310 :     structure AMD64RA = AMD64RegAlloc (
311 :     structure I = AMD64Instr
312 :     structure CFG = AMD64CFG
313 :     structure Asm = AMD64Asm
314 :     structure SpillHeur = ChowHennessySpillHeur
315 :     structure Spill = RASpill
316 :     structure Props = AMD64InsnProps
317 :     val floats16ByteAligned = floats16ByteAligned
318 :     type spill_info = unit
319 :     fun beforeRA (Graph.GRAPH graph) = ()
320 :     datatype spill_operand_kind = datatype spill_operand_kind
321 :     datatype ra_phase = datatype ra_phase
322 :     structure Int = IntRA
323 :     structure Float = FloatRA)
324 :    
325 :     structure AMD64Expand = CFGExpandCopies (
326 :     structure CFG=AMD64CFG
327 :     structure Shuffle = AMD64Shuffle)
328 :    
329 : mrainey 3038 structure CCalls = AMD64SVIDFn (
330 : mrainey 3037 structure T = AMD64MLTree)
331 :    
332 : mrainey 3038 (*
333 : mrainey 2990 structure CCalls = AMD64SVID (
334 :     structure T = AMD64MLTree
335 :     val frameAlign = 16)
336 : mrainey 3038 *)
337 : mrainey 3000
338 :     structure RA2 =
339 :     RISC_RA
340 :     (structure I = AMD64Instr
341 :     structure Asm = AMD64Asm
342 :     structure CFG = AMD64CFG
343 :     structure InsnProps = AMD64InsnProps
344 :     structure Rewrite =
345 :     struct
346 :     structure I = AMD64Instr
347 : mrainey 3008 structure C=I.C
348 :     structure CB = CellsBasis
349 :     fun error msg = MLRiscErrorMsg.error("X86Rewrite", msg)
350 :    
351 :     fun operand (rs,rt) opnd =
352 :     (case opnd
353 :     of I.Direct (sz, r) => if CB.sameColor(r,rs) then I.Direct (sz, rt) else opnd
354 :     | I.Displace{base, disp, mem} =>
355 :     if CB.sameColor(base,rs) then I.Displace{base=rt, disp=disp, mem=mem}
356 :     else opnd
357 :     | I.Indexed{base as SOME b, index, scale, disp, mem} => let
358 :     val base'= if CB.sameColor(b,rs) then SOME rt else base
359 :     val index'=if CB.sameColor(index,rs) then rt else index
360 :     in I.Indexed{base=base', index=index', scale=scale, disp=disp, mem=mem}
361 :     end
362 :     | I.Indexed{base, index, scale, disp, mem=mem} =>
363 :     if CB.sameColor(index,rs) then
364 :     I.Indexed{base=base, index=rt, scale=scale, disp=disp, mem=mem}
365 :     else opnd
366 :     | _ => opnd
367 :     (*end case*))
368 :    
369 :    
370 :     fun rewriteDef (instr, rs, rt) = let
371 :     fun operand(opnd as I.Direct (sz, r)) =
372 :     if CB.sameColor(r,rs) then I.Direct (sz, rt) else opnd
373 :     | operand _ = error "operand: not I.Direct"
374 :     fun replace r = if CB.sameColor(r,rs) then rt else r
375 :     fun rewriteX86Def(instr) =
376 :     (case instr
377 :     of I.CALL{opnd, defs, uses, return, cutsTo, mem, pops} =>
378 :     I.CALL{opnd=opnd, cutsTo=cutsTo,
379 :     return=CB.CellSet.map {from=rs,to=rt} return, pops=pops,
380 :     defs=CB.CellSet.map {from=rs,to=rt} defs, uses=uses, mem=mem}
381 :     | I.MOVE{mvOp, src, dst} => I.MOVE{mvOp=mvOp, src=src, dst=operand dst}
382 :     | I.LEAL{r32, addr} => I.LEAL{r32=replace r32, addr=addr}
383 :     | I.LEAQ{r64, addr} => I.LEAQ{r64=replace r64, addr=addr}
384 :     | I.BINARY{binOp, src, dst} =>
385 :     I.BINARY{binOp=binOp, src=src, dst=operand dst}
386 :     | I.SHIFT{shiftOp, src, dst, count} =>
387 :     I.SHIFT{shiftOp=shiftOp, src=src, count=count, dst=operand dst}
388 :     | I.UNARY{unOp, opnd} => I.UNARY{unOp=unOp, opnd=operand opnd}
389 :     | I.SET{cond, opnd} => I.SET{cond=cond, opnd=operand opnd}
390 :     | _ => instr
391 :     (* end case *))
392 :    
393 :     fun f (I.ANNOTATION{a,i}) =
394 :     I.ANNOTATION{i=rewriteDef(i,rs,rt),
395 :     a=(case a of
396 :     CB.DEF_USE{cellkind=CB.GP,defs,uses} =>
397 :     CB.DEF_USE{cellkind=CB.GP,uses=uses,
398 :     defs=map replace defs}
399 :     | _ => a)}
400 :     | f (I.INSTR i) = I.INSTR(rewriteX86Def(i))
401 :     | f (I.COPY{k as CB.GP, sz, dst, src, tmp}) =
402 :     I.COPY{k=k, sz=sz, dst=map replace dst, src=src, tmp=tmp}
403 :     in
404 :     f(instr)
405 :     end
406 :    
407 :    
408 :     fun rewriteUse (instr, rs, rt) = let
409 :     val operand = operand (rs, rt)
410 :     fun replace r = if CB.sameColor(r,rs) then rt else r
411 :     fun rewrite instr = (case instr
412 :     of I.JMP(opnd, labs) => I.JMP(operand opnd, labs)
413 :     | I.JCC{cond, opnd} => I.JCC{cond=cond, opnd = operand opnd}
414 :     | I.CALL{opnd, defs, uses, return, cutsTo, mem, pops} =>
415 :     I.CALL{opnd=operand opnd, defs=defs, return=return,
416 :     uses=CB.CellSet.map {from=rs,to=rt} uses, cutsTo=cutsTo,
417 :     mem=mem, pops=pops}
418 :     | I.MOVE{mvOp, src, dst as I.Direct _} =>
419 :     I.MOVE{mvOp=mvOp, src=operand src, dst=dst}
420 :     | I.MOVE{mvOp, src, dst} =>
421 :     I.MOVE{mvOp=mvOp, src=operand src, dst=operand dst}
422 :     | I.LEAL{r32, addr} => I.LEAL{r32=r32, addr=operand addr}
423 :     | I.LEAQ{r64, addr} => I.LEAQ{r64=r64, addr=operand addr}
424 :     | I.CMPL{lsrc, rsrc} => I.CMPL{lsrc=operand lsrc, rsrc=operand rsrc}
425 :     | I.CMPW{lsrc, rsrc} => I.CMPW{lsrc=operand lsrc, rsrc=operand rsrc}
426 :     | I.CMPB{lsrc, rsrc} => I.CMPB{lsrc=operand lsrc, rsrc=operand rsrc}
427 :     | I.TESTL{lsrc, rsrc} => I.TESTL{lsrc=operand lsrc, rsrc=operand rsrc}
428 :     | I.TESTW{lsrc, rsrc} => I.TESTW{lsrc=operand lsrc, rsrc=operand rsrc}
429 :     | I.TESTB{lsrc, rsrc} => I.TESTB{lsrc=operand lsrc, rsrc=operand rsrc}
430 :     | I.BITOP{bitOp, lsrc, rsrc} =>
431 :     I.BITOP{bitOp=bitOp, lsrc=operand lsrc, rsrc=operand rsrc}
432 :     | I.BINARY{binOp, src, dst} =>
433 :     I.BINARY{binOp=binOp, src=operand src, dst=operand dst}
434 :     | I.SHIFT{shiftOp, src, dst, count} =>
435 :     I.SHIFT{shiftOp=shiftOp, src=operand src, dst=operand dst,
436 :     count=operand src}
437 :     (* end case *))
438 :    
439 :     fun f(I.ANNOTATION{a,i}) =
440 :     I.ANNOTATION{i=rewriteUse(i, rs, rt),
441 :     a = case a of
442 :     CB.DEF_USE{cellkind=CB.GP,defs,uses} =>
443 :     CB.DEF_USE{cellkind=CB.GP,uses=map replace uses,
444 :     defs=defs}
445 :     | _ => a}
446 :     | f(I.INSTR i) = I.INSTR(rewrite(i))
447 :     | f(I.COPY{k as CB.GP, sz, dst, src, tmp}) =
448 :     I.COPY{k=k, sz=sz, dst=dst, src=List.map replace src, tmp=tmp}
449 :     in
450 :     f (instr:I.instruction)
451 :     end
452 :    
453 :    
454 : mrainey 3000 fun frewriteDef _ = raise Fail ""
455 :     fun frewriteUse _ = raise Fail ""
456 :     end
457 :     structure SpillInstr = AMD64SpillInstr (
458 :     structure I = I
459 :     structure Props = AMD64InsnProps
460 :     val floats16ByteAligned = true)
461 :     structure SpillHeur = ChaitinSpillHeur
462 :     structure Spill = RASpill (structure InsnProps = AMD64InsnProps
463 :     structure Asm = AMD64Asm)
464 :    
465 :     datatype spillOperandKind = SPILL_LOC | CONST_VAL
466 :     type spill_info = unit
467 : mrainey 3008 fun beforeRA _ = ()
468 : mrainey 3000
469 :     val architecture = "amd64"
470 :     fun pure _ = true
471 :    
472 :     structure Int =
473 :     struct
474 : mrainey 3042 val allRegs = C.Regs CellsBasis.GP {from=0, to=15, step=1}
475 :     val allRegsSet = List.foldl C.addReg C.empty allRegs
476 : mrainey 3008 val dedicated = [C.rsp, C.rbp]
477 : mrainey 3042 val avail = C.getReg (List.foldl C.rmvReg allRegsSet dedicated)
478 : mrainey 3000 fun spillLoc _ = raise Fail ""
479 :     val mode = RACore.NO_OPTIMIZATION
480 :     end
481 :     structure Float =
482 :     struct
483 : mrainey 3008 val avail = C.Regs CellsBasis.FP {from=0, to=15, step=1}
484 : mrainey 3000 val dedicated = []
485 :     fun spillLoc _ = raise Fail ""
486 : mrainey 3008 val mode = Word.orb (RACore.HAS_PARALLEL_COPIES, RACore.DEAD_COPY_ELIM)
487 : mrainey 3000 end
488 :    
489 :     )
490 :    
491 : mrainey 3009 structure RA = RA2
492 :     structure Cells = AMD64Instr.C
493 :     structure T = AMD64MLTree
494 :     structure CFG = AMD64CFG
495 :     structure FlowGraph = AMD64FlowGraph
496 : mrainey 3038 structure ChkTy = MLTreeCheckTy(structure T = T val intTy = 64)
497 : mrainey 3042 structure Vararg = AMD64VarargCCallFn(structure T = T)
498 : mrainey 3009
499 :     structure TestStagedAllocation =
500 :     struct
501 :    
502 :     val wordTy = 64
503 : mrainey 3042
504 :     fun gen (functionName, stms, result) = let
505 :     val insnStrm = FlowGraph.build()
506 :     val stream as AMD64Stream.STREAM
507 :     { beginCluster, (* start a cluster *)
508 :     endCluster, (* end a cluster *)
509 :     emit, (* emit MLTREE stm *)
510 :     defineLabel, (* define a local label *)
511 :     entryLabel, (* define an external entry *)
512 :     exitBlock, (* mark the end of a procedure *)
513 :     pseudoOp, (* emit a pseudo op *)
514 :     annotation, (* add an annotation *)
515 :     ... } =
516 :     AMD64.selectInstructions insnStrm
517 :     fun doit () = (
518 :     beginCluster 0; (* start a new cluster *)
519 :     pseudoOp PseudoOpsBasisTyp.TEXT;
520 :     pseudoOp (PseudoOpsBasisTyp.EXPORT [functionName]);
521 :     entryLabel functionName; (* define the entry label *)
522 :     List.app emit stms; (* emit all the statements *)
523 :     exitBlock result;
524 :     endCluster [])
525 :     val cfg = doit ()
526 :     val cfg = RA.run cfg
527 :     val cfg = AMD64Expand.run cfg
528 :     in
529 :     (cfg, stream) (* end the cluster *)
530 :     end
531 : mrainey 3009
532 :     fun codegen (functionName, target, proto, initStms, args) = let
533 :     val _ = Label.reset()
534 :    
535 :     val [functionName, target] = List.map Label.global [functionName, target]
536 :    
537 :     (* construct the C call *)
538 :     val {result, callseq} = CCalls.genCall {
539 :     name=T.LABEL target,
540 :     paramAlloc=fn _ => false,
541 :     structRet=fn _ => T.REG (64, Cells.rax),
542 :     saveRestoreDedicated=fn _ => {save=[], restore=[]},
543 :     callComment=NONE,
544 :     proto=proto,
545 :     args=args}
546 :    
547 :     fun wordLit i = T.LI (T.I.fromInt (wordTy, i))
548 :    
549 :     val stms = List.concat [
550 :     [T.EXT(AMD64InstrExt.PUSHQ(T.REG(64, Cells.rbp))),
551 :     T.COPY (wordTy, [Cells.rbp], [Cells.rsp])],
552 :     initStms,
553 :     callseq,
554 :     [T.EXT(AMD64InstrExt.LEAVE)],
555 :     [T.RET []]]
556 : mrainey 3038 val _ = List.all (fn stm => ChkTy.check stm
557 :     orelse raise Fail ("typechecking error: "^AMD64MTC.AMD64MLTreeUtils.stmToString stm))
558 :     stms
559 : mrainey 3042 in
560 :     gen (functionName, stms, result)
561 :     end
562 : mrainey 3009
563 :     fun dumpOutput (cfg, stream) = let
564 :     val (cfg as Graph.GRAPH graph, blocks) =
565 :     AMD64BlockPlacement.blockPlacement cfg
566 :     val CFG.INFO{annotations=an, data, decls, ...} = #graph_info graph
567 :     in
568 :     AMD64Emit.asmEmit (cfg, blocks)
569 :     end (* dumpOutput *)
570 :    
571 : mrainey 3042 fun lit i = T.LI (T.I.fromInt (wordTy, i))
572 :    
573 :     fun testVarargs _ = let
574 :     val lab = Label.global "varargs"
575 :     val tmp = C.newReg()
576 :     val tmpC = C.newReg()
577 :     val preCallInstrs = [T.MV(wordTy, C.rax, lit (List.length CCalls.CCs.fprParams))]
578 :     val stms =
579 :     List.concat [
580 :     [T.EXT(AMD64InstrExt.PUSHQ(T.REG(64, Cells.rbp))),
581 :     T.COPY (wordTy, [Cells.rbp], [Cells.rsp])],
582 :     [T.MV(wordTy, tmp, T.REG(wordTy, C.rsi))],
583 :     [T.MV(wordTy, tmpC, T.REG(wordTy, C.rdi))],
584 :     Vararg.genVarArgs (T.REG(wordTy, tmpC), tmp, preCallInstrs),
585 :     [T.EXT(AMD64InstrExt.LEAVE)],
586 :     [T.RET []]
587 :     ]
588 :    
589 :     val asmOutStrm = TextIO.openOut "mlrisc.s"
590 :     fun doit () = dumpOutput(gen(lab, stms, [T.GPR (T.REG (wordTy, C.rax))]))
591 :     val _ = AsmStream.withStream asmOutStrm doit ()
592 :     val _ = TextIO.closeOut asmOutStrm
593 :     in
594 :     0
595 :     end
596 :    
597 : mrainey 3009 end
598 :    
599 :    
600 :     (* machine-specific data *)
601 :     val wordTy = 64
602 :     val wordSzB = wordTy div 8
603 :     val param0 = T.REG(wordTy, Cells.rdi)
604 :    
605 :     (* maximum argument size in machine words *)
606 :     val maxArgSz = 16
607 :     val maxArgSzB = maxArgSz * wordSzB
608 : mrainey 3038
609 :     (* unit testing code *)
610 :     structure Test =
611 :     struct
612 :    
613 :     open CCalls
614 :    
615 :     fun li2k (_, k, _) = k
616 :    
617 :     val ty1 = CTy.C_STRUCT [CTy.C_STRUCT [CTy.C_unsigned CTy.I_char, CTy.C_unsigned CTy.I_int]]
618 :     val ty2 = CTy.C_STRUCT [CTy.C_signed CTy.I_short]
619 :     val ty3 = CTy.C_STRUCT [CTy.C_signed CTy.I_short, CTy.C_PTR]
620 :     val ty4 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_PTR]
621 :     val ty4 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_unsigned CTy.I_int], CTy.C_PTR]
622 :     val ty5 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float]]
623 :     val ty6 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
624 :     val ty7 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_STRUCT[CTy.C_float,CTy.C_float],CTy.C_float,CTy.C_float]]
625 :     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]]
626 :     val ty9 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
627 :     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]]]
628 :     val ty11 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_float, CTy.C_float, CTy.C_float]
629 :    
630 :     fun kindOfEB () = let
631 :     fun test (eb, k) = (kindOfEightByte eb = k) orelse raise Fail "failed test"
632 :     fun eb1 ty = hd (eightBytesOfCTy ty)
633 :     fun eb2 ty = hd(tl (eightBytesOfCTy ty))
634 :     in
635 :     List.all test [(eb1 ty1, K_GPR), (eb1 ty2, K_GPR), (eb2 ty3, K_GPR),
636 :     (eb1 ty5, K_FPR), (eb1 ty6, K_FPR), (eb2 ty6, K_FPR),
637 :     (eb1 ty7, K_FPR), (eb2 ty7, K_FPR),
638 :     (eb1 ty8, K_GPR), (eb2 ty8, K_FPR)]
639 :     end
640 :    
641 :     fun slots () = let
642 :     fun test (lis : SA.slot list, ks2 : location_kind list) = let
643 :     val ks1 = List.map li2k lis
644 :     in
645 :     (List.length ks1 = List.length ks2) andalso (ListPair.all (op =) (ks1, ks2))
646 :     end
647 :     val tests = [
648 :     (ty2, [K_GPR]),
649 :     (ty1, [K_GPR]),
650 :     (ty3, [K_GPR, K_GPR]),
651 :     (ty4, [K_GPR, K_GPR]),
652 :     (ty5, [K_FPR]),
653 :     (ty6, [K_FPR, K_FPR]),
654 :     (ty7, [K_FPR, K_FPR]),
655 :     (ty8, [K_GPR, K_FPR]),
656 :     (ty11, [K_MEM, K_MEM, K_MEM])
657 :     ]
658 :     val (ts, anss) = ListPair.unzip tests
659 :     in
660 :     ListPair.all test (List.map slotsOfCTy ts, anss) orelse raise Fail "failed test"
661 :     end
662 :     end

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