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 1346 - (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 :     *)
51 :    
52 :     (* we extend the interface to support generating the stubs needed for
53 :     * dynamic linking (see "Inside MacOS X: Mach-O Runtime Architecture"
54 :     * for details.
55 :     *)
56 :     signature PPC_MACOSX_C_CALLS =
57 :     sig
58 :     include C_CALLS
59 :     end;
60 :    
61 :     functor PPCMacOSX_CCalls (
62 :    
63 :     structure T : MLTREE
64 :     val ix : (T.stm, T.rexp, T.fexp, T.ccexp) PPCInstrExt.sext -> T.sext
65 :    
66 :     ): PPC_MACOSX_C_CALLS = struct
67 :     structure T = T
68 :     structure Ty = CTypes
69 :     structure C = PPCCells
70 :     structure IX = PPCInstrExt
71 :    
72 :     fun error msg = MLRiscErrorMsg.error ("PPCCompCCalls", msg)
73 :    
74 :     datatype arg_loc
75 :     = GPR of C.cell
76 :     | FPR of C.cell
77 :     | STK
78 :    
79 :     type arg_pos = {
80 :     offset : int, (* stack offset of memory for argument *)
81 :     loc : arg_loc (* location where argument is passed *)
82 :     }
83 :    
84 :     datatype c_arg
85 :     = ARG of T.rexp
86 :     | FARG of T.fexp
87 :     | ARGS of c_arg list
88 :    
89 :     val mem = T.Region.memory
90 :     val stack = T.Region.memory
91 :    
92 :     val maxRegArgs = 6
93 :     val paramAreaOffset = 68
94 :    
95 :     fun LI i = T.LI (T.I.fromInt (32, i))
96 :    
97 :     val GP = C.GPReg
98 :     val FP = C.FPReg
99 :    
100 :     fun greg r = GP r
101 :     fun oreg r = GP (r + 8)
102 :     fun freg r = FP r
103 :    
104 :     fun reg32 r = T.REG (32, r)
105 :     fun freg64 r = T.FREG (64, r)
106 :    
107 :     val sp = oreg 6
108 :     val spreg = reg32 sp
109 :    
110 :     fun addli (x, 0) = x
111 :     | addli (x, d) = let
112 :     val d' = T.I.fromInt (32, d)
113 :     in
114 :     case x of
115 :     T.ADD (_, r, T.LI d) =>
116 :     T.ADD (32, r, T.LI (T.I.ADD (32, d, d')))
117 :     | _ => T.ADD (32, x, T.LI d')
118 :     end
119 :    
120 :     fun argaddr n = addli (spreg, paramAreaOffset + 4*n)
121 :    
122 :     (* temp location for transfers through memory *)
123 :     val tmpaddr = argaddr 1
124 :    
125 :     fun roundup (i, a) = a * ((i + a - 1) div a)
126 :    
127 :     (* calculate size and alignment for a C type *)
128 :     fun szal (Ty.C_void | Ty.C_float | Ty.C_PTR |
129 :     Ty.C_signed (Ty.I_int | Ty.I_long) |
130 :     Ty.C_unsigned (Ty.I_int | Ty.I_long)) = (4, 4)
131 :     | szal (Ty.C_double |
132 :     Ty.C_signed Ty.I_long_long |
133 :     Ty.C_unsigned Ty.I_long_long) = (8, 8)
134 :     | szal (Ty.C_long_double) = (16, 8)
135 :     | szal (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) = (1, 1)
136 :     | szal (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) = (2, 2)
137 :     | szal (Ty.C_ARRAY (t, n)) = let val (s, a) = szal t in (n * s, a) end
138 :     | szal (Ty.C_STRUCT l) =
139 :     let (* i: next free memory address (relative to struct start);
140 :     * a: current total alignment,
141 :     * l: list of struct member types *)
142 :     fun pack (i, a, []) =
143 :     (* when we are done with all elements, the total size
144 :     * of the struct must be padded out to its own alignment *)
145 :     (roundup (i, a), a)
146 :     | pack (i, a, t :: tl) = let
147 :     val (ts, ta) = szal t (* size and alignment for member *)
148 :     in
149 :     (* member must be aligned according to its own
150 :     * alignment requirement; the next free position
151 :     * is then at "aligned member-address plus member-size";
152 :     * new total alignment is max of current alignment
153 :     * and member alignment (assuming all alignments are
154 :     * powers of 2) *)
155 :     pack (roundup (i, ta) + ts, Int.max (a, ta), tl)
156 :     end
157 :     in
158 :     pack (0, 1, l)
159 :     end
160 :    
161 :     fun genCall { name, proto, paramAlloc, structRet, saveRestoreDedicated,
162 :     callComment, args } = let
163 :     val { conv, retTy, paramTys } = proto
164 :     val _ = case conv of
165 :     ("" | "ccall") => ()
166 :     | _ => error (concat ["unknown calling convention \"",
167 :     String.toString conv, "\""])
168 :     val res_szal =
169 :     case retTy of
170 :     (Ty.C_long_double | Ty.C_STRUCT _) => SOME (szal retTy)
171 :     | _ => NONE
172 :    
173 :     val nargwords = let
174 :     fun loop ([], n) = n
175 :     | loop (t :: tl, n) =
176 :     loop (tl, (case t of
177 :     (Ty.C_double | Ty.C_signed Ty.I_long_long |
178 :     Ty.C_unsigned Ty.I_long_long) => 2
179 :     | _ => 1) + n)
180 :     in
181 :     loop (paramTys, 0)
182 :     end
183 :    
184 :     val regargwords = Int.min (nargwords, maxRegArgs)
185 :     val stackargwords = Int.max (nargwords, maxRegArgs) - maxRegArgs
186 :    
187 :     val stackargsstart = paramAreaOffset + 4 * maxRegArgs
188 :    
189 :     val scratchstart = stackargsstart + 4 * stackargwords
190 :    
191 :     (* Copy struct or part thereof to designated area on the stack.
192 :     * An already properly aligned address (relative to %sp) is
193 :     * in to_off. *)
194 :     fun struct_copy (sz, al, ARG a, t, to_off, cpc) =
195 :     (* Two main cases here:
196 :     * 1. t is C_STRUCT _: in this case "a" computes the address
197 :     * of the struct to be copied.
198 :     * 2. t is some other non-floating type; "a" computes the
199 :     * the corresponding value (i.e., not its address).
200 :     *)
201 :     let fun ldst ty =
202 :     T.STORE (ty, addli (spreg, to_off), a, stack) :: cpc
203 :     in
204 :     case t of
205 :     (Ty.C_void | Ty.C_PTR |
206 :     Ty.C_signed (Ty.I_int | Ty.I_long) |
207 :     Ty.C_unsigned (Ty.I_int | Ty.I_long)) => ldst 32
208 :     | (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) => ldst 8
209 :     | (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>
210 :     ldst 16
211 :     | (Ty.C_signed Ty.I_long_long |
212 :     Ty.C_unsigned Ty.I_long_long) => ldst 64
213 :     | (Ty.C_ARRAY _) =>
214 :     error "ARRAY within gather/scatter struct"
215 :     | (Ty.C_STRUCT _) =>
216 :     (* Here we have to do the equivalent of a "memcpy". *)
217 :     let val from = a (* argument is address of struct *)
218 :     fun cp (ty, incr) = let
219 :     fun load_from from_off =
220 :     T.LOAD (32, addli (from, from_off), mem)
221 :     (* from_off is relative to from,
222 :     * to_off is relative to %sp *)
223 :     fun loop (i, from_off, to_off, cpc) =
224 :     if i <= 0 then cpc
225 :     else loop (i - incr,
226 :     from_off + incr, to_off + incr,
227 :     T.STORE (ty, addli (spreg, to_off),
228 :     load_from from_off,
229 :     stack)
230 :     :: cpc)
231 :     in
232 :     loop (sz, 0, to_off, cpc)
233 :     end
234 :     in
235 :     case al of
236 :     1 => cp (8, 1)
237 :     | 2 => cp (16, 2)
238 :     | _ => (* 4 or more *) cp (32, 4)
239 :     end
240 :     | (Ty.C_float | Ty.C_double | Ty.C_long_double) =>
241 :     error "floating point type does not match ARG"
242 :     end
243 :     | struct_copy (_, _, ARGS args, Ty.C_STRUCT tl, to_off, cpc) =
244 :     (* gather/scatter case *)
245 :     let fun loop ([], [], _, cpc) = cpc
246 :     | loop (t :: tl, a :: al, to_off, cpc) = let
247 :     val (tsz, tal) = szal t
248 :     val to_off' = roundup (to_off, tal)
249 :     val cpc' = struct_copy (tsz, tal, a, t, to_off', cpc)
250 :     in
251 :     loop (tl, al, to_off' + tsz, cpc')
252 :     end
253 :     | loop _ =
254 :     error "number of types does not match number of arguments"
255 :     in
256 :     loop (tl, args, to_off, cpc)
257 :     end
258 :     | struct_copy (_, _, ARGS _, _, _, _) =
259 :     error "gather/scatter for non-struct"
260 :     | struct_copy (sz, al, FARG a, t, to_off, cpc) =
261 :     let fun fldst ty =
262 :     T.FSTORE (ty, addli (spreg, to_off), a, stack) :: cpc
263 :     in
264 :     case t of
265 :     Ty.C_float => fldst 32
266 :     | Ty.C_double => fldst 64
267 :     | Ty.C_long_double => fldst 128
268 :     | _ => error "non-floating-point type does not match FARG"
269 :     end
270 :    
271 :     val (stackdelta, argsetupcode, copycode) = let
272 :     fun loop ([], [], _, ss, asc, cpc) =
273 :     (roundup (Int.max (0, ss - stackargsstart), 8), asc, cpc)
274 :     | loop (t :: tl, a :: al, n, ss, asc, cpc) = let
275 :     fun wordassign a =
276 :     if n < 6 then T.MV (32, oreg n, a)
277 :     else T.STORE (32, argaddr n, a, stack)
278 :     fun wordarg (a, cpc, ss) =
279 :     loop (tl, al, n + 1, ss, wordassign a :: asc, cpc)
280 :    
281 :     fun dwordmemarg (addr, region, tmpstore) = let
282 :     fun toreg (n, addr) =
283 :     T.MV (32, oreg n, T.LOAD (32, addr, region))
284 :     fun tomem (n, addr) =
285 :     T.STORE (32,
286 :     argaddr n,
287 :     T.LOAD (32, addr, region),
288 :     stack)
289 :     fun toany (n, addr) =
290 :     if n < 6 then toreg (n, addr) else tomem (n, addr)
291 :     in
292 :     (* if n < 6 andalso n div 2 = 0 then
293 :     * use ldd here once MLRISC gets its usage right
294 :     * else
295 :     * ... *)
296 :     loop (tl, al, n+2, ss,
297 :     tmpstore @
298 :     toany (n, addr)
299 :     :: toany (n+1, addli (addr, 4))
300 :     :: asc,
301 :     cpc)
302 :     end
303 :     fun dwordarg mkstore =
304 :     if n > 6 andalso n div 2 = 1 then
305 :     (* 8-byte aligned memory *)
306 :     loop (tl, al, n+2, ss,
307 :     mkstore (argaddr n) :: asc,
308 :     cpc)
309 :     else dwordmemarg (tmpaddr, stack, [mkstore tmpaddr])
310 :     in
311 :     case (t, a) of
312 :     ((Ty.C_void | Ty.C_PTR | Ty.C_ARRAY _ |
313 :     Ty.C_unsigned (Ty.I_int | Ty.I_long) |
314 :     Ty.C_signed (Ty.I_int | Ty.I_long)),
315 :     ARG a) => wordarg (a, cpc, ss)
316 :     | (Ty.C_signed Ty.I_char, ARG a) =>
317 :     wordarg (T.SX (32, 8, a), cpc, ss)
318 :     | (Ty.C_unsigned Ty.I_char, ARG a) =>
319 :     wordarg (T.ZX (32, 8, a), cpc, ss)
320 :     | (Ty.C_signed Ty.I_short, ARG a) =>
321 :     wordarg (T.SX (32, 16, a), cpc, ss)
322 :     | (Ty.C_unsigned Ty.I_short, ARG a) =>
323 :     wordarg (T.ZX (32, 16, a), cpc, ss)
324 :     | ((Ty.C_signed Ty.I_long_long |
325 :     Ty.C_unsigned Ty.I_long_long), ARG a) =>
326 :     (case a of
327 :     T.LOAD (_, addr, region) =>
328 :     dwordmemarg (addr, region, [])
329 :     | _ => dwordarg (fn addr =>
330 :     T.STORE (64, addr, a, stack)))
331 :     | (Ty.C_float, FARG a) =>
332 :     (* we use the stack region reserved for storing
333 :     * %o0-%o5 as temporary storage for transferring
334 :     * floating point values *)
335 :     (case a of
336 :     T.FLOAD (_, addr, region) =>
337 :     wordarg (T.LOAD (32, addr, region), cpc, ss)
338 :     | _ =>
339 :     if n < 6 then let
340 :     val ld = T.MV (32, oreg n,
341 :     T.LOAD (32, tmpaddr, stack))
342 :     val cp = T.FSTORE (32, tmpaddr, a, stack)
343 :     in
344 :     loop (tl, al, n + 1, ss, cp :: ld :: asc, cpc)
345 :     end
346 :     else loop (tl, al, n + 1, ss,
347 :     T.FSTORE (32, argaddr n, a, stack)
348 :     :: asc,
349 :     cpc))
350 :     | (Ty.C_double, FARG a) =>
351 :     (case a of
352 :     T.FLOAD (_, addr, region) =>
353 :     dwordmemarg (addr, region, [])
354 :     | _ => dwordarg (fn addr =>
355 :     T.FSTORE (64, addr, a, stack)))
356 :     | (Ty.C_long_double, FARG a) => let
357 :     (* Copy 128-bit floating point value (16 bytes)
358 :     * into scratch space (aligned at 8-byte boundary).
359 :     * The address of the scratch copy is then
360 :     * passed as a regular 32-bit argument. *)
361 :     val ss' = roundup (ss, 8)
362 :     val ssaddr = addli (spreg, ss')
363 :     in
364 :     wordarg (ssaddr,
365 :     T.FSTORE (128, ssaddr, a, stack) :: cpc,
366 :     ss' + 16)
367 :     end
368 :     | (t as Ty.C_STRUCT _, a) => let
369 :     (* copy entire struct into scratch space
370 :     * (aligned according to struct's alignment
371 :     * requirements). The address of the scratch
372 :     * copy is then passed as a regular 32-bit
373 :     * argument. *)
374 :     val (sz, al) = szal t
375 :     val ss' = roundup (ss, al)
376 :     val ssaddr = addli (spreg, ss')
377 :     val cpc' = struct_copy (sz, al, a, t, ss', cpc)
378 :     in
379 :     wordarg (ssaddr, cpc', ss' + sz)
380 :     end
381 :     | _ => error "argument/type mismatch"
382 :     end
383 :     | loop _ = error "wrong number of arguments"
384 :     in
385 :     loop (paramTys, args, 0, scratchstart, [], [])
386 :     end
387 :    
388 :     val (defs, uses) = let
389 :     val gp = T.GPR o reg32
390 :     val fp = T.FPR o freg64
391 :     val g_regs = map (gp o greg) [1, 2, 3, 4, 5, 6, 7]
392 :     val a_regs = map (gp o oreg) [0, 1, 2, 3, 4, 5]
393 :     val l_reg = gp (oreg 7)
394 :     val f_regs = map (fp o freg)
395 :     [0, 2, 4, 6, 8, 10, 12, 14,
396 :     16, 18, 20, 22, 24, 26, 28, 30]
397 :     (* a call instruction defines all caller-save registers:
398 :     * - %g1 - %g7
399 :     * - %o0 - %o5 (argument registers)
400 :     * - %o7 (link register)
401 :     * - all fp registers *)
402 :    
403 :     val defs = g_regs @ a_regs @ l_reg :: f_regs
404 :     (* A call instruction "uses" just the argument registers. *)
405 :     val uses = List.take (a_regs, regargwords)
406 :     in
407 :     (defs, uses)
408 :     end
409 :    
410 :     val result =
411 :     case retTy of
412 :     Ty.C_float => [T.FPR (T.FREG (32, FP 0))]
413 :     | Ty.C_double => [T.FPR (T.FREG (64, FP 0))] (* %f0/%f1 *)
414 :     | Ty.C_long_double => []
415 :     | Ty.C_STRUCT _ => []
416 :     | Ty.C_ARRAY _ => error "array return type"
417 :     | (Ty.C_PTR | Ty.C_void |
418 :     Ty.C_signed (Ty.I_int | Ty.I_long) |
419 :     Ty.C_unsigned (Ty.I_int | Ty.I_long)) =>
420 :     [T.GPR (T.REG (32, oreg 0))]
421 :     | (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) =>
422 :     [T.GPR (T.REG (8, oreg 0))]
423 :     | (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>
424 :     [T.GPR (T.REG (16, oreg 0))]
425 :     | (Ty.C_signed Ty.I_long_long | Ty.C_unsigned Ty.I_long_long) =>
426 :     [T.GPR (T.REG (64, oreg 0))]
427 :    
428 :     val { save, restore } = saveRestoreDedicated defs
429 :    
430 :     val (sretsetup, srethandshake) =
431 :     case res_szal of
432 :     NONE => ([], [])
433 :     | SOME (sz, al) => let
434 :     val addr = structRet { szb = sz, align = al }
435 :     in
436 :     ([T.STORE (32, addli (spreg, 64), addr, stack)],
437 :     [T.EXT (ix (IX.UNIMP sz))])
438 :     end
439 :    
440 :     val call = T.CALL { funct = name, targets = [],
441 :     defs = defs, uses = uses,
442 :     region = mem, pops = 0 }
443 :    
444 :     val call =
445 :     case callComment of
446 :     NONE => call
447 :     | SOME c =>
448 :     T.ANNOTATION (call, #create MLRiscAnnotations.COMMENT c)
449 :    
450 :     val (sp_sub, sp_add) =
451 :     if stackdelta = 0 then ([], []) else
452 :     if paramAlloc { szb = stackdelta, align = 4 } then ([], [])
453 :     else ([T.MV (32, sp, T.SUB (32, spreg, LI stackdelta))],
454 :     [T.MV (32, sp, addli (spreg, stackdelta))])
455 :    
456 :     val callseq =
457 :     List.concat [sp_sub,
458 :     copycode,
459 :     argsetupcode,
460 :     sretsetup,
461 :     save,
462 :     [call],
463 :     srethandshake,
464 :     restore,
465 :     sp_add]
466 :    
467 :     in
468 :     { callseq = callseq, result = result }
469 :     end
470 :     end

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