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/c-call/test/c-sparc-test.sml
ViewVC logotype

Annotation of /MLRISC/trunk/c-call/test/c-sparc-test.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3177 - (view) (download)

1 : mrainey 3173 local
2 :    
3 :     (*---------------------------------------------------------------------------
4 :     * First, some front-end dependent stuff. Typically, you only need
5 :     * one instance of these things for each source language.
6 :     *---------------------------------------------------------------------------*)
7 :    
8 :     (*
9 :     * User defined constant type. Dummy for now.
10 :     * In practice, you'll want to use this type to implement constants with
11 :     * values that cannot be determined until final code generation, e.g.
12 :     * stack frame offset.
13 :     *)
14 :     structure UserConst =
15 :     struct
16 :     type const = unit
17 :     fun toString() = ""
18 :     fun hash() = 0w0
19 :     fun valueOf _ = 0
20 :     fun == _ = true
21 :     end
22 :    
23 :     (*
24 :     * Instantiate label expressions with respect to user defined constants.
25 :     * This type is somewhat misnamed; it is used to represent constant
26 :     * expressions.
27 :     *)
28 :     (* structure LabelExp = LabelExp(UserConst) *)
29 :    
30 :     (*
31 :     * User defined datatype for representing aliasing. Dummy for now.
32 :     * You'll need this to represent aliasing information.
33 :     *)
34 :     structure UserRegion =
35 :     struct
36 :     type region = unit
37 :     fun toString () = ""
38 :     val memory = ()
39 :     val stack = ()
40 :     val readonly = ()
41 :     val spill = ()
42 :     end
43 :    
44 :     (*
45 :     * User defined datatype for representing pseudo assembly operators.
46 :     * Dummy for now.
47 :     *
48 :     * You'll need this to represent assembler directives.
49 :     *)
50 :     structure UserPseudoOps =
51 :     struct
52 :     type pseudo_op = unit
53 :     fun toString () = ""
54 :     fun emitValue _ = ()
55 :     fun sizeOf _ = 0
56 :     fun adjustLabels _ = true
57 :     end
58 :    
59 :    
60 :     (*
61 :     * Instruction stream datatype.
62 :     * This is just a simple record type used by MLRISC to represent
63 :     * instruction streams.
64 :     *)
65 :     (*structure Stream = InstructionStream(UserPseudoOps)*)
66 :    
67 :     (*
68 :     * Client defined extensions. None for now.
69 :     * You'll need this only if you need to extend the set of MLTREE operators
70 :     *)
71 :     structure UserExtension =
72 :     struct
73 :    
74 :     type ('s,'r,'f,'c) sx = ('s,'r,'f,'c) SparcInstrExt.sext
75 :     type ('s,'r,'f,'c) rx = unit
76 :     type ('s,'r,'f,'c) fx = unit
77 :     type ('s,'r,'f,'c) ccx = unit
78 :    
79 :     end
80 :    
81 :     structure SparcMLTree =
82 :     MLTreeF (structure Constant = UserConst
83 :     structure Region = UserRegion
84 :     structure Extension = UserExtension)
85 :    
86 :    
87 :     (*---------------------------------------------------------------------------
88 :     * Backend specific stuff. You'll need one instance of these things
89 :     * for each architecture.
90 :     *---------------------------------------------------------------------------*)
91 :    
92 :     (*
93 :     * The Sparc instruction set, specialized with respect to the
94 :     * user constant and region types.
95 :     *)
96 :     structure SparcInstr = SparcInstr
97 :     (SparcMLTree
98 :     )
99 :    
100 :     (*
101 :     * How to serialize parallel copies
102 :     *)
103 :     structure SparcShuffle = SparcShuffle(SparcInstr)
104 :    
105 :     structure SparcMLTreeEval =
106 :     MLTreeEval (structure T = SparcMLTree
107 :     fun eq _ _ = false
108 :     val eqRext = eq val eqFext = eq
109 :     val eqCCext = eq val eqSext = eq)
110 :    
111 :     functor SparcPseudoOpsFn (
112 :     structure T : MLTREE
113 :     structure MLTreeEval : MLTREE_EVAL where T = T
114 :     ) : PSEUDO_OPS_BASIS = SparcGasPseudoOps (
115 :     structure T = SparcMLTree
116 :     structure MLTreeEval = SparcMLTreeEval)
117 :    
118 :     structure SparcPseudoOps = SparcPseudoOpsFn(
119 :     structure T = SparcMLTree
120 :     structure MLTreeEval = SparcMLTreeEval)
121 :    
122 :     structure PseudoOps =
123 :     struct
124 :    
125 :     structure Client =
126 :     struct
127 :     structure AsmPseudoOps = SparcPseudoOps
128 :     type pseudo_op = unit
129 :    
130 :     fun toString () = ""
131 :    
132 :     fun emitValue _ = raise Fail "todo"
133 :     fun sizeOf _ = raise Fail "todo"
134 :     fun adjustLabels _ = raise Fail "todo"
135 :     end (* Client *)
136 :    
137 :     structure PseudoOps = PseudoOps (structure Client = Client)
138 :     end
139 :    
140 : mrainey 3177 structure SparcStream = InstructionStream(PseudoOps.PseudoOps)
141 :     structure SparcMLTreeStream =
142 :     MLTreeStream
143 :     (structure T = SparcMLTree
144 :     structure S = SparcStream)
145 : mrainey 3173
146 :     (*
147 :     * The assembler
148 :     *)
149 :     structure SparcAsm = SparcAsmEmitter
150 :     (structure Instr = SparcInstr
151 : mrainey 3177 structure Stream = SparcStream
152 : mrainey 3173 structure Shuffle = SparcShuffle
153 : mrainey 3177 structure S = SparcStream
154 : mrainey 3173 structure MLTreeEval = SparcMLTreeEval
155 :     val V9 = false (* we'll generate V8 instructions for now *)
156 :     )
157 :    
158 : mrainey 3177 structure SparcPseudoInstrs : SPARC_PSEUDO_INSTR =
159 : mrainey 3173 struct
160 :     structure I = SparcInstr
161 : mrainey 3177 structure C = I.C
162 : mrainey 3173
163 :     type format1 =
164 :     {r:CellsBasis.cell, i:I.operand, d:CellsBasis.cell} *
165 :     (I.operand -> CellsBasis.cell) -> I.instruction list
166 :    
167 :     type format2 =
168 :     {i:I.operand, d:CellsBasis.cell} *
169 :     (I.operand -> CellsBasis.cell) -> I.instruction list
170 :    
171 :     fun error msg = MLRiscErrorMsg.impossible ("SparcPseudoInstrs."^msg)
172 :    
173 : mrainey 3177 val delta = 0 (*SparcSpec.framesize*) (* initial value of %fp - %sp *)
174 : mrainey 3173
175 : mrainey 3177 (* runtime system dependent; the numbers are relative to %sp but
176 :     * we need offsets relative to %fp, hence the adjustment by delta *)
177 :     val floatTmpOffset = I.IMMED (88 - delta)
178 :     val umulOffset = I.IMMED (80 - delta)
179 :     val smulOffset = I.IMMED (72 - delta)
180 :     val udivOffset = I.IMMED (84 - delta)
181 :     val sdivOffset = I.IMMED (76 - delta)
182 :    
183 :     val stack = () (*CPSRegions.stack*)
184 :    
185 :     val native = true (* use native versions of the instructions? *)
186 :    
187 :     fun umul_native({r, i, d}, reduceOpnd) =
188 :     [I.arith{a=I.UMUL,r=r,i=i,d=d}]
189 :    
190 :     val TNE = I.ticc{t=I.BNE,cc=I.ICC,r=C.r0,i=I.IMMED 7}
191 :     val TVS = I.ticc{t=I.BVS,cc=I.ICC,r=C.r0,i=I.IMMED 7}
192 :    
193 :     (* overflows iff Y != (d ~>> 31) *)
194 :     fun smult_native({r, i, d}, reduceOpnd) =
195 :     let val t1 = C.newReg()
196 :     val t2 = C.newReg()
197 :     in [I.arith{a=I.SMUL,r=r,i=i,d=d},
198 :     I.shift{s=I.SRA,r=d,i=I.IMMED 31,d=t1},
199 :     I.rdy{d=t2},
200 :     I.arith{a=I.SUBCC,r=t1,i=I.REG t2,d=C.r0},
201 :     TNE
202 :     ]
203 :     end
204 :    
205 :     fun smul_native({r, i, d}, reduceOpnd) =
206 :     [I.arith{a=I.SMUL,r=r,i=i,d=d}]
207 :    
208 :     fun udiv_native({r,i,d},reduceOpnd) =
209 :     [I.wry{r=C.r0,i=I.REG C.r0},
210 :     I.arith{a=I.UDIV,r=r,i=i,d=d}]
211 :    
212 :     (* May overflow if MININT div -1 *)
213 :     fun sdivt_native({r,i,d},reduceOpnd) =
214 :     let val t1 = C.newReg()
215 :     in [I.shift{s=I.SRA,r=r,i=I.IMMED 31,d=t1},
216 :     I.wry{r=t1,i=I.REG C.r0},
217 :     I.arith{a=I.SDIVCC,r=r,i=i,d=d},
218 :     TVS
219 :     ]
220 :     end
221 :    
222 :     fun sdiv_native({r,i,d},reduceOpnd) =
223 :     let val t1 = C.newReg()
224 :     in [I.shift{s=I.SRA,r=r,i=I.IMMED 31,d=t1},
225 :     I.wry{r=t1,i=I.REG C.r0},
226 :     I.arith{a=I.SDIV,r=r,i=i,d=d}
227 :     ]
228 :     end
229 :    
230 :     (*
231 :     * Registers %o2, %o3 are used to pass arguments to ml_mul and ml_div
232 :     * Result is returned in %o2.
233 :     *)
234 :     val r10 = C.GPReg 10
235 :     val r11 = C.GPReg 11
236 :    
237 :     fun callRoutine(offset,reduceOpnd,r,i,d) =
238 :     let val addr = C.newReg()
239 :     val defs = C.addReg(r10,C.empty)
240 :     val uses = C.addReg(r10,C.addReg(r11,C.empty))
241 :     fun copy{dst, src, tmp} =
242 :     I.COPY{k=CellsBasis.GP, sz=32, dst=dst, src=src, tmp=tmp}
243 :     in
244 :     [copy{src=[r,reduceOpnd i],dst=[r10,r11],tmp=SOME(I.Direct(C.newReg()))},
245 :     I.load{l=I.LD,r=C.frameptrR,i=offset,d=addr,mem=stack},
246 :     I.jmpl{r=addr,i=I.IMMED 0,d=C.linkReg,defs=defs,uses=uses,
247 :     cutsTo=[],nop=true,mem=stack},
248 :     copy{src=[r10],dst=[d],tmp=NONE}
249 : mrainey 3173 ]
250 :     end
251 :    
252 : mrainey 3177 fun umul({r, i, d}, reduceOpnd) = callRoutine(umulOffset,reduceOpnd,r,i,d)
253 :     fun smultrap({r, i, d}, reduceOpnd) = callRoutine(smulOffset,reduceOpnd,r,i,d)
254 :     fun udiv({r, i, d}, reduceOpnd) = callRoutine(udivOffset,reduceOpnd,r,i,d)
255 :     fun sdivtrap({r, i, d}, reduceOpnd) = callRoutine(sdivOffset,reduceOpnd,r,i,d)
256 :    
257 :     fun cvti2d({i, d}, reduceOpnd) =
258 :     [I.store{s=I.ST,r=C.frameptrR,i=floatTmpOffset,d=reduceOpnd i,mem=stack},
259 :     I.fload{l=I.LDF,r=C.frameptrR,i=floatTmpOffset,d=d,mem=stack},
260 :     I.fpop1{a=I.FiTOd,r=d,d=d}
261 : mrainey 3173 ]
262 :     fun cvti2s _ = error "cvti2s"
263 :     fun cvti2q _ = error "cvti2q"
264 :    
265 : mrainey 3177 (* Generate native versions of the instructions *)
266 :     val umul32 = if native then umul_native else umul
267 :     val smul32 : format1 =
268 :     if native then smul_native else (fn _ => error "smul32")
269 :     val smul32trap = if native then smult_native else smultrap
270 :     val udiv32 = if native then udiv_native else udiv
271 :     val sdiv32 : format1 =
272 :     if native then sdiv_native else (fn _ => error "sdiv32")
273 :     val sdiv32trap = if native then sdivt_native else sdivtrap
274 : mrainey 3173
275 : mrainey 3177 val overflowtrap32 = (* tvs 0x7 *)
276 :     [I.ticc{t=I.BVS,cc=I.ICC,r=C.r0,i=I.IMMED 7}]
277 : mrainey 3173 val overflowtrap64 = [] (* not needed *)
278 : mrainey 3177
279 :    
280 : mrainey 3173 end
281 :    
282 :     structure SparcMLTreeHash =
283 :     MLTreeHash
284 :     (structure T = SparcMLTree
285 :     fun h _ _ = 0w0
286 :     val hashRext = h val hashFext = h
287 :     val hashCCext = h val hashSext = h)
288 :    
289 :     structure SparcProps =
290 :     SparcProps
291 :     (structure SparcInstr = SparcInstr
292 :     structure MLTreeEval = SparcMLTreeEval
293 :     structure MLTreeHash = SparcMLTreeHash)
294 :    
295 :     structure SparcAsmEmitter =
296 :     SparcAsmEmitter(structure Instr=SparcInstr
297 :     structure Shuffle=SparcShuffle
298 : mrainey 3177 structure S = SparcStream
299 : mrainey 3173 structure MLTreeEval=SparcMLTreeEval
300 :     val V9 = false)
301 :    
302 :    
303 :     structure SparcCFG =
304 :     ControlFlowGraph
305 :     (structure I = SparcInstr
306 :     structure PseudoOps = SparcPseudoOps
307 :     structure GraphImpl = DirectedGraph
308 :     structure InsnProps = SparcProps
309 :     structure Asm = SparcAsmEmitter)
310 :    
311 : mrainey 3177 structure SparcFlowGraph = BuildFlowgraph
312 :     (structure Props = SparcProps
313 :     structure Stream = SparcStream
314 :     structure CFG = SparcCFG)
315 :    
316 :     structure SparcExpand = CFGExpandCopies (structure CFG=SparcCFG
317 :     structure Shuffle = SparcShuffle)
318 :     structure SparcBlockPlacement = DefaultBlockPlacement(SparcCFG)
319 :    
320 :     structure SparcEmit = CFGEmit (
321 :     structure CFG = SparcCFG
322 :     structure E = SparcAsmEmitter)
323 :    
324 :     structure SparcCCall = SparcCCallFn (
325 :     structure T = SparcMLTree
326 :     fun ix x = raise Fail "")
327 :    
328 : mrainey 3173 (*
329 : mrainey 3177 * This module controls how we handle user extensions. Since we don't
330 :     * have any yet. This is just a bunch of dummy routines.
331 :     *)
332 :     structure SparcMLTreeExtComp : MLTREE_EXTENSION_COMP =
333 :     struct
334 :     structure TS = SparcMLTreeStream
335 :     structure I = SparcInstr
336 :     structure T = SparcMLTree
337 :     structure C = I.C
338 :     structure Ext = UserExtension
339 :     structure CFG = SparcCFG
340 :     structure SparcCompInstrExt =
341 :     SparcCompInstrExt(structure I = I structure CFG = CFG structure TS=SparcMLTreeStream)
342 :    
343 :     type reducer =
344 :     (I.instruction,C.cellset,I.operand,I.addressing_mode, CFG.cfg) TS.reducer
345 :     fun unimplemented _ = MLRiscErrorMsg.impossible "SparcMLTreeExtComp"
346 :    
347 :     val compileSext = SparcCompInstrExt.compileSext
348 :     val compileRext = unimplemented
349 :     val compileCCext = unimplemented
350 :     val compileFext = unimplemented
351 :     end
352 :    
353 : mrainey 3173 structure MLTreeComp=
354 :     Sparc(structure SparcInstr = SparcInstr
355 :     structure SparcMLTree = SparcMLTree
356 :     structure PseudoInstrs = SparcPseudoInstrs
357 :     structure ExtensionComp = SparcMLTreeExtComp
358 :     val V9 = false
359 :     val muluCost = ref 5
360 :     val multCost = ref 3
361 :     val divuCost = ref 5
362 :     val divtCost = ref 5
363 :     val registerwindow = ref false
364 :     val useBR = ref false
365 :     )
366 :    
367 :    
368 : mrainey 3177 structure InsnProps = SparcProps
369 :    
370 :     structure RA =
371 :     RISC_RA
372 :     (structure I = SparcInstr
373 :     structure C = CellsBasis
374 :     structure T = SparcMLTree
375 :     structure CFG = SparcCFG
376 :     structure InsnProps = InsnProps
377 :     structure Rewrite = SparcRewrite(SparcInstr)
378 :     structure SpillInstr= SparcSpillInstr(SparcInstr)
379 :     structure Asm = SparcAsmEmitter
380 :     structure SpillHeur = ChaitinSpillHeur
381 :     structure Spill = RASpill(structure InsnProps = InsnProps
382 :     structure Asm = SparcAsmEmitter)
383 :    
384 :     structure SpillTable = SpillTable(val initialSpillOffset = 0 (* This is probably wrong!!!!! *)
385 : mrainey 3173 val spillAreaSz = 4000
386 : mrainey 3177 val architecture = "Sparc" )
387 :     val fp = I.C.frameptrR
388 :     val spill = UserRegion.spill
389 :     datatype spillOperandKind = SPILL_LOC | CONST_VAL
390 :     type spill_info = unit
391 :     fun beforeRA _ = SpillTable.beginRA()
392 :    
393 :     val architecture = "Sparc"
394 :    
395 :     fun pure(I.ANNOTATION{i,...}) = pure i
396 :     | pure(I.INSTR(I.LOAD _)) = true
397 :     | pure(I.INSTR(I.FLOAD _)) = true
398 :     | pure(I.INSTR(I.SETHI _)) = true
399 :     | pure(I.INSTR(I.SHIFT _)) = true
400 :     | pure(I.INSTR(I.FPop1 _)) = true
401 :     | pure(I.INSTR(I.FPop2 _)) = true
402 :     | pure _ = false
403 :    
404 :     (* make copy *)
405 :     structure Int =
406 :     struct
407 :     val dedicated = [I.C.stackptrR, I.C.GPReg 0]
408 :     val avail =
409 :     C.SortedCells.return
410 : mrainey 3173 (C.SortedCells.difference(
411 :     C.SortedCells.uniq(
412 : mrainey 3177 SparcCells.Regs C.GP {from=0, to=31, step=1}),
413 : mrainey 3173 C.SortedCells.uniq dedicated)
414 :     )
415 :    
416 : mrainey 3177 fun mkDisp loc = T.LI(T.I.fromInt(32, SpillTable.get loc))
417 :     fun spillLoc{info, an, cell, id} =
418 :     {opnd=I.Displace{base=fp, disp=mkDisp(RAGraph.FRAME id), mem=spill},
419 :     kind=SPILL_LOC}
420 : mrainey 3173
421 : mrainey 3177 val mode = RACore.NO_OPTIMIZATION
422 :     end
423 :    
424 :     structure Float =
425 :     struct
426 :     fun fromto(n, m, inc) = if n>m then [] else n :: fromto(n+inc, m, inc)
427 :     val avail = SparcCells.Regs C.FP {from=0, to=30, step=2}
428 :     val dedicated = []
429 :    
430 :     fun mkDisp loc = T.LI(T.I.fromInt(32, SpillTable.getF loc))
431 :    
432 :     fun spillLoc(S, an, loc) =
433 :     I.Displace{base=fp, disp=mkDisp(RAGraph.FRAME loc), mem=spill}
434 :    
435 :     val mode = RACore.NO_OPTIMIZATION
436 :     end
437 :     )
438 :    
439 :     structure Cells = SparcInstr.C
440 :     structure T = SparcMLTree
441 :     structure CFG = SparcCFG
442 :     structure FlowGraph = SparcFlowGraph
443 :     val wordTy = 32
444 :    
445 :     fun gen (functionName, stms, result) = let
446 :     val insnStrm = FlowGraph.build()
447 :     val stream as SparcStream.STREAM
448 :     { beginCluster, (* start a cluster *)
449 :     endCluster, (* end a cluster *)
450 :     emit, (* emit MLTREE stm *)
451 :     defineLabel, (* define a local label *)
452 :     entryLabel, (* define an external entry *)
453 :     exitBlock, (* mark the end of a procedure *)
454 :     pseudoOp, (* emit a pseudo op *)
455 :     annotation, (* add an annotation *)
456 :     ... } =
457 :     MLTreeComp.selectInstructions insnStrm
458 :     fun doit () = (
459 :     beginCluster 0; (* start a new cluster *)
460 :     pseudoOp PseudoOpsBasisTyp.TEXT;
461 :     pseudoOp (PseudoOpsBasisTyp.EXPORT [functionName]);
462 :     entryLabel functionName; (* define the entry label *)
463 :     List.app emit stms; (* emit all the statements *)
464 :     exitBlock result;
465 :     endCluster [])
466 :     val cfg = doit ()
467 :     val cfg = RA.run cfg
468 :     val cfg = SparcExpand.run cfg
469 :     in
470 :     (cfg, stream) (* end the cluster *)
471 : mrainey 3173 end
472 :    
473 : mrainey 3177 fun dumpOutput (cfg, stream) = let
474 :     val (cfg as Graph.GRAPH graph, blocks) =
475 :     SparcBlockPlacement.blockPlacement cfg
476 :     val CFG.INFO{annotations=an, data, decls, ...} = #graph_info graph
477 :     in
478 :     SparcEmit.asmEmit (cfg, blocks)
479 :     end (* dumpOutput *)
480 :    
481 : mrainey 3173
482 : mrainey 3177 fun codegen (functionName, target, proto, initStms, args) = let
483 :     val _ = Label.reset()
484 :    
485 :     val [functionName, target] = List.map Label.global [functionName, target]
486 :    
487 :     (* construct the C call *)
488 :     val {result, callseq} = SparcCCall.genCall {
489 :     name=T.LABEL target,
490 :     paramAlloc=fn _ => false,
491 :     (* FIXME *)
492 :     structRet=fn _ => T.REG(32, SparcCells.GPReg 0),
493 :     saveRestoreDedicated=fn _ => {save=[], restore=[]},
494 :     callComment=NONE,
495 :     proto=proto,
496 :     args=args}
497 :    
498 :     fun wordLit i = T.LI (T.I.fromInt (wordTy, i))
499 :    
500 :     val stms = List.concat [
501 :     initStms,
502 :     callseq,
503 :     [T.RET []]]
504 :    
505 :     (* val _ = List.all (fn stm => ChkTy.check stm
506 :     orelse raise Fail ("typechecking error: "^SparcMTC.SparcMLTreeUtils.stmToString stm))
507 :     stms
508 : mrainey 3173 *)
509 : mrainey 3177
510 :     in
511 :     dumpOutput(gen (functionName, stms, result))
512 :     end
513 :    
514 :     val GP = SparcCells.GPReg
515 :     val FP = SparcCells.FPReg
516 :    
517 :     fun greg r = GP r
518 :     fun oreg r = GP (r + 8)
519 :     fun ireg r = GP (r + 24)
520 :     fun freg r = FP r
521 :     fun reg32 r = T.REG (32, r)
522 :     fun freg64 r = T.FREG (64, r)
523 :     fun LI i = T.LI (T.I.fromInt (32, i))
524 :    
525 :    
526 : mrainey 3173 in
527 : mrainey 3177 structure SparcTest = GenTestFn (
528 :     structure T = SparcMLTree
529 :     structure CCall = SparcCCall
530 :     structure Cells = SparcCells
531 :     val codegen = codegen
532 :     val param0 = reg32(oreg 0)
533 :     val wordTy = 32)
534 : mrainey 3173 end

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