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/staged-alloc/allocator/staged-allocation-fn.sml
ViewVC logotype

Annotation of /MLRISC/trunk/staged-alloc/allocator/staged-allocation-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3177 - (view) (download)

1 : mrainey 3177 c-call/cm/group.cm
2 :     functor SparcCCallFn
3 :    
4 :     structure X86MLRISCGen
5 :     structure X86MLTree
6 :     structure X86Test
7 :     structure X86_64Test
8 :     structure SparcTest
9 :     structure CType
10 :    
11 :     group(../../staged-alloc/cm/sources.cm)
12 :     library(../../cm/MLRISC.cm)
13 :     library(../../cm/IA32.cm)
14 :     library(../../cm/AMD64.cm)
15 :     is
16 :    
17 :     $/basis.cm
18 :     $/smlnj-lib.cm
19 :     $/controls-lib.cm
20 :     $/pp-lib.cm
21 :     $smlnj-tdp/plugins.cm
22 :    
23 :     ../../cm/Control.cm
24 :     ../../cm/Lib.cm
25 :     ../../cm/MLRISC.cm
26 :     ../../cm/Graphs.cm
27 :     ../../cm/MLTREE.cm
28 :     ../../cm/RA.cm
29 :     ../../cm/Visual.cm
30 :     ../../cm/Peephole.cm
31 :     ../../cm/IA32.cm
32 :     ../../cm/AMD64.cm
33 :     ../../cm/RTL.cm
34 :     ../../cm/SPARC.cm
35 :    
36 :     ../gen/c-call-sig.sml
37 :     ../gen/c-call-fn.sml
38 :     ../gen/c-type.sml
39 :    
40 :     ../../staged-alloc/cm/sources.cm
41 :    
42 :     ../archs/x86-64-svid-fn.sml
43 :     ../archs/x86-64-c-sizes.sml
44 :     ../archs/x86-svid-fn.sml
45 :     ../archs/x86-c-sizes.sml
46 :     ../archs/sparc-c-sizes.sml
47 :     ../archs/sparc-c-call-fn.sml
48 :    
49 :     ../test/c-test-gen.sml
50 :     ../test/c-x86-test.sml
51 :     ../test/c-x86-64-test.sml
52 :     ../test/c-sparc-test.sml
53 :     ../test/spill-table.sml
54 :     * First, some front-end dependent stuff. Typically, you only need
55 :     * one instance of these things for each source language.
56 :     *---------------------------------------------------------------------------*)
57 :    
58 :     (*
59 :     * User defined constant type. Dummy for now.
60 :     * In practice, you'll want to use this type to implement constants with
61 :     * values that cannot be determined until final code generation, e.g.
62 :     * stack frame offset.
63 :     *)
64 :     structure UserConst =
65 :     struct
66 :     type const = unit
67 :     fun toString() = ""
68 :     fun hash() = 0w0
69 :     fun valueOf _ = 0
70 :     fun == _ = true
71 :     end
72 :    
73 :     (*
74 :     * Instantiate label expressions with respect to user defined constants.
75 :     * This type is somewhat misnamed; it is used to represent constant
76 :     * expressions.
77 :     *)
78 :     (* structure LabelExp = LabelExp(UserConst) *)
79 :    
80 :     (*
81 :     * User defined datatype for representing aliasing. Dummy for now.
82 :     * You'll need this to represent aliasing information.
83 :     *)
84 :     structure UserRegion =
85 :     struct
86 :     type region = unit
87 :     fun toString () = ""
88 :     val memory = ()
89 :     val stack = ()
90 :     val readonly = ()
91 :     val spill = ()
92 :     end
93 :    
94 :     (*
95 :     * User defined datatype for representing pseudo assembly operators.
96 :     * Dummy for now.
97 :     *
98 :     * You'll need this to represent assembler directives.
99 :     *)
100 :     structure UserPseudoOps =
101 :     struct
102 :     type pseudo_op = unit
103 :     fun toString () = ""
104 : mrainey 3140 fun emitValue _ = ()
105 : mrainey 3177 fun sizeOf _ = 0
106 : mrainey 3140 fun adjustLabels _ = true
107 : mrainey 3177 end
108 :    
109 :    
110 :     (*
111 :     * Instruction stream datatype.
112 :     * This is just a simple record type used by MLRISC to represent
113 :     * instruction streams.
114 :     *)
115 : mrainey 3140 (*structure Stream = InstructionStream(UserPseudoOps)*)
116 : mrainey 3177
117 :     (*
118 :     * Client defined extensions. None for now.
119 :     * You'll need this only if you need to extend the set of MLTREE operators
120 :     *)
121 :     structure UserExtension =
122 :     struct
123 :    
124 :     type ('s,'r,'f,'c) sx = ('s,'r,'f,'c) SparcInstrExt.sext
125 :     type ('s,'r,'f,'c) rx = unit
126 :     type ('s,'r,'f,'c) fx = unit
127 :     type ('s,'r,'f,'c) ccx = unit
128 :    
129 :     end
130 :    
131 :     structure SparcMLTree =
132 :     MLTreeF (structure Constant = UserConst
133 :     structure Region = UserRegion
134 :     structure Extension = UserExtension)
135 :    
136 :    
137 :     (*---------------------------------------------------------------------------
138 :     * Backend specific stuff. You'll need one instance of these things
139 :     * for each architecture.
140 :     *---------------------------------------------------------------------------*)
141 :    
142 :     (*
143 :     * The Sparc instruction set, specialized with respect to the
144 :     * user constant and region types.
145 :     *)
146 :     structure SparcInstr = SparcInstr
147 :     (SparcMLTree
148 :     )
149 :    
150 :     (*
151 :     * How to serialize parallel copies
152 :     *)
153 :     structure SparcShuffle = SparcShuffle(SparcInstr)
154 :    
155 :     structure SparcMLTreeEval =
156 :     MLTreeEval (structure T = SparcMLTree
157 :     fun eq _ _ = false
158 :     val eqRext = eq val eqFext = eq
159 :     val eqCCext = eq val eqSext = eq)
160 :    
161 :     functor SparcPseudoOpsFn (
162 :     structure T : MLTREE
163 :     structure MLTreeEval : MLTREE_EVAL where T = T
164 :     ) : PSEUDO_OPS_BASIS = SparcGasPseudoOps (
165 :     structure T = SparcMLTree
166 :     structure MLTreeEval = SparcMLTreeEval)
167 :    
168 :     structure SparcPseudoOps = SparcPseudoOpsFn(
169 :     structure T = SparcMLTree
170 :     structure MLTreeEval = SparcMLTreeEval)
171 :    
172 :     structure PseudoOps =
173 :     struct
174 :    
175 :     structure Client =
176 :     struct
177 :     structure AsmPseudoOps = SparcPseudoOps
178 :     type pseudo_op = unit
179 :    
180 : mrainey 3140 fun toString () = ""
181 :    
182 : mrainey 3177 fun emitValue _ = raise Fail "todo"
183 :     fun sizeOf _ = raise Fail "todo"
184 :     fun adjustLabels _ = raise Fail "todo"
185 :     end (* Client *)
186 :    
187 :     structure PseudoOps = PseudoOps (structure Client = Client)
188 :     end
189 :    
190 :     structure SparcStream = InstructionStream(PseudoOps.PseudoOps)
191 :     structure SparcMLTreeStream =
192 :     MLTreeStream
193 :     (structure T = SparcMLTree
194 :     structure S = SparcStream)
195 :    
196 : mrainey 3140 (*
197 : mrainey 3177 * The assembler
198 :     *)
199 :     structure SparcAsm = SparcAsmEmitter
200 :     (structure Instr = SparcInstr
201 :     structure Stream = SparcStream
202 : mrainey 3140 structure Shuffle = SparcShuffle
203 : mrainey 3177 structure S = SparcStream
204 :     structure MLTreeEval = SparcMLTreeEval
205 :     val V9 = false (* we'll generate V8 instructions for now *)
206 :     )
207 :    
208 :     structure SparcPseudoInstrs : SPARC_PSEUDO_INSTR =
209 :     struct
210 :     structure I = SparcInstr
211 :     structure C = I.C
212 :    
213 :     type format1 =
214 : mrainey 3140 {r:CellsBasis.cell, i:I.operand, d:CellsBasis.cell} *
215 : mrainey 3177 (I.operand -> CellsBasis.cell) -> I.instruction list
216 :    
217 :     type format2 =
218 :     {i:I.operand, d:CellsBasis.cell} *
219 :     (I.operand -> CellsBasis.cell) -> I.instruction list
220 :    
221 :     fun error msg = MLRiscErrorMsg.impossible ("SparcPseudoInstrs."^msg)
222 :    
223 :     val delta = 0 (*SparcSpec.framesize*) (* initial value of %fp - %sp *)
224 :    
225 :     (* runtime system dependent; the numbers are relative to %sp but
226 :     * we need offsets relative to %fp, hence the adjustment by delta *)
227 :     val floatTmpOffset = I.IMMED (88 - delta)
228 :     val umulOffset = I.IMMED (80 - delta)
229 :     val smulOffset = I.IMMED (72 - delta)
230 :     val udivOffset = I.IMMED (84 - delta)
231 :     val sdivOffset = I.IMMED (76 - delta)
232 :    
233 :     val stack = () (*CPSRegions.stack*)
234 :    
235 :     val native = true (* use native versions of the instructions? *)
236 :    
237 :     fun umul_native({r, i, d}, reduceOpnd) =
238 :     [I.arith{a=I.UMUL,r=r,i=i,d=d}]
239 :    
240 :     val TNE = I.ticc{t=I.BNE,cc=I.ICC,r=C.r0,i=I.IMMED 7}
241 :     val TVS = I.ticc{t=I.BVS,cc=I.ICC,r=C.r0,i=I.IMMED 7}
242 :    
243 :     (* overflows iff Y != (d ~>> 31) *)
244 :     fun smult_native({r, i, d}, reduceOpnd) =
245 :     let val t1 = C.newReg()
246 :     val t2 = C.newReg()
247 :     in [I.arith{a=I.SMUL,r=r,i=i,d=d},
248 :     I.shift{s=I.SRA,r=d,i=I.IMMED 31,d=t1},
249 :     I.rdy{d=t2},
250 :     I.arith{a=I.SUBCC,r=t1,i=I.REG t2,d=C.r0},
251 :     TNE
252 :     ]
253 :     end
254 :    
255 :     fun smul_native({r, i, d}, reduceOpnd) =
256 :     [I.arith{a=I.SMUL,r=r,i=i,d=d}]
257 :    
258 :     fun udiv_native({r,i,d},reduceOpnd) =
259 :     [I.wry{r=C.r0,i=I.REG C.r0},
260 :     I.arith{a=I.UDIV,r=r,i=i,d=d}]
261 :    
262 :     (* May overflow if MININT div -1 *)
263 :     fun sdivt_native({r,i,d},reduceOpnd) =
264 :     let val t1 = C.newReg()
265 :     in [I.shift{s=I.SRA,r=r,i=I.IMMED 31,d=t1},
266 :     I.wry{r=t1,i=I.REG C.r0},
267 :     I.arith{a=I.SDIVCC,r=r,i=i,d=d},
268 :     TVS
269 :     ]
270 :     end
271 :    
272 :     fun sdiv_native({r,i,d},reduceOpnd) =
273 :     let val t1 = C.newReg()
274 :     in [I.shift{s=I.SRA,r=r,i=I.IMMED 31,d=t1},
275 :     I.wry{r=t1,i=I.REG C.r0},
276 :     I.arith{a=I.SDIV,r=r,i=i,d=d}
277 :     ]
278 :     end
279 :    
280 :     (*
281 :     * Registers %o2, %o3 are used to pass arguments to ml_mul and ml_div
282 :     * Result is returned in %o2.
283 :     *)
284 :     val r10 = C.GPReg 10
285 :     val r11 = C.GPReg 11
286 :    
287 :     fun callRoutine(offset,reduceOpnd,r,i,d) =
288 :     let val addr = C.newReg()
289 :     val defs = C.addReg(r10,C.empty)
290 : mrainey 3140 val uses = C.addReg(r10,C.addReg(r11,C.empty))
291 : mrainey 3177 fun copy{dst, src, tmp} =
292 :     I.COPY{k=CellsBasis.GP, sz=32, dst=dst, src=src, tmp=tmp}
293 :     in
294 :     [copy{src=[r,reduceOpnd i],dst=[r10,r11],tmp=SOME(I.Direct(C.newReg()))},
295 :     I.load{l=I.LD,r=C.frameptrR,i=offset,d=addr,mem=stack},
296 :     I.jmpl{r=addr,i=I.IMMED 0,d=C.linkReg,defs=defs,uses=uses,
297 :     cutsTo=[],nop=true,mem=stack},
298 :     copy{src=[r10],dst=[d],tmp=NONE}
299 :     ]
300 :     end
301 :    
302 :     fun umul({r, i, d}, reduceOpnd) = callRoutine(umulOffset,reduceOpnd,r,i,d)
303 :     fun smultrap({r, i, d}, reduceOpnd) = callRoutine(smulOffset,reduceOpnd,r,i,d)
304 :     fun udiv({r, i, d}, reduceOpnd) = callRoutine(udivOffset,reduceOpnd,r,i,d)
305 :     fun sdivtrap({r, i, d}, reduceOpnd) = callRoutine(sdivOffset,reduceOpnd,r,i,d)
306 :    
307 :     fun cvti2d({i, d}, reduceOpnd) =
308 :     [I.store{s=I.ST,r=C.frameptrR,i=floatTmpOffset,d=reduceOpnd i,mem=stack},
309 :     I.fload{l=I.LDF,r=C.frameptrR,i=floatTmpOffset,d=d,mem=stack},
310 :     I.fpop1{a=I.FiTOd,r=d,d=d}
311 :     ]
312 :     fun cvti2s _ = error "cvti2s"
313 :     fun cvti2q _ = error "cvti2q"
314 :    
315 :     (* Generate native versions of the instructions *)
316 :     val umul32 = if native then umul_native else umul
317 :     val smul32 : format1 =
318 :     if native then smul_native else (fn _ => error "smul32")
319 :     val smul32trap = if native then smult_native else smultrap
320 :     val udiv32 = if native then udiv_native else udiv
321 :     val sdiv32 : format1 =
322 :     if native then sdiv_native else (fn _ => error "sdiv32")
323 :     val sdiv32trap = if native then sdivt_native else sdivtrap
324 :    
325 :     val overflowtrap32 = (* tvs 0x7 *)
326 :     [I.ticc{t=I.BVS,cc=I.ICC,r=C.r0,i=I.IMMED 7}]
327 :     val overflowtrap64 = [] (* not needed *)
328 :    
329 :    
330 :     end
331 :    
332 :     structure SparcMLTreeHash =
333 :     MLTreeHash
334 :     (structure T = SparcMLTree
335 :     fun h _ _ = 0w0
336 :     val hashRext = h val hashFext = h
337 :     val hashCCext = h val hashSext = h)
338 :    
339 :     structure SparcProps =
340 :     SparcProps
341 :     (structure SparcInstr = SparcInstr
342 :     structure MLTreeEval = SparcMLTreeEval
343 :     structure MLTreeHash = SparcMLTreeHash)
344 :    
345 :     structure SparcAsmEmitter =
346 :     SparcAsmEmitter(structure Instr=SparcInstr
347 :     structure Shuffle=SparcShuffle
348 :     structure S = SparcStream
349 :     structure MLTreeEval=SparcMLTreeEval
350 :     val V9 = false)
351 :    
352 :    
353 :     structure SparcCFG =
354 :     ControlFlowGraph
355 :     (structure I = SparcInstr
356 :     structure PseudoOps = SparcPseudoOps
357 :     structure GraphImpl = DirectedGraph
358 :     structure InsnProps = SparcProps
359 :     structure Asm = SparcAsmEmitter)
360 :    
361 :     structure SparcFlowGraph = BuildFlowgraph
362 :     (structure Props = SparcProps
363 :     structure Stream = SparcStream
364 :     structure CFG = SparcCFG)
365 :    
366 :     structure SparcExpand = CFGExpandCopies (structure CFG=SparcCFG
367 :     structure Shuffle = SparcShuffle)
368 :     structure SparcBlockPlacement = DefaultBlockPlacement(SparcCFG)
369 :    
370 :     structure SparcEmit = CFGEmit (
371 :     structure CFG = SparcCFG
372 :     structure E = SparcAsmEmitter)
373 :    
374 :     structure SparcCCall = SparcCCallFn (
375 :     structure T = SparcMLTree
376 :     fun ix x = raise Fail "")
377 :    
378 :     (*
379 :     * This module controls how we handle user extensions. Since we don't
380 :     * have any yet. This is just a bunch of dummy routines.
381 :     *)
382 :     structure SparcMLTreeExtComp : MLTREE_EXTENSION_COMP =
383 :     struct
384 :     structure TS = SparcMLTreeStream
385 :     structure I = SparcInstr
386 :     structure T = SparcMLTree
387 :     structure C = I.C
388 :     structure Ext = UserExtension
389 :     structure CFG = SparcCFG
390 :     structure SparcCompInstrExt =
391 :     SparcCompInstrExt(structure I = I structure CFG = CFG structure TS=SparcMLTreeStream)
392 :    
393 :     type reducer =
394 :     (I.instruction,C.cellset,I.operand,I.addressing_mode, CFG.cfg) TS.reducer
395 :     fun unimplemented _ = MLRiscErrorMsg.impossible "SparcMLTreeExtComp"
396 :    
397 :     val compileSext = SparcCompInstrExt.compileSext
398 :     val compileRext = unimplemented
399 :     val compileCCext = unimplemented
400 :     val compileFext = unimplemented
401 :     end
402 :    
403 :     structure MLTreeComp=
404 :     Sparc(structure SparcInstr = SparcInstr
405 :     structure SparcMLTree = SparcMLTree
406 :     structure PseudoInstrs = SparcPseudoInstrs
407 :     structure ExtensionComp = SparcMLTreeExtComp
408 :     val V9 = false
409 :     val muluCost = ref 5
410 :     val multCost = ref 3
411 :     val divuCost = ref 5
412 :     val divtCost = ref 5
413 :     val registerwindow = ref false
414 :     val useBR = ref false
415 :     )
416 :    
417 :    
418 :     structure InsnProps = SparcProps
419 :    
420 :     structure RA =
421 :     RISC_RA
422 :     (structure I = SparcInstr
423 :     structure C = CellsBasis
424 :     structure T = SparcMLTree
425 :     structure CFG = SparcCFG
426 :     structure InsnProps = InsnProps
427 :     structure Rewrite = SparcRewrite(SparcInstr)
428 :     structure SpillInstr= SparcSpillInstr(SparcInstr)
429 :     structure Asm = SparcAsmEmitter
430 :     structure SpillHeur = ChaitinSpillHeur
431 :     structure Spill = RASpill(structure InsnProps = InsnProps
432 :     structure Asm = SparcAsmEmitter)
433 :    
434 :     structure SpillTable = SpillTable(val initialSpillOffset = 0 (* This is probably wrong!!!!! *)
435 :     val spillAreaSz = 4000
436 :     val architecture = "Sparc" )
437 :     val fp = I.C.frameptrR
438 :     val spill = UserRegion.spill
439 :     datatype spillOperandKind = SPILL_LOC | CONST_VAL
440 :     type spill_info = unit
441 :     fun beforeRA _ = SpillTable.beginRA()
442 :    
443 :     val architecture = "Sparc"
444 :    
445 :     fun pure(I.ANNOTATION{i,...}) = pure i
446 :     | pure(I.INSTR(I.LOAD _)) = true
447 :     | pure(I.INSTR(I.FLOAD _)) = true
448 :     | pure(I.INSTR(I.SETHI _)) = true
449 :     | pure(I.INSTR(I.SHIFT _)) = true
450 :     | pure(I.INSTR(I.FPop1 _)) = true
451 :     | pure(I.INSTR(I.FPop2 _)) = true
452 :     | pure _ = false
453 :    
454 :     (* make copy *)
455 :     structure Int =
456 :     struct
457 :     val dedicated = [I.C.stackptrR, I.C.GPReg 0]
458 :     val avail =
459 :     C.SortedCells.return
460 :     (C.SortedCells.difference(
461 :     C.SortedCells.uniq(
462 :     SparcCells.Regs C.GP {from=0, to=31, step=1}),
463 :     C.SortedCells.uniq dedicated)
464 :     )
465 :    
466 :     fun mkDisp loc = T.LI(T.I.fromInt(32, SpillTable.get loc))
467 :     fun spillLoc{info, an, cell, id} =
468 :     {opnd=I.Displace{base=fp, disp=mkDisp(RAGraph.FRAME id), mem=spill},
469 :     kind=SPILL_LOC}
470 :    
471 :     val mode = RACore.NO_OPTIMIZATION
472 :     end
473 :    
474 :     structure Float =
475 :     struct
476 :     fun fromto(n, m, inc) = if n>m then [] else n :: fromto(n+inc, m, inc)
477 :     val avail = SparcCells.Regs C.FP {from=0, to=30, step=2}
478 :     val dedicated = []
479 :    
480 :     fun mkDisp loc = T.LI(T.I.fromInt(32, SpillTable.getF loc))
481 :    
482 :     fun spillLoc(S, an, loc) =
483 :     I.Displace{base=fp, disp=mkDisp(RAGraph.FRAME loc), mem=spill}
484 :    
485 :     val mode = RACore.NO_OPTIMIZATION
486 :     end
487 :     )
488 :    
489 :     structure Cells = SparcInstr.C
490 :     structure T = SparcMLTree
491 :     structure CFG = SparcCFG
492 :     structure FlowGraph = SparcFlowGraph
493 :     val wordTy = 32
494 :    
495 :     fun gen (functionName, stms, result) = let
496 :     val insnStrm = FlowGraph.build()
497 :     val stream as SparcStream.STREAM
498 :     { beginCluster, (* start a cluster *)
499 :     endCluster, (* end a cluster *)
500 :     emit, (* emit MLTREE stm *)
501 :     defineLabel, (* define a local label *)
502 :     entryLabel, (* define an external entry *)
503 :     exitBlock, (* mark the end of a procedure *)
504 :     pseudoOp, (* emit a pseudo op *)
505 :     annotation, (* add an annotation *)
506 :     ... } =
507 :     MLTreeComp.selectInstructions insnStrm
508 :     fun doit () = (
509 :     beginCluster 0; (* start a new cluster *)
510 :     pseudoOp PseudoOpsBasisTyp.TEXT;
511 :     pseudoOp (PseudoOpsBasisTyp.EXPORT [functionName]);
512 :     entryLabel functionName; (* define the entry label *)
513 :     List.app emit stms; (* emit all the statements *)
514 :     exitBlock result;
515 :     endCluster [])
516 :     val cfg = doit ()
517 :     val cfg = RA.run cfg
518 :     val cfg = SparcExpand.run cfg
519 :     in
520 :     (cfg, stream) (* end the cluster *)
521 :     end
522 :    
523 :     fun dumpOutput (cfg, stream) = let
524 :     val (cfg as Graph.GRAPH graph, blocks) =
525 :     SparcBlockPlacement.blockPlacement cfg
526 :     val CFG.INFO{annotations=an, data, decls, ...} = #graph_info graph
527 :     in
528 :     SparcEmit.asmEmit (cfg, blocks)
529 :     end (* dumpOutput *)
530 :    
531 :    
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} = SparcCCall.genCall {
539 :     name=T.LABEL target,
540 :     paramAlloc=fn _ => false,
541 :     (* FIXME *)
542 :     structRet=fn _ => T.REG(32, SparcCells.GPReg 0),
543 :     saveRestoreDedicated=fn _ => {save=[], restore=[]},
544 :     callComment=NONE,
545 :     proto=proto,
546 :     args=args}
547 :    
548 :     fun wordLit i = T.LI (T.I.fromInt (wordTy, i))
549 :    
550 :     val stms = List.concat [
551 :     initStms,
552 :     callseq,
553 :     [T.RET []]]
554 :    
555 :     (* val _ = List.all (fn stm => ChkTy.check stm
556 :     orelse raise Fail ("typechecking error: "^SparcMTC.SparcMLTreeUtils.stmToString stm))
557 :     stms
558 :     *)
559 :    
560 :     in
561 :     dumpOutput(gen (functionName, stms, result))
562 :     end
563 :    
564 :     val GP = SparcCells.GPReg
565 :     val FP = SparcCells.FPReg
566 :    
567 :     fun greg r = GP r
568 :     fun oreg r = GP (r + 8)
569 :     fun ireg r = GP (r + 24)
570 :     fun freg r = FP r
571 :     fun reg32 r = T.REG (32, r)
572 :     fun freg64 r = T.FREG (64, r)
573 :     fun LI i = T.LI (T.I.fromInt (32, i))
574 :    
575 :    
576 :     in
577 :     structure SparcTest = GenTestFn (
578 :     structure T = SparcMLTree
579 :     structure CCall = SparcCCall
580 :     structure Cells = SparcCells
581 :     val codegen = codegen
582 :     val param0 = reg32(oreg 0)
583 :     val wordTy = 32)
584 :     end
585 :    
586 :     val initialSpillOffset : int
587 :     val spillAreaSz : int
588 :     ) :
589 :     sig
590 :    
591 :     val architecture : string
592 :     val beginRA : unit -> unit
593 :     val get : RAGraph.spillLoc -> int
594 :     val getF : RAGraph.spillLoc -> int
595 :    
596 :     end =
597 :     struct
598 :    
599 :     structure G = RAGraph
600 :    
601 :     fun error msg = MLRiscErrorMsg.error(architecture^".SpillTable",msg)
602 :    
603 :     val itow = Word.fromInt
604 :    
605 :     val architecture = architecture
606 :    
607 :     exception RegSpills and FregSpills
608 :     val spillOffset = ref initialSpillOffset
609 :     val regspills : int G.SpillLocHashTable.hash_table =
610 :     G.SpillLocHashTable.mkTable(0,RegSpills)
611 :     val fregspills : int G.SpillLocHashTable.hash_table =
612 :     G.SpillLocHashTable.mkTable(0,FregSpills)
613 :     val lookupReg = G.SpillLocHashTable.lookup regspills
614 :     val enterReg = G.SpillLocHashTable.insert regspills
615 :     val lookupFreg = G.SpillLocHashTable.lookup fregspills
616 :     val enterFreg = G.SpillLocHashTable.insert fregspills
617 :    
618 :     fun beginRA() =
619 :     ((* Reset the regspills/fregspills map by need. *)
620 :     if !spillOffset = initialSpillOffset then ()
621 :     else (G.SpillLocHashTable.clear regspills;
622 :     G.SpillLocHashTable.clear fregspills
623 :     )
624 :     ;
625 :     spillOffset := initialSpillOffset
626 :     )
627 :    
628 :     fun newOffset offset =
629 :     if offset >= spillAreaSz then error "spill area too small"
630 :     else spillOffset := offset
631 :    
632 :     (* Get spill location for integer registers *)
633 :     fun get loc =
634 :     lookupReg loc handle _ =>
635 :     let val offset = !spillOffset
636 :     in newOffset(offset+4);
637 :     enterReg (loc,offset);
638 :     offset
639 :     end
640 :    
641 :     (* Get spill location for floating point registers *)
642 :     fun getF loc =
643 :     lookupFreg loc handle _ =>
644 :     let val offset = !spillOffset
645 :     val aligned = Word.toIntX (Word.andb(itow (offset+7), itow ~8))
646 :     in
647 :     newOffset(aligned+8);
648 :     enterFreg (loc, aligned);
649 :     aligned
650 :     end
651 :    
652 :     end
653 :    
654 :    
655 :     build-sparc:
656 :     ml-build $(ML_BUILD_FLAGS) ../cm/wrapper.cm SparcTest.main test-main
657 :     sml @SMLcmdname=test-main @SMLload=test-main
658 :     gcc -g -c mlrisc.s
659 :     gcc -g -c glue.c
660 :     gcc -g -c sanity.c
661 :     gcc -g mlrisc.o glue.o sanity.o -o sanity
662 :     gcc -g -c main.c
663 :     gcc -g mlrisc.o glue.o main.o -o main
664 :     ./main > main.out
665 :     ./sanity > sanity.out
666 :     diff -Naur main.out sanity.out
667 :    
668 :     build-x86-64:
669 :     ml-build $(ML_BUILD_FLAGS) ../cm/wrapper.cm X86_64Test.main test-main
670 :     sml @SMLcmdname=test-main @SMLload=test-main
671 :     gcc -g -m64 -c mlrisc.s
672 :     gcc -g -m64 -c glue.c
673 :     gcc -g -m64 -c sanity.c
674 :     gcc -g -m64 mlrisc.o glue.o sanity.o -o sanity
675 :     gcc -g -m64 -c main.c
676 :     gcc -g -m64 mlrisc.o glue.o main.o -o main
677 :     ./main > main.out
678 :     ./sanity > sanity.out
679 :     diff -Naur main.out sanity.out
680 :    
681 :     X86_FLAGS=-m32 -march=i686 -g
682 :    
683 :     build-x86:
684 :     ml-build $(ML_BUILD_FLAGS) ../cm/wrapper.cm X86Test.main test-main
685 :     sml @SMLcmdname=test-main @SMLload=test-main
686 :     gcc $(X86_FLAGS) -c mlrisc.s
687 :     gcc $(X86_FLAGS) -c glue.c
688 :     gcc $(X86_FLAGS) -c sanity.c
689 :     gcc $(X86_FLAGS) -S glue.c
690 :     gcc $(X86_FLAGS) mlrisc.o glue.o sanity.o -o sanity
691 :     gcc $(X86_FLAGS) -c main.c
692 :     gcc $(X86_FLAGS) mlrisc.o glue.o main.o -o main
693 :     ./main > main.out
694 :     ./sanity > sanity.out
695 :     diff -Naur main.out sanity.out
696 :    
697 :     clean:
698 :     rm -rf *.s *.c *.o main sanity *~ .cm *.out test-main*
699 :     *
700 :     * Generate the interpreter loop.
701 :     *)
702 :    
703 :     functor GenFn (
704 :     structure T : MLTREE
705 :     (* general-purpose registers used for passing or returning arguments *)
706 :     val gprs : T.reg list
707 :     (* floating-point registers used for passing or returning arguments *)
708 :     val fprs : T.reg list
709 :     (* possible widths *)
710 :     val gprWidths : T.ty list
711 :     val fprWidths : T.ty list
712 :     (* stack pointer register *)
713 :     val spReg : T.rexp
714 :     val defaultWidth : T.ty
715 :     val callerSaves : T.reg list
716 :     val callerSavesF : T.reg list
717 :     ) :> sig
718 :    
719 :     (* generate the machine-independent part of the vararg interpreter *)
720 :     val gen : {interpFunPtr : T.rexp, largsReg : T.reg, endOfLargs : T.rexp} -> T.stm list
721 :    
722 :     end = struct
723 :    
724 :     structure Consts = VarargConstants
725 :     structure SA = StagedAllocation(
726 :     type reg_id = T.reg
727 :     datatype loc_kind = datatype CLocKind.loc_kind
728 :     val memSize = 4)
729 :    
730 :     datatype loc
731 :     = REG_LOC of T.reg
732 :     | STK_LOC
733 :    
734 :     datatype loc_kind = datatype CLocKind.loc_kind
735 :    
736 :     (* as we go from top to bottom, we become increasingly specific about the destination of the argument. *)
737 :     datatype branch
738 : mrainey 3140 = ENTRY of {larg : T.rexp, ks : loc_kind list, widths : T.ty list, narrowings : T.ty list, locs : loc list}
739 : mrainey 3177 | KIND of {larg : T.rexp, k : loc_kind, widths : T.ty list, narrowings : T.ty list, locs : loc list}
740 :     | WIDTH of {larg : T.rexp, k : loc_kind, width : T.ty, narrowings : T.ty list, locs : loc list}
741 : mrainey 3140 | NARROWING of {larg : T.rexp, k : loc_kind, width : T.ty, narrowing : T.ty, locs : loc list}
742 : mrainey 3177 | LOC of {larg : T.rexp, k : loc_kind, width : T.ty, narrowing : T.ty, loc : loc}
743 : mrainey 3140
744 : mrainey 3177 val regToInt = CellsBasis.physicalRegisterNum
745 :     fun locToInt (REG_LOC r) = regToInt r
746 :     | locToInt STK_LOC = 0
747 :    
748 :     (* labels *)
749 :     local
750 :     val instLabels = ref ([] : (string * Label.label) list)
751 : mrainey 3140 fun newLabel s = (case List.find (fn (s', _) => s' = s) (!instLabels)
752 : mrainey 3177 of NONE => let
753 :     val l = Label.label s ()
754 :     in
755 :     instLabels := (s, l) :: !instLabels;
756 :     l
757 : mrainey 3140 end
758 : mrainey 3177 | SOME (s, l) => l
759 :     (* end case *))
760 :     fun kindToString GPR = "GPR"
761 :     | kindToString FPR = "FPR"
762 :     | kindToString STK = "STK"
763 :     | kindToString FSTK = "FSTK"
764 :     val c = String.concatWith "."
765 :     val i2s = Int.toString
766 :     fun locToString (REG_LOC r) = "r"^i2s (regToInt r)
767 :     | locToString STK_LOC = "stk"
768 :     fun instToString (ENTRY {...}) = "entry"
769 :     | instToString (KIND {k, ...}) = c["kind", kindToString k]
770 :     | instToString (WIDTH {k, width, ...}) = c["width", kindToString k, i2s width]
771 :     | instToString (NARROWING {k, width, narrowing, ...}) =
772 :     c["narrowing", kindToString k, i2s width, i2s narrowing]
773 :     | instToString (LOC {k, width, narrowing, loc, ...}) =
774 :     c["loc", kindToString k, i2s width, i2s narrowing, locToString loc]
775 :     in
776 :     (* generates labels for instructions *)
777 :     val labelOfInst = newLabel o instToString
778 :     val interpEntryLab = newLabel "interpEntry"
779 :     val interpLab = newLabel "interp"
780 :     val gotoCLab = newLabel "gotoC"
781 :     val errLab = Label.global "vararg_error"
782 :     end (* local *)
783 : mrainey 3140
784 : mrainey 3177 val defTy = defaultWidth
785 :     val mem = T.Region.memory
786 :     val stack = T.Region.stack
787 :     fun lit i = T.LI (T.I.fromInt (defTy, i))
788 :     val lit' = lit o Word32.toInt
789 :     fun gpr r = T.GPR (T.REG (defTy, r))
790 : mrainey 3140 fun fpr (ty, f) = T.FPR (T.FREG (ty, f))
791 :     fun concatMap f xs = List.concat (List.map f xs)
792 : mrainey 3177
793 :     (* displacement from the located argument *)
794 :     fun offLocdArg (ty, larg, off) = T.LOAD(ty, T.ADD(defTy, larg, lit' off), mem)
795 :     fun offLocdArgF (ty, larg, off) = T.FLOAD(ty, T.ADD(defTy, larg, lit' off), mem)
796 :    
797 :     (* store an integer argument on the stack *)
798 :     fun storeSTK larg ty =
799 :     T.STORE(ty, T.ADD (defTy, spReg, offLocdArg(defTy, larg, Consts.locOffB)),
800 : mrainey 3173 offLocdArg(ty, larg, Consts.argOffB), mem)
801 : mrainey 3177
802 :     (* store a floating-point argument on the stack *)
803 :     fun storeFSTK larg ty =
804 : mrainey 3140 T.FSTORE(ty, T.ADD (defTy, spReg, offLocdArg(defTy, larg, Consts.locOffB)),
805 : mrainey 3177 offLocdArgF(ty, larg, Consts.argOffB), mem)
806 :    
807 :     (* load an integer argument into a register *)
808 :     fun loadGPR larg ty r = T.MV(ty, r, offLocdArg(ty, larg, Consts.argOffB))
809 : mrainey 3140
810 : mrainey 3177 (* load a floating-point argument into a register *)
811 :     fun loadFPR larg ty r = T.FMV(ty, r, offLocdArgF(ty, larg, Consts.argOffB))
812 :    
813 :     (* are the width and narrowing legal for kind of location? *)
814 : mrainey 3140 fun widthOK (k, w, narrowing) = let
815 : mrainey 3177 val ws = (case k
816 :     of (GPR | STK) => gprWidths
817 : mrainey 3140 | (FPR | FSTK) => fprWidths)
818 : mrainey 3177 in
819 :     List.exists (fn w' => w = w') ws andalso List.exists (fn w' => narrowing = w') ws
820 : mrainey 3140 end
821 : mrainey 3177
822 :     (* generate code that places the argument *)
823 :     fun loc {larg, k, width, narrowing, loc} = let
824 :     (* offset into the argument (only nonzero if the argument has an aggregate type) *)
825 :     val argMembOff = offLocdArg(ty, larg, Consts.offsetOffB)
826 : mrainey 3140 (* narrow the location if necessary *)
827 : mrainey 3177 fun narrow loc = if width = narrowing then loc
828 : mrainey 3140 else SA.NARROW(loc, k, loc)
829 :     (* FIXME: handle narrowing and offsets *)
830 : mrainey 3177 val ldInstrs = (
831 :     case (k, loc, widthOK(k, width, narrowing))
832 :     of (GPR, REG_LOC r, true) =>
833 :     CCall.writeLoc (offLocdArg(ty, larg, Consts.argOffB)) (argMembOff, narrow(SA.REG(ty, GPR, r)), [])
834 :     (* [loadGPR larg width r] *)
835 :     | (FPR, REG_LOC r, true) =>
836 :     CCall.writeLoc (offLocdArgF(ty, larg, Consts.argOffB)) (argMembOff, narrow(SA.REG(ty, FPR, r)), [])
837 :     (* [loadFPR larg width r]*)
838 :     | (STK, STK_LOC, true) =>
839 :     [storeSTK larg width]
840 :     | (FSTK, STK_LOC, true) =>
841 :     [storeFSTK larg width]
842 :     | _ => [T.JMP (T.LABEL errLab, [])]
843 :     (* end case *))
844 :     in
845 :     (* place the argument *)
846 :     ldInstrs @
847 :     (* return to the interpreter loop *)
848 :     [T.JMP (T.LABEL interpLab, [])]
849 :     end
850 :    
851 :     fun genHandlers (i, f, instrs) = let
852 :     fun genHandler instr = let
853 :     val lab = labelOfInst (i instr)
854 :     in
855 :     List.concat [
856 :     [T.DEFINE lab],
857 :     f instr,
858 :     [T.JMP (T.LABEL errLab, [])]
859 :     ]
860 :     end
861 :     in
862 :     concatMap genHandler instrs
863 :     end
864 :    
865 :     (* generate code to handle an argument narrowing *)
866 :     fun narrowing {larg, k, width, narrowing, locs} = let
867 :     (* we only use this instruction for generating labels *)
868 :     fun branch loc = LOC {larg=larg, k=k, width=width, narrowing=narrowing, loc=loc}
869 :     val locBranches = List.map (labelOfInst o branch) locs
870 :     fun instr (loc, branch) = if (k = GPR orelse k = FPR)
871 :     then T.BCC(T.CMP(defTy, T.EQ,
872 :     offLocdArg(defTy, larg, Consts.locOffB),
873 :     lit (locToInt loc)),
874 :     branch)
875 :     else T.JMP (T.LABEL branch, [])
876 :     in
877 :     ListPair.map instr (locs, locBranches)
878 :     end
879 :    
880 :     (* generate code to handle an argument width *)
881 :     fun width {larg, k, width, narrowings, locs} = let
882 :     (* we only use this instruction for generating labels *)
883 :     fun branch narrowing = NARROWING {larg=larg, k=k, width=width, narrowing=narrowing, locs=locs}
884 :     val narrowingBranches = List.map (labelOfInst o branch) narrowings
885 :     fun instr (narrowing, branch) =
886 :     T.BCC(T.CMP(defTy, T.EQ,
887 :     offLocdArg(defTy, larg, Consts.narrowingOffB),
888 :     lit narrowing),
889 :     branch)
890 :     in
891 :     ListPair.map instr (narrowings, narrowingBranches)
892 :     end
893 :    
894 :     (* generate code to handle an argument kind *)
895 :     fun kind {larg, k, widths, narrowings, locs} = let
896 :     fun branch width = WIDTH {larg=larg, k=k, width=width, narrowings=narrowings, locs=locs}
897 :     val widthBranches = List.map (labelOfInst o branch) widths
898 :     fun instr (width, branch) =
899 :     T.BCC(T.CMP(defTy, T.EQ,
900 :     offLocdArg(defTy, larg, Consts.widthOffB),
901 :     lit width),
902 :     branch)
903 :     in
904 :     ListPair.map instr (widths, widthBranches)
905 :     end
906 :    
907 :     (* generate code to handle an argument kind *)
908 :     fun entry {larg, ks, widths, narrowings, locs} = let
909 :     fun branch k = KIND {larg=larg, k=k, widths=widths, narrowings=narrowings, locs=locs}
910 :     val kBranches = List.map (labelOfInst o branch) ks
911 :     fun instr (k, branch) =
912 :     T.BCC(T.CMP(defTy, T.EQ,
913 :     offLocdArg(defTy, larg, Consts.kindOffB),
914 :     lit'(Consts.kind k)),
915 :     branch)
916 :     in
917 :     ListPair.map instr (ks, kBranches)
918 :     end
919 :    
920 :     fun locInstrs {larg, k, width, narrowing, locs=[]} = []
921 :     | locInstrs {larg, k, width, narrowing, locs=loc::locs} =
922 :     {larg=larg, k=k, width=width, narrowing=narrowing, loc=loc} ::
923 :     locInstrs {larg=larg, k=k, width=width, narrowing=narrowing, locs=locs}
924 :    
925 :     fun narrowingInstrs {larg, k, width, narrowings=[], locs} = []
926 :     | narrowingInstrs {larg, k, width, narrowings=narrowing::narrowings, locs} =
927 :     {larg=larg, k=k, width=width, narrowing=narrowing, locs=locs} ::
928 :     narrowingInstrs {larg=larg, k=k, width=width, narrowings=narrowings, locs=locs}
929 :    
930 :     fun widthInstrs {larg, k, widths=[], narrowings, locs} = []
931 :     | widthInstrs {larg, k, widths=width::widths, narrowings, locs} =
932 :     {larg=larg, k=k, width=width, narrowings=narrowings, locs=locs} ::
933 :     widthInstrs {larg=larg, k=k, widths=widths, narrowings=narrowings, locs=locs}
934 :    
935 :     fun kindInstrs {larg, ks=[], widths, narrowings, locs} = []
936 :     | kindInstrs {larg, ks=k::ks, widths, narrowings, locs} =
937 :     {larg=larg, k=k, widths=widths, narrowings=narrowings, locs=locs} ::
938 :     kindInstrs {larg=larg, ks=ks, widths=widths, narrowings=narrowings, locs=locs}
939 :    
940 :     structure IS = IntBinarySet
941 :     fun mkUnique ints = IS.listItems(IS.addList(IS.empty, ints))
942 :    
943 :     fun entryInstr larg = let
944 :     val ks = [GPR, FPR, STK, FSTK]
945 :     val widths = mkUnique (gprWidths@fprWidths)
946 :     val narrowings = widths
947 :     val locs = STK_LOC :: List.map REG_LOC gprs @ List.map REG_LOC fprs
948 :     in
949 :     {larg=larg, ks=ks, widths=widths, narrowings=narrowings, locs=locs}
950 :     end
951 :    
952 :     (* all possible combinations of instructions *)
953 :     fun allInstrs larg = let
954 :     val entryInstr = entryInstr larg
955 :     val kindInstrs = kindInstrs entryInstr
956 :     val widthInstrs = concatMap widthInstrs kindInstrs
957 :     val narrowingInstrs = concatMap narrowingInstrs widthInstrs
958 :     val locInstrs = concatMap locInstrs narrowingInstrs
959 :     in
960 :     (entryInstr, kindInstrs, widthInstrs, narrowingInstrs, locInstrs)
961 :     end
962 :    
963 :     (* call the varargs C function *)
964 :     fun genCallC interpFunPtr = let
965 :     val defs = List.map gpr callerSaves @ List.map (fn r => fpr(64, r)) callerSavesF
966 :     val uses = List.map gpr gprs @ List.map (fn r => fpr(64, r)) fprs
967 :     in
968 :     [
969 :     T.DEFINE gotoCLab,
970 :     T.CALL {funct=interpFunPtr, targets=[], defs=defs, uses=uses, region=mem, pops=0}
971 :     ]
972 :     end
973 :    
974 :     (* interpreter for varlargs *)
975 :     fun genInterp (largs, largsReg, endOfLargs) = [
976 :     T.DEFINE interpLab,
977 :     (* loop through the largs *)
978 :     T.MV (defTy, largsReg, T.ADD (defTy, largs, lit' Consts.locdArgSzB)),
979 :     T.DEFINE interpEntryLab,
980 :     T.BCC (T.CMP(defTy, T.GE, largs, endOfLargs), gotoCLab)
981 :     ]
982 :    
983 :     fun gen {interpFunPtr, largsReg, endOfLargs} = let
984 :     val largs = T.REG (defTy, largsReg)
985 :     val (entryInstr, kindInstrs, widthInstrs, narrowingInstrs, locInstrs) = allInstrs largs
986 :     in
987 :     List.concat [
988 :     [T.JMP (T.LABEL interpEntryLab, [])],
989 :     genInterp(largs, largsReg, endOfLargs),
990 :     genHandlers(ENTRY, entry, [entryInstr]),
991 :     genHandlers(KIND, kind, kindInstrs),
992 :     genHandlers(WIDTH, width, widthInstrs),
993 :     genHandlers(NARROWING, narrowing, narrowingInstrs),
994 :     genHandlers(LOC, loc, locInstrs),
995 :     genCallC interpFunPtr
996 :     ]
997 :     end
998 :    
999 :     end (* GenFn *)
1000 :    
1001 :     structure C : CELLS
1002 :     val offSp : T.I.machine_int -> T.rexp
1003 :     val wordTy : int
1004 :    
1005 :     structure SA : STAGED_ALLOCATION
1006 :     where type reg_id = T.reg
1007 :     where type loc_kind = CLocKind.loc_kind
1008 :    
1009 :     ) = struct
1010 :    
1011 :     structure K = CLocKind
1012 :    
1013 :     fun concatMap f ls = List.concat(List.map f ls)
1014 :    
1015 :     datatype c_arg
1016 :     = ARG of T.rexp
1017 :     (* rexp specifies integer or pointer; if the
1018 :     * corresponding parameter is a C struct, then
1019 :     * this argument is the address of the struct.
1020 :     *)
1021 :     | FARG of T.fexp
1022 :     (* fexp specifies floating-point argument *)
1023 :    
1024 :     fun copyToReg (mty, r, e) = let
1025 :     val tmp = C.newReg ()
1026 :     in
1027 :     [T.COPY (mty, [r], [tmp]), T.MV (mty, tmp, e)]
1028 :     end
1029 :    
1030 :     fun copyToFReg (mty, r, e) = let
1031 :     val tmp = C.newFreg ()
1032 :     in
1033 :     [T.FCOPY (mty, [r], [tmp]), T.FMV (mty, tmp, e)]
1034 :     end
1035 :    
1036 :     val stack = T.Region.stack
1037 :    
1038 :     fun litInt i = T.I.fromInt(wordTy, i)
1039 :     val lit = T.LI o litInt
1040 :     val offSp = offSp o litInt
1041 :    
1042 :     (* returns any general-purpose register IDs used in a machine location *)
1043 :     fun gprsOfLoc (SA.REG (_, K.GPR, r)) = [r]
1044 :     | gprsOfLoc (SA.COMBINE (l1, l2)) = gprsOfLoc l1 @ gprsOfLoc l2
1045 :     | gprsOfLoc (SA.NARROW (l, _, K.GPR)) = gprsOfLoc l
1046 :     | gprsOfLoc _ = []
1047 :    
1048 :     (* returns any floating-point register IDs used in a machine location *)
1049 :     fun fprsOfLoc (SA.REG (w, K.FPR, r)) = [(w, r)]
1050 :     | fprsOfLoc (SA.COMBINE (l1, l2)) = fprsOfLoc l1 @ fprsOfLoc l2
1051 :     | fprsOfLoc (SA.NARROW (l, _, K.FPR)) = fprsOfLoc l
1052 :     | fprsOfLoc _ = []
1053 :    
1054 :     (* eliminate redundant narrows, i.e., narrow.32(r1.32) == r1.32 *)
1055 :     fun elimNarrow (loc as SA.NARROW(SA.REG(wr, kr, r), wn, kn)) =
1056 :     if kr = kn andalso wr = wn
1057 :     then SA.REG(wr, kr, r)
1058 :     else loc
1059 :     | elimNarrow (loc as SA.NARROW(SA.BLOCK_OFFSET(wb, kb, offset), wn, kn)) =
1060 :     if kb = kn andalso wb = wn
1061 :     then SA.BLOCK_OFFSET(wb, kb, offset)
1062 :     else loc
1063 :     | elimNarrow (SA.COMBINE(l1, l2)) = SA.COMBINE(elimNarrow l1, elimNarrow l2)
1064 :     | elimNarrow loc = loc
1065 :    
1066 :     (* write a C argument (non aggregate) to a machine location
1067 :     * - arg is the argument data
1068 :     * - off is an offset into the argument data
1069 :     * - loc is the machine location
1070 :     * - stms is the accumulator of machine instructions
1071 :     *)
1072 :     fun writeLoc arg (off, loc, stms) = (
1073 :     case (arg, loc)
1074 :     of (ARG (e as T.REG _), SA.BLOCK_OFFSET(w, (K.GPR | K.STK), offset)) =>
1075 :     (* register to stack (gpr) *)
1076 :     T.STORE(wordTy, offSp offset, e, stack) :: stms
1077 :     | (ARG (e as T.REG _), SA.NARROW(SA.BLOCK_OFFSET(w, (K.GPR | K.STK), offset), w', (K.GPR | K.STK))) =>
1078 :     (* register to stack with width conversion (gpr) *)
1079 :     T.STORE(w, offSp offset, T.SX(w, w', e), stack) :: stms
1080 :     | (ARG (T.LOAD (ty, e, rgn)), SA.REG (w, K.GPR, r)) =>
1081 :     (* memory to register (gpr) *)
1082 :     copyToReg(w, r, T.LOAD (ty, T.ADD(wordTy, e, off), rgn)) @ stms
1083 :     | (ARG (T.LOAD (ty, e, rgn)), SA.NARROW(SA.REG (w, K.GPR, r), w', K.GPR)) =>
1084 :     (* memory to register with conversion (gpr) *)
1085 :     copyToReg(w, r, T.SX(w, w', T.LOAD (w', T.ADD(wordTy, e, off), rgn))) @ stms
1086 :     | (ARG (T.LOAD (ty, e, rgn)), SA.BLOCK_OFFSET(w, (K.GPR | K.STK), offset)) => let
1087 :     (* memory to stack (gpr) *)
1088 :     val tmp = C.newReg ()
1089 :     in
1090 :     T.STORE (ty, offSp offset, T.REG (ty, tmp), stack) ::
1091 :     T.MV (ty, tmp, T.LOAD (ty, T.ADD(wordTy, e, off), rgn)) :: stms
1092 :     end
1093 :     | (ARG (T.LOAD (ty, e, rgn)), SA.NARROW(SA.BLOCK_OFFSET(w, (K.GPR | K.STK), offset), w', K.GPR)) => let
1094 :     (* memory to stack with conversion (gpr) *)
1095 :     val tmp = C.newReg ()
1096 :     in
1097 :     T.STORE (w, offSp offset, T.REG (w, tmp), stack) ::
1098 :     T.MV (w, tmp, T.SX(w, w', T.LOAD (w', T.ADD(wordTy, e, off), rgn))) :: stms
1099 :     end
1100 :     | (ARG e, SA.BLOCK_OFFSET(w, (K.GPR | K.STK), offset)) => let
1101 : mrainey 3140 (* expression to stack (gpr) *)
1102 : mrainey 3177 val tmp = C.newReg ()
1103 :     in
1104 :     T.STORE (w, offSp offset, T.REG (w, tmp), stack) :: T.MV (w, tmp, e) :: stms
1105 :     end
1106 :     | (ARG e, SA.NARROW(SA.BLOCK_OFFSET(w, (K.GPR | K.STK), offset), w', K.GPR)) => let
1107 :     (* expression to stack with conversion (gpr) *)
1108 :     val tmp = C.newReg ()
1109 :     in
1110 :     T.STORE (w, offSp offset, T.REG (w, tmp), stack) :: T.MV (w, tmp, T.SX(w, w', e)) :: stms
1111 :     end
1112 :     | (FARG (e as T.FREG _), SA.BLOCK_OFFSET(w, (K.FPR | K.FSTK), offset)) =>
1113 :     (* register to stack (fpr) *)
1114 :     T.FSTORE (w, offSp offset, e, stack) :: stms
1115 :     | (ARG (T.LOAD (ty, e, rgn)), SA.REG(w, K.FPR, r)) =>
1116 :     (* memory to register (fpr) *)
1117 :     copyToFReg(w, r, T.FLOAD (ty, T.ADD(wordTy, e, off), rgn)) @ stms
1118 :     | (FARG (T.FLOAD (ty, e, rgn)), SA.BLOCK_OFFSET(w, (K.FPR | K.FSTK), offset)) => let
1119 :     (* memory to stack (fpr) *)
1120 :     val tmp = C.newFreg ()
1121 :     in
1122 :     T.FSTORE (w, offSp offset, T.FREG (w, tmp), stack) ::
1123 :     T.FMV (w, tmp, T.FLOAD (ty, T.ADD(wordTy, e, off), rgn)) :: stms
1124 :     end
1125 :     | (FARG e, SA.BLOCK_OFFSET(w, (K.FPR | K.FSTK), offset)) => let
1126 :     (* expression to stack (fpr) *)
1127 :     val tmp = C.newFreg ()
1128 :     in
1129 :     T.FSTORE (w, offSp offset, T.FREG (w, tmp), stack) :: T.FMV (w, tmp, e) :: stms
1130 :     end
1131 :     | (FARG e, SA.REG(w, K.FPR, r)) =>
1132 :     (* expression to register (fpr) *)
1133 :     copyToFReg(w, r, e) @ stms
1134 :     | _ => raise Fail "invalid arg / loc pair"
1135 :     (* end case *))
1136 :    
1137 :     (* write a C argument (possibly an aggregate) to some parameter locations *)
1138 :     fun writeLocs' (arg, locs, stms) = let
1139 :     val locs = List.map elimNarrow locs
1140 :     (* offsets of the members of the struct *)
1141 :     val membOffs = List.tabulate(List.length locs, fn i => lit(i*8))
1142 :     in
1143 :     ListPair.foldl (writeLoc arg) stms (membOffs, locs)
1144 :     end
1145 : mrainey 3140
1146 : mrainey 3177 (* write C arguments to parameter locations; also return any used GPRs or FPRs *)
1147 :     fun writeLocs (args, argLocs) = let
1148 :     val gprs = concatMap gprsOfLoc (List.concat argLocs)
1149 :     val fprs = concatMap fprsOfLoc (List.concat argLocs)
1150 :     val instrs = ListPair.foldl writeLocs' [] (args, argLocs)
1151 : mrainey 3140 in
1152 : mrainey 3177 (List.rev instrs, gprs, fprs)
1153 :     end
1154 : mrainey 3140
1155 : mrainey 3177 (* read from a machine location *)
1156 :     fun readLoc (loc, (resultRegs, copyResult)) = (
1157 :     case elimNarrow loc
1158 :     of SA.REG(w, K.GPR, r) => let
1159 :     (* register (gpr) *)
1160 :     val tmpR = C.newReg()
1161 :     in
1162 :     (T.GPR(T.REG(w, tmpR)) :: resultRegs, T.COPY(w, [tmpR], [r]) :: copyResult)
1163 :     end
1164 :     | SA.NARROW(loc, w', K.GPR) => let
1165 :     (* conversion (gpr) *)
1166 :     val ([resultReg as T.GPR(T.REG(_, tmp))], copyResult') = readLoc(loc, ([], []))
1167 :     val w = SA.width loc
1168 :     in
1169 :     (resultReg :: resultRegs, T.MV(w, tmp, T.ZX(w, w', T.REG (w', tmp))) :: copyResult' @ copyResult)
1170 : mrainey 3140 end
1171 : mrainey 3177 | SA.REG(w, K.FPR, r) => let
1172 : mrainey 3140 val resReg = C.newFreg()
1173 : mrainey 3177 in
1174 :     (T.FPR(T.FREG(w, resReg)) :: resultRegs, T.FCOPY(w, [resReg], [r]) :: copyResult)
1175 :     end
1176 :     | SA.NARROW(loc, w', K.FPR) => let
1177 :     (* conversion (fpr) *)
1178 :     val ([resultReg as T.FPR(T.FREG(_, tmp))], copyResult') = readLoc(loc, ([], []))
1179 :     val w = SA.width loc
1180 :     in
1181 :     (resultReg :: resultRegs, T.FMV(w', tmp, T.CVTF2F(w', w, T.FREG(w, tmp))) :: copyResult' @ copyResult)
1182 :     end
1183 :     | SA.COMBINE (l1, l2) => (
1184 :     case (readLoc (l1, ([], [])), readLoc (l2, ([], [])))
1185 :     of ( ([T.GPR e1], instrs1), ([T.GPR e2], instrs2) ) => let
1186 :     val w = SA.width loc
1187 :     val w' = SA.width l2
1188 :     val tmp = C.newReg()
1189 :     in
1190 :     (T.GPR(T.REG(w, tmp)) :: resultRegs, T.MV(w, tmp, T.ADD(w, T.SLL(w, lit w', e1), e2)) :: instrs1 @ instrs2 @ copyResult)
1191 :     end
1192 :     (* end case *))
1193 :     | _ => raise Fail "bogus read location"
1194 :     (* end case *))
1195 :    
1196 :     (* read from some machine locations *)
1197 :     fun readLocs locs = let
1198 :     val (resultRegs, copyResult) = List.foldl readLoc ([], []) locs
1199 :     in
1200 :     (List.rev resultRegs, List.rev copyResult)
1201 :     end
1202 :    
1203 :     end (* CCallFn *)
1204 :    

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