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 3058 - (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 3058
332 :     structure OldCCalls = AMD64SVID (
333 : mrainey 2990 structure T = AMD64MLTree
334 :     val frameAlign = 16)
335 : mrainey 3000
336 : mrainey 3058
337 : mrainey 3000 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 3054 structure Vararg = AMD64VarargCCallFn(
497 :     structure T = T
498 :     fun push e = T.EXT(AMD64InstrExt.PUSHQ e)
499 :     val leave = T.EXT(AMD64InstrExt.LEAVE)
500 :     )
501 : mrainey 3009
502 : mrainey 3049 structure TestSA =
503 : mrainey 3009 struct
504 :    
505 :     val wordTy = 64
506 : mrainey 3042
507 :     fun gen (functionName, stms, result) = let
508 :     val insnStrm = FlowGraph.build()
509 :     val stream as AMD64Stream.STREAM
510 :     { beginCluster, (* start a cluster *)
511 :     endCluster, (* end a cluster *)
512 :     emit, (* emit MLTREE stm *)
513 :     defineLabel, (* define a local label *)
514 :     entryLabel, (* define an external entry *)
515 :     exitBlock, (* mark the end of a procedure *)
516 :     pseudoOp, (* emit a pseudo op *)
517 :     annotation, (* add an annotation *)
518 :     ... } =
519 :     AMD64.selectInstructions insnStrm
520 :     fun doit () = (
521 :     beginCluster 0; (* start a new cluster *)
522 :     pseudoOp PseudoOpsBasisTyp.TEXT;
523 :     pseudoOp (PseudoOpsBasisTyp.EXPORT [functionName]);
524 :     entryLabel functionName; (* define the entry label *)
525 :     List.app emit stms; (* emit all the statements *)
526 :     exitBlock result;
527 :     endCluster [])
528 :     val cfg = doit ()
529 :     val cfg = RA.run cfg
530 :     val cfg = AMD64Expand.run cfg
531 :     in
532 :     (cfg, stream) (* end the cluster *)
533 :     end
534 : mrainey 3009
535 :     fun codegen (functionName, target, proto, initStms, args) = let
536 :     val _ = Label.reset()
537 :    
538 :     val [functionName, target] = List.map Label.global [functionName, target]
539 :    
540 :     (* construct the C call *)
541 :     val {result, callseq} = CCalls.genCall {
542 :     name=T.LABEL target,
543 :     paramAlloc=fn _ => false,
544 :     structRet=fn _ => T.REG (64, Cells.rax),
545 :     saveRestoreDedicated=fn _ => {save=[], restore=[]},
546 :     callComment=NONE,
547 :     proto=proto,
548 :     args=args}
549 :    
550 :     fun wordLit i = T.LI (T.I.fromInt (wordTy, i))
551 :    
552 :     val stms = List.concat [
553 :     [T.EXT(AMD64InstrExt.PUSHQ(T.REG(64, Cells.rbp))),
554 :     T.COPY (wordTy, [Cells.rbp], [Cells.rsp])],
555 :     initStms,
556 :     callseq,
557 :     [T.EXT(AMD64InstrExt.LEAVE)],
558 :     [T.RET []]]
559 : mrainey 3038 val _ = List.all (fn stm => ChkTy.check stm
560 :     orelse raise Fail ("typechecking error: "^AMD64MTC.AMD64MLTreeUtils.stmToString stm))
561 :     stms
562 : mrainey 3042 in
563 :     gen (functionName, stms, result)
564 :     end
565 : mrainey 3009
566 :     fun dumpOutput (cfg, stream) = let
567 :     val (cfg as Graph.GRAPH graph, blocks) =
568 :     AMD64BlockPlacement.blockPlacement cfg
569 :     val CFG.INFO{annotations=an, data, decls, ...} = #graph_info graph
570 :     in
571 :     AMD64Emit.asmEmit (cfg, blocks)
572 :     end (* dumpOutput *)
573 :    
574 : mrainey 3042 fun lit i = T.LI (T.I.fromInt (wordTy, i))
575 :    
576 : mrainey 3049 fun vararg _ = let
577 : mrainey 3054 val _ = Label.reset()
578 :     val (lab, varargStms) = Vararg.genVarargs()
579 : mrainey 3042 val asmOutStrm = TextIO.openOut "mlrisc.s"
580 : mrainey 3054 fun doit () = dumpOutput(gen(lab, varargStms, [T.GPR (T.REG (wordTy, C.rax))]))
581 : mrainey 3042 val _ = AsmStream.withStream asmOutStrm doit ()
582 :     val _ = TextIO.closeOut asmOutStrm
583 :     in
584 :     0
585 :     end
586 : mrainey 3009 end
587 :    
588 :    
589 :     (* machine-specific data *)
590 :     val wordTy = 64
591 :     val wordSzB = wordTy div 8
592 :     val param0 = T.REG(wordTy, Cells.rdi)
593 :    
594 :     (* maximum argument size in machine words *)
595 :     val maxArgSz = 16
596 :     val maxArgSzB = maxArgSz * wordSzB
597 : mrainey 3043 (*
598 : mrainey 3038 (* unit testing code *)
599 :     structure Test =
600 :     struct
601 :    
602 :     open CCalls
603 :    
604 :     fun li2k (_, k, _) = k
605 :    
606 :     val ty1 = CTy.C_STRUCT [CTy.C_STRUCT [CTy.C_unsigned CTy.I_char, CTy.C_unsigned CTy.I_int]]
607 :     val ty2 = CTy.C_STRUCT [CTy.C_signed CTy.I_short]
608 :     val ty3 = CTy.C_STRUCT [CTy.C_signed CTy.I_short, CTy.C_PTR]
609 :     val ty4 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_PTR]
610 :     val ty4 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_unsigned CTy.I_int], CTy.C_PTR]
611 :     val ty5 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float]]
612 :     val ty6 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
613 :     val ty7 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_STRUCT[CTy.C_float,CTy.C_float],CTy.C_float,CTy.C_float]]
614 :     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]]
615 :     val ty9 = CTy.C_STRUCT [CTy.C_STRUCT[CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
616 :     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]]]
617 :     val ty11 = CTy.C_STRUCT [CTy.C_PTR, CTy.C_float, CTy.C_float, CTy.C_float]
618 :    
619 :     fun kindOfEB () = let
620 :     fun test (eb, k) = (kindOfEightByte eb = k) orelse raise Fail "failed test"
621 :     fun eb1 ty = hd (eightBytesOfCTy ty)
622 :     fun eb2 ty = hd(tl (eightBytesOfCTy ty))
623 :     in
624 :     List.all test [(eb1 ty1, K_GPR), (eb1 ty2, K_GPR), (eb2 ty3, K_GPR),
625 :     (eb1 ty5, K_FPR), (eb1 ty6, K_FPR), (eb2 ty6, K_FPR),
626 :     (eb1 ty7, K_FPR), (eb2 ty7, K_FPR),
627 :     (eb1 ty8, K_GPR), (eb2 ty8, K_FPR)]
628 :     end
629 :    
630 :     fun slots () = let
631 :     fun test (lis : SA.slot list, ks2 : location_kind list) = let
632 :     val ks1 = List.map li2k lis
633 :     in
634 :     (List.length ks1 = List.length ks2) andalso (ListPair.all (op =) (ks1, ks2))
635 :     end
636 :     val tests = [
637 :     (ty2, [K_GPR]),
638 :     (ty1, [K_GPR]),
639 :     (ty3, [K_GPR, K_GPR]),
640 :     (ty4, [K_GPR, K_GPR]),
641 :     (ty5, [K_FPR]),
642 :     (ty6, [K_FPR, K_FPR]),
643 :     (ty7, [K_FPR, K_FPR]),
644 :     (ty8, [K_GPR, K_FPR]),
645 :     (ty11, [K_MEM, K_MEM, K_MEM])
646 :     ]
647 :     val (ts, anss) = ListPair.unzip tests
648 :     in
649 :     ListPair.all test (List.map slotsOfCTy ts, anss) orelse raise Fail "failed test"
650 :     end
651 :     end
652 : mrainey 3043 *)
653 :    
654 :     structure Test = struct end

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