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 /sml/trunk/src/MLRISC/ppc/c-calls/ppc-macosx.sml
ViewVC logotype

Annotation of /sml/trunk/src/MLRISC/ppc/c-calls/ppc-macosx.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1522 - (view) (download)

1 : jhr 1346 (* ppc-macosx.sml
2 :     *
3 :     * COPYRIGHT (c) 2003 John Reppy (http://www.cs.uchicago.edu/~jhr)
4 :     * All rights reserved.
5 :     *
6 :     * C function calls for the PowerPC using the MacOS X ABI.
7 :     *
8 :     * Register conventions:
9 :     *
10 :     * Register Callee-save Purpose
11 :     * -------- ----------- -------
12 :     * GPR0 no Zero
13 :     * 1 no Stack pointer
14 :     * 2 no scratch (TOC on AIX)
15 :     * 3 no arg0 and return result
16 :     * 4-10 no arg1-arg7
17 :     * 11 no scratch
18 :     * 12 no holds taget of indirect call
19 :     * 13-31 yes callee-save registers
20 :     *
21 :     * FPR0 no scratch
22 :     * 1-13 no floating-point arguments
23 :     * 14-31 yes floating-point callee-save registers
24 :     *
25 :     * V0-V1 no scratch vector registers
26 :     * 2-13 no vector argument registers
27 :     * 14-19 no scratch vector registers
28 :     * 20-31 yes callee-save vector registers
29 :     *
30 :     * LR no link register holds return address
31 :     *
32 :     * CR0-CR1 no scratch condition registers
33 :     * 2-4 yes callee-save condition registers
34 :     * 5-7 no scratch condition registers
35 :     *
36 :     * Calling convention:
37 :     *
38 :     * Return result:
39 :     * + Integer and pointer results are returned in GPR3
40 :     * + 64-bit integers (long long) returned in GPR3/GPR4
41 :     * + float/double results are returned in FPR1
42 :     * + Struct results are returned in space provided by the caller.
43 :     * The address of this space is passed to the callee as an
44 :     * implicit first argument in GPR3 and the first real argument is
45 :     * passed in GPR4.
46 :     *
47 :     * Function arguments:
48 :     * * arguments (except for floating-point values) are passed in
49 :     * registers GPR3-GPR10
50 : jhr 1438 *
51 :     * Note also that stack frames are supposed to be 16-byte aligned.
52 : jhr 1346 *)
53 :    
54 :     (* we extend the interface to support generating the stubs needed for
55 :     * dynamic linking (see "Inside MacOS X: Mach-O Runtime Architecture"
56 :     * for details.
57 :     *)
58 :     signature PPC_MACOSX_C_CALLS =
59 :     sig
60 :     include C_CALLS
61 : jhr 1438
62 :     (*
63 :     val genStub : {
64 :     name : T.rexp,
65 :     proto : CTypes.c_proto,
66 :     paramAlloc : {szb : int, align : int} -> bool,
67 :     structRet : {szb : int, align : int} -> T.rexp,
68 :     saveRestoreDedicated :
69 :     T.mlrisc list -> {save: T.stm list, restore: T.stm list},
70 :     callComment : string option,
71 :     args : c_arg list
72 :     } -> {
73 :     callseq : T.stm list,
74 :     result: T.mlrisc list
75 :     }
76 :     *)
77 :    
78 : jhr 1346 end;
79 :    
80 :     functor PPCMacOSX_CCalls (
81 :    
82 :     structure T : MLTREE
83 :     val ix : (T.stm, T.rexp, T.fexp, T.ccexp) PPCInstrExt.sext -> T.sext
84 :    
85 :     ): PPC_MACOSX_C_CALLS = struct
86 :     structure T = T
87 : jhr 1521 structure CTy = CTypes
88 : jhr 1346 structure C = PPCCells
89 :     structure IX = PPCInstrExt
90 :    
91 :     fun error msg = MLRiscErrorMsg.error ("PPCCompCCalls", msg)
92 :    
93 : jhr 1521 (* the location of arguments/parameters; offsets are given with respect to the
94 :     * low end of the parameter area.
95 :     *)
96 :     datatype arg_location
97 : jhr 1522 = Reg of T.ty * T.reg * T.I.machine_int option
98 :     (* integer/pointer argument in register *)
99 :     | FReg of T.fty * T.freg * T.I.machine_int option
100 :     (* floating-point argument in register *)
101 : jhr 1521 | Stk of T.ty * T.I.machine_int (* integer/pointer argument in parameter area *)
102 :     | FStk of T.fty * T.I.machine_int (* floating-point argument in parameter area *)
103 :     | Args of arg_location list
104 :    
105 : jhr 1522 val wordTy = 32
106 :     val fltTy = 32 (* MLRISC type of float *)
107 :     val dblTy = 64 (* MLRISC type of double *)
108 : jhr 1346
109 : jhr 1521 (* registers used for parameter passing *)
110 :     val argGPRs = List.map C.GPReg [3, 4, 5, 6, 7, 8, 9, 10]
111 :     val argFPRs = List.map C.FPReg [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13]
112 : jhr 1522 val resGPR = C.GPReg 3
113 :     val resFPR = C.FPReg 1
114 : jhr 1521
115 :     (* C callee-save registers *)
116 :     val calleeSaveRegs = List.map C.GPReg [
117 :     13, 14, 15, 16, 17, 18, 19, 20, 21, 22,
118 :     23, 24, 25, 26, 27, 28, 29, 30, 31
119 :     ]
120 :     val calleeSaveFRegs = List.map C.FPReg [
121 :     14, 15, 16, 17, 18, 19, 20, 21, 22,
122 :     23, 24, 25, 26, 27, 28, 29, 30, 31
123 :     ]
124 :    
125 : jhr 1522 (* size and padding for integer types. Note that the padding is based on the
126 :     * parameter-passing description on p. 35 of the documentation.
127 :     *)
128 : jhr 1521 fun sizeOf CTy.I_char = {sz = 1, pad = 3}
129 :     | sizeOf CTy.I_short = {sz = 2, pad = 2}
130 :     | sizeOf CTy.I_int = {sz = 4, pad = 0}
131 :     | sizeOf CTy.I_long = {sz = 4, pad = 0}
132 :     | sizeOf CTy.I_long_long = {sz = 8, pad = 0}
133 :    
134 : jhr 1522 (* sizes of other C types *)
135 :     val sizeOfPtr = {sz = 4, pad = 0}
136 :    
137 :     fun sizeOfStruct ? = ?
138 :    
139 : jhr 1521 (* compute the layout of a C call's arguments *)
140 :     fun layout {conv, retTy, paramTys} = let
141 : jhr 1522 fun gprRes isz = (case sizeOf isz
142 :     of 8 => raise Fail "register pairs not yet supported"
143 :     | _ => SOME resGPR
144 : jhr 1521 (* end case *))
145 : jhr 1522 val (resReg, availGPRs) = (case retTy
146 :     of CTy.C_void => (NONE, availGPRs)
147 :     | CTy.C_float => (SOME resFPR, availGPRs)
148 :     | CTy.C_double => (SOME resFPR, availGPRs)
149 :     | CTy.C_long_double => (SOME resFPR, availGPRs)
150 :     | CTy.C_unsigned isz => (gprRes isz, availGPRs)
151 :     | CTy.C_signed isz => (gprRes isz, availGPRs)
152 :     | CTy.C_PTR => (SOME resGPR, availGPRs)
153 :     | CTy.C_ARRAY _ => error "array return type"
154 :     | CTy.C_STRUCT s => let
155 :     val sz = sizeOfStruct s
156 :     in
157 :     (* Note that this is a place where the MacOS X and Linux ABIs differ.
158 :     * In Linux, GPR3/GPR4 are used to return composite values of 8 bytes.
159 :     *)
160 :     if (sz > 4)
161 :     then (SOME resGPR, List.tl availGPRs)
162 :     else (SOME resGPR, availGPRs)
163 :     end
164 :     (* end case *))
165 : jhr 1521 fun assign ([], offset, _, _, layout) = {sz = offset, layout = List.rev layout}
166 :     | assign (arg::args, offset, availGPRs, availFPRs, layout) = (
167 :     case arg
168 :     of CTy.C_void => error "unexpected void argument type"
169 : jhr 1522 | CTy.C_float => (case (availGPRs, availFPRs)
170 :     of (_:gprs, fpr::fprs) =>
171 :     assign (args, offset+4, gprs, fprs, FReg(fltTy, fpr, SOME offset)::layout)
172 :     | ([], fpr::fprs) =>
173 :     assign (args, offset+4, [], fprs, FReg(fltTy, fpr, SOME offset)::layout)
174 :     | ([], []) =>
175 :     assign (args, offset+4, [], [], FStk(fltTy, offset)::layout)
176 :     (* end case *))
177 : jhr 1521 | CTy.C_double =>
178 :     | CTy.C_long_double =>
179 :     | CTy.C_unsigned isz =>
180 : jhr 1522 assignGPR(sizeOf isz, args, offset, availGPRs, availFPRs, layout)
181 : jhr 1521 | CTy.C_signed isz =>
182 : jhr 1522 assignGPR(sizeOf isz, args, offset, availGPRs, availFPRs, layout)
183 : jhr 1521 | CTy.C_PTR =>
184 : jhr 1522 assignGPR(sizeOfPtr, args, offset, availGPRs, availFPRs, layout)
185 : jhr 1521 | CTy.C_ARRAY _ =>
186 : jhr 1522 assignGPR(sizeOfPtr, args, offset, availGPRs, availFPRs, layout)
187 : jhr 1521 | CTy.C_STRUCT tys =>
188 :     (* end case *))
189 : jhr 1522 (* assign a GP register and memory for an integer/pointer argument. *)
190 :     and assignGPR ({sz, pad}, args, offset, availGPRs, availFPRs, layout) = let
191 :     val (loc, availGPRs) = (case (sz, availGPRs)
192 :     of (8, _) => raise Fail "register pairs not yet supported"
193 :     | (_, []) => (Stk(wordTy, offset), [])
194 :     | (_, r1::rs) => (Reg(wordTy, r1, SOME offset), rs)
195 :     (* end case *))
196 :     val offset = offset + sz + pad
197 : jhr 1521 in
198 : jhr 1522 assign (args, offset, availGPRs, availFPRs, loc::layout)
199 : jhr 1521 end
200 : jhr 1522 (* assign a FP register and memory/GPRs for double-precision argument. *)
201 :     and assignFPR (args, offset, availGPRs, availFPRs, layout) = let
202 :     fun continue (availGPRs, availFPRs, loc) =
203 :     assign (args, offset+8, availGPRs, availFPRs, loc::layout)
204 :     fun freg fpr = FReg(dblTy, fpr, SOME offset)
205 :     in
206 :     case (availGPRs, availFPRs)
207 :     of (_::_::gprs, fpr::fprs) => continue (gprs, fprs, freg fpr)
208 :     | (_, fpr::fprs) => continue ([], fprs, freg fpr)
209 :     | ([], []) => continue ([], [], FStk(dblTy, offset))
210 :     (* end case *)
211 :     end
212 : jhr 1521 in
213 : jhr 1522 { args = assign (paramTys, 0, argGPRs, argFPRs, []), res = resReg }
214 : jhr 1521 end
215 :    
216 : jhr 1346 datatype c_arg
217 :     = ARG of T.rexp
218 :     | FARG of T.fexp
219 :     | ARGS of c_arg list
220 :    
221 :     val mem = T.Region.memory
222 :     val stack = T.Region.memory
223 :    
224 :     val maxRegArgs = 6
225 :     val paramAreaOffset = 68
226 :    
227 : jhr 1443 fun LI i = T.LI(T.I.fromInt (32, i))
228 : jhr 1346
229 : jhr 1443 fun reg r = C.GPReg r
230 :     fun freg r = C.FPReg r
231 : jhr 1346
232 : jhr 1443 fun reg32 r = T.REG(32, r)
233 :     fun freg64 r = T.FREG(64, r)
234 : jhr 1346
235 : jhr 1443 (* stack pointer *)
236 :     val sp = reg1
237 :     val spR = reg32 sp
238 : jhr 1346
239 :     fun addli (x, 0) = x
240 :     | addli (x, d) = let
241 : jhr 1438 val d' = T.I.fromInt (32, d)
242 :     in
243 :     case x
244 :     of T.ADD (_, r, T.LI d) =>
245 :     T.ADD (32, r, T.LI (T.I.ADD (32, d, d')))
246 : jhr 1346 | _ => T.ADD (32, x, T.LI d')
247 : jhr 1443 (* end case *)
248 : jhr 1438 end
249 : jhr 1346
250 :     fun argaddr n = addli (spreg, paramAreaOffset + 4*n)
251 :    
252 : jhr 1443 (* layout information for C types; note that stack and struct alignment
253 :     * are different for some types
254 :     *)
255 :     type layout_info = {
256 :     sz : int,
257 :     stkAlign : int,
258 :     structAlign : int
259 :     }
260 : jhr 1346
261 :     fun roundup (i, a) = a * ((i + a - 1) div a)
262 :    
263 : jhr 1443 (* layout information for integer types *)
264 :     local
265 :     fun layout n = {sz = n, stkAlign = n, structAlign = n}
266 : jhr 1438
267 : jhr 1443 fun intSizeAndAlign Ty.I_char = layout 1
268 :     | intSizeAndAlign Ty.I_short = layout 2
269 :     | intSizeAndAlign Ty.I_int = layout 4
270 :     | intSizeAndAlign Ty.I_long = layout 4
271 :     | intSizeAndAlign Ty.I_long_long = {sz = 8, stkAlign = 8, structAlign = 4}
272 :    
273 :     in
274 :    
275 : jhr 1438 (* calculate size and alignment for a C type *)
276 :     fun szal (T.C_unsigned ty) = intSizeAndAlign ty
277 :     | szal (T.C_signed ty) = intSizeAndAlign ty
278 :     | szal Ty.C_void = raise Fail "unexpected void type"
279 : jhr 1443 | szal Ty.C_float = layout 4
280 :     | szal Ty.C_PTR = layout 4
281 :     | szal Ty.C_double = {sz = 8, stkAlign = 8, structAlign = 4}
282 :     | szal (Ty.C_long_double) = {sz = 8, stkAlign = 8, structAlign = 4}
283 :     | szal (Ty.C_ARRAY(t, n)) = let
284 :     val a = szal t
285 :     in
286 :     {sz = n * #sz a, stkAlign = ?, structAlign = #structAlign a}
287 :     end
288 : jhr 1438 | szal (Ty.C_STRUCT l) = let
289 :     (* FIXME: the rules for structs are more complicated (and they also depend
290 :     * on the alignment mode). In Power alignment, 8-byte quantites like
291 :     * long long and double are 4-byte aligned in structs.
292 :     *)
293 :     (* i: next free memory address (relative to struct start);
294 :     * a: current total alignment,
295 :     * l: list of struct member types
296 :     *)
297 :     fun pack (i, a, []) =
298 :     (* when we are done with all elements, the total size
299 :     * of the struct must be padded out to its own alignment
300 :     *)
301 : jhr 1346 (roundup (i, a), a)
302 : jhr 1438 | pack (i, a, t :: tl) = let
303 :     val (ts, ta) = szal t (* size and alignment for member *)
304 : jhr 1346 in
305 : jhr 1438 (* member must be aligned according to its own
306 :     * alignment requirement; the next free position
307 :     * is then at "aligned member-address plus member-size";
308 :     * new total alignment is max of current alignment
309 :     * and member alignment (assuming all alignments are
310 :     * powers of 2) *)
311 :     pack (roundup (i, ta) + ts, Int.max (a, ta), tl)
312 : jhr 1346 end
313 : jhr 1438 in
314 : jhr 1346 pack (0, 1, l)
315 : jhr 1438 end
316 : jhr 1443 end
317 : jhr 1346
318 : jhr 1445 fun assignIntLoc (ty, gprs, offset) = let
319 :     val {sz, alignStk, alignStruct} = szal ty
320 :     val offset = align(offset, alignStk)
321 : jhr 1443 in
322 : jhr 1445 case (sz, gprs)
323 :     of (_, []) => ({offset = offset, loc = ARG(??)}, offset+sz, [])
324 :     | (8, [r]) =>
325 :     | (8, r1::r2::rs) =>
326 :     | (_, r::rs) =>({offset = offset, loc = GPR r}, offset+sz, rs)
327 :     (* end case *)
328 : jhr 1443 end
329 :    
330 : jhr 1445 fun genCall {
331 :     name, proto, paramAlloc, structRet, saveRestoreDedicated,
332 :     callComment, args
333 :     } = let
334 :     val {conv, retTy, paramTys} = proto
335 :     val callseq = List.concat [
336 :     sp_sub,
337 :     copycode,
338 :     argsetupcode,
339 :     sretsetup,
340 :     save,
341 :     [call],
342 :     srethandshake,
343 :     restore,
344 :     sp_add
345 :     ]
346 :     in
347 :     (* check calling convention *)
348 :     case conv
349 :     of ("" | "ccall") => ()
350 :     | _ => error (concat [
351 :     "unknown calling convention \"",
352 :     String.toString conv, "\""
353 :     ])
354 :     (* end case *);
355 :     {callseq = callseq, result = result}
356 :     end
357 : jhr 1346
358 : jhr 1445 (******
359 :     val res_szal = (case retTy
360 :     of (Ty.C_long_double | Ty.C_STRUCT _) => SOME(szal retTy)
361 :     | _ => NONE
362 :    
363 : jhr 1346 val nargwords = let
364 :     fun loop ([], n) = n
365 :     | loop (t :: tl, n) =
366 :     loop (tl, (case t of
367 :     (Ty.C_double | Ty.C_signed Ty.I_long_long |
368 :     Ty.C_unsigned Ty.I_long_long) => 2
369 :     | _ => 1) + n)
370 :     in
371 :     loop (paramTys, 0)
372 :     end
373 :    
374 :     val regargwords = Int.min (nargwords, maxRegArgs)
375 :     val stackargwords = Int.max (nargwords, maxRegArgs) - maxRegArgs
376 :    
377 :     val stackargsstart = paramAreaOffset + 4 * maxRegArgs
378 :    
379 :     val scratchstart = stackargsstart + 4 * stackargwords
380 :    
381 :     (* Copy struct or part thereof to designated area on the stack.
382 :     * An already properly aligned address (relative to %sp) is
383 :     * in to_off. *)
384 :     fun struct_copy (sz, al, ARG a, t, to_off, cpc) =
385 :     (* Two main cases here:
386 :     * 1. t is C_STRUCT _: in this case "a" computes the address
387 :     * of the struct to be copied.
388 :     * 2. t is some other non-floating type; "a" computes the
389 :     * the corresponding value (i.e., not its address).
390 :     *)
391 :     let fun ldst ty =
392 :     T.STORE (ty, addli (spreg, to_off), a, stack) :: cpc
393 :     in
394 :     case t of
395 :     (Ty.C_void | Ty.C_PTR |
396 :     Ty.C_signed (Ty.I_int | Ty.I_long) |
397 :     Ty.C_unsigned (Ty.I_int | Ty.I_long)) => ldst 32
398 :     | (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) => ldst 8
399 :     | (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>
400 :     ldst 16
401 :     | (Ty.C_signed Ty.I_long_long |
402 :     Ty.C_unsigned Ty.I_long_long) => ldst 64
403 :     | (Ty.C_ARRAY _) =>
404 :     error "ARRAY within gather/scatter struct"
405 :     | (Ty.C_STRUCT _) =>
406 :     (* Here we have to do the equivalent of a "memcpy". *)
407 :     let val from = a (* argument is address of struct *)
408 :     fun cp (ty, incr) = let
409 :     fun load_from from_off =
410 :     T.LOAD (32, addli (from, from_off), mem)
411 :     (* from_off is relative to from,
412 :     * to_off is relative to %sp *)
413 :     fun loop (i, from_off, to_off, cpc) =
414 :     if i <= 0 then cpc
415 :     else loop (i - incr,
416 :     from_off + incr, to_off + incr,
417 :     T.STORE (ty, addli (spreg, to_off),
418 :     load_from from_off,
419 :     stack)
420 :     :: cpc)
421 :     in
422 :     loop (sz, 0, to_off, cpc)
423 :     end
424 :     in
425 :     case al of
426 :     1 => cp (8, 1)
427 :     | 2 => cp (16, 2)
428 :     | _ => (* 4 or more *) cp (32, 4)
429 :     end
430 :     | (Ty.C_float | Ty.C_double | Ty.C_long_double) =>
431 :     error "floating point type does not match ARG"
432 :     end
433 :     | struct_copy (_, _, ARGS args, Ty.C_STRUCT tl, to_off, cpc) =
434 :     (* gather/scatter case *)
435 :     let fun loop ([], [], _, cpc) = cpc
436 :     | loop (t :: tl, a :: al, to_off, cpc) = let
437 :     val (tsz, tal) = szal t
438 :     val to_off' = roundup (to_off, tal)
439 :     val cpc' = struct_copy (tsz, tal, a, t, to_off', cpc)
440 :     in
441 :     loop (tl, al, to_off' + tsz, cpc')
442 :     end
443 :     | loop _ =
444 :     error "number of types does not match number of arguments"
445 :     in
446 :     loop (tl, args, to_off, cpc)
447 :     end
448 :     | struct_copy (_, _, ARGS _, _, _, _) =
449 :     error "gather/scatter for non-struct"
450 :     | struct_copy (sz, al, FARG a, t, to_off, cpc) =
451 :     let fun fldst ty =
452 :     T.FSTORE (ty, addli (spreg, to_off), a, stack) :: cpc
453 :     in
454 :     case t of
455 :     Ty.C_float => fldst 32
456 :     | Ty.C_double => fldst 64
457 :     | Ty.C_long_double => fldst 128
458 :     | _ => error "non-floating-point type does not match FARG"
459 :     end
460 :    
461 :     val (stackdelta, argsetupcode, copycode) = let
462 :     fun loop ([], [], _, ss, asc, cpc) =
463 :     (roundup (Int.max (0, ss - stackargsstart), 8), asc, cpc)
464 :     | loop (t :: tl, a :: al, n, ss, asc, cpc) = let
465 :     fun wordassign a =
466 :     if n < 6 then T.MV (32, oreg n, a)
467 :     else T.STORE (32, argaddr n, a, stack)
468 :     fun wordarg (a, cpc, ss) =
469 :     loop (tl, al, n + 1, ss, wordassign a :: asc, cpc)
470 :    
471 :     fun dwordmemarg (addr, region, tmpstore) = let
472 :     fun toreg (n, addr) =
473 :     T.MV (32, oreg n, T.LOAD (32, addr, region))
474 :     fun tomem (n, addr) =
475 :     T.STORE (32,
476 :     argaddr n,
477 :     T.LOAD (32, addr, region),
478 :     stack)
479 :     fun toany (n, addr) =
480 :     if n < 6 then toreg (n, addr) else tomem (n, addr)
481 :     in
482 :     (* if n < 6 andalso n div 2 = 0 then
483 :     * use ldd here once MLRISC gets its usage right
484 :     * else
485 :     * ... *)
486 :     loop (tl, al, n+2, ss,
487 :     tmpstore @
488 :     toany (n, addr)
489 :     :: toany (n+1, addli (addr, 4))
490 :     :: asc,
491 :     cpc)
492 :     end
493 :     fun dwordarg mkstore =
494 :     if n > 6 andalso n div 2 = 1 then
495 :     (* 8-byte aligned memory *)
496 :     loop (tl, al, n+2, ss,
497 :     mkstore (argaddr n) :: asc,
498 :     cpc)
499 :     else dwordmemarg (tmpaddr, stack, [mkstore tmpaddr])
500 :     in
501 :     case (t, a) of
502 :     ((Ty.C_void | Ty.C_PTR | Ty.C_ARRAY _ |
503 :     Ty.C_unsigned (Ty.I_int | Ty.I_long) |
504 :     Ty.C_signed (Ty.I_int | Ty.I_long)),
505 :     ARG a) => wordarg (a, cpc, ss)
506 :     | (Ty.C_signed Ty.I_char, ARG a) =>
507 :     wordarg (T.SX (32, 8, a), cpc, ss)
508 :     | (Ty.C_unsigned Ty.I_char, ARG a) =>
509 :     wordarg (T.ZX (32, 8, a), cpc, ss)
510 :     | (Ty.C_signed Ty.I_short, ARG a) =>
511 :     wordarg (T.SX (32, 16, a), cpc, ss)
512 :     | (Ty.C_unsigned Ty.I_short, ARG a) =>
513 :     wordarg (T.ZX (32, 16, a), cpc, ss)
514 :     | ((Ty.C_signed Ty.I_long_long |
515 :     Ty.C_unsigned Ty.I_long_long), ARG a) =>
516 :     (case a of
517 :     T.LOAD (_, addr, region) =>
518 :     dwordmemarg (addr, region, [])
519 :     | _ => dwordarg (fn addr =>
520 :     T.STORE (64, addr, a, stack)))
521 :     | (Ty.C_float, FARG a) =>
522 :     (* we use the stack region reserved for storing
523 :     * %o0-%o5 as temporary storage for transferring
524 :     * floating point values *)
525 :     (case a of
526 :     T.FLOAD (_, addr, region) =>
527 :     wordarg (T.LOAD (32, addr, region), cpc, ss)
528 :     | _ =>
529 :     if n < 6 then let
530 :     val ld = T.MV (32, oreg n,
531 :     T.LOAD (32, tmpaddr, stack))
532 :     val cp = T.FSTORE (32, tmpaddr, a, stack)
533 :     in
534 :     loop (tl, al, n + 1, ss, cp :: ld :: asc, cpc)
535 :     end
536 :     else loop (tl, al, n + 1, ss,
537 :     T.FSTORE (32, argaddr n, a, stack)
538 :     :: asc,
539 :     cpc))
540 :     | (Ty.C_double, FARG a) =>
541 :     (case a of
542 :     T.FLOAD (_, addr, region) =>
543 :     dwordmemarg (addr, region, [])
544 :     | _ => dwordarg (fn addr =>
545 :     T.FSTORE (64, addr, a, stack)))
546 :     | (Ty.C_long_double, FARG a) => let
547 :     (* Copy 128-bit floating point value (16 bytes)
548 :     * into scratch space (aligned at 8-byte boundary).
549 :     * The address of the scratch copy is then
550 :     * passed as a regular 32-bit argument. *)
551 :     val ss' = roundup (ss, 8)
552 :     val ssaddr = addli (spreg, ss')
553 :     in
554 :     wordarg (ssaddr,
555 :     T.FSTORE (128, ssaddr, a, stack) :: cpc,
556 :     ss' + 16)
557 :     end
558 :     | (t as Ty.C_STRUCT _, a) => let
559 :     (* copy entire struct into scratch space
560 :     * (aligned according to struct's alignment
561 :     * requirements). The address of the scratch
562 :     * copy is then passed as a regular 32-bit
563 :     * argument. *)
564 :     val (sz, al) = szal t
565 :     val ss' = roundup (ss, al)
566 :     val ssaddr = addli (spreg, ss')
567 :     val cpc' = struct_copy (sz, al, a, t, ss', cpc)
568 :     in
569 :     wordarg (ssaddr, cpc', ss' + sz)
570 :     end
571 :     | _ => error "argument/type mismatch"
572 :     end
573 :     | loop _ = error "wrong number of arguments"
574 :     in
575 :     loop (paramTys, args, 0, scratchstart, [], [])
576 :     end
577 :    
578 :     val (defs, uses) = let
579 :     val gp = T.GPR o reg32
580 :     val fp = T.FPR o freg64
581 :     val g_regs = map (gp o greg) [1, 2, 3, 4, 5, 6, 7]
582 :     val a_regs = map (gp o oreg) [0, 1, 2, 3, 4, 5]
583 :     val l_reg = gp (oreg 7)
584 :     val f_regs = map (fp o freg)
585 :     [0, 2, 4, 6, 8, 10, 12, 14,
586 :     16, 18, 20, 22, 24, 26, 28, 30]
587 :     (* a call instruction defines all caller-save registers:
588 :     * - %g1 - %g7
589 :     * - %o0 - %o5 (argument registers)
590 :     * - %o7 (link register)
591 :     * - all fp registers *)
592 :    
593 :     val defs = g_regs @ a_regs @ l_reg :: f_regs
594 :     (* A call instruction "uses" just the argument registers. *)
595 :     val uses = List.take (a_regs, regargwords)
596 :     in
597 :     (defs, uses)
598 :     end
599 :    
600 :     val result =
601 :     case retTy of
602 :     Ty.C_float => [T.FPR (T.FREG (32, FP 0))]
603 :     | Ty.C_double => [T.FPR (T.FREG (64, FP 0))] (* %f0/%f1 *)
604 :     | Ty.C_long_double => []
605 :     | Ty.C_STRUCT _ => []
606 :     | Ty.C_ARRAY _ => error "array return type"
607 :     | (Ty.C_PTR | Ty.C_void |
608 :     Ty.C_signed (Ty.I_int | Ty.I_long) |
609 :     Ty.C_unsigned (Ty.I_int | Ty.I_long)) =>
610 :     [T.GPR (T.REG (32, oreg 0))]
611 :     | (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) =>
612 :     [T.GPR (T.REG (8, oreg 0))]
613 :     | (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>
614 :     [T.GPR (T.REG (16, oreg 0))]
615 :     | (Ty.C_signed Ty.I_long_long | Ty.C_unsigned Ty.I_long_long) =>
616 :     [T.GPR (T.REG (64, oreg 0))]
617 :    
618 :     val { save, restore } = saveRestoreDedicated defs
619 :    
620 :     val (sretsetup, srethandshake) =
621 :     case res_szal of
622 :     NONE => ([], [])
623 :     | SOME (sz, al) => let
624 :     val addr = structRet { szb = sz, align = al }
625 :     in
626 :     ([T.STORE (32, addli (spreg, 64), addr, stack)],
627 :     [T.EXT (ix (IX.UNIMP sz))])
628 :     end
629 :    
630 :     val call = T.CALL { funct = name, targets = [],
631 :     defs = defs, uses = uses,
632 :     region = mem, pops = 0 }
633 :    
634 :     val call =
635 :     case callComment of
636 :     NONE => call
637 :     | SOME c =>
638 :     T.ANNOTATION (call, #create MLRiscAnnotations.COMMENT c)
639 :    
640 :     val (sp_sub, sp_add) =
641 :     if stackdelta = 0 then ([], []) else
642 :     if paramAlloc { szb = stackdelta, align = 4 } then ([], [])
643 :     else ([T.MV (32, sp, T.SUB (32, spreg, LI stackdelta))],
644 :     [T.MV (32, sp, addli (spreg, stackdelta))])
645 :    
646 :     val callseq =
647 :     List.concat [sp_sub,
648 :     copycode,
649 :     argsetupcode,
650 :     sretsetup,
651 :     save,
652 :     [call],
653 :     srethandshake,
654 :     restore,
655 :     sp_add]
656 :    
657 :     in
658 :     { callseq = callseq, result = result }
659 :     end
660 : jhr 1445 *****)
661 :    
662 :     end

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