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

Annotation of /sml/trunk/src/MLRISC/sparc/c-calls/sparc-c-calls.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1552 - (view) (download)

1 : blume 840 (* sparc-c-calls.sml
2 :     *
3 :     * COPYRIGHT (c) 2001 Bell Labs, Lucent Technologies
4 :     *
5 :     * author: Matthias Blume (blume@reseach.bell-labs.com)
6 :     *
7 :     * Comment: This is a first cut. It might be quite sub-optimal for some cases.
8 :     * (For example, I make no attempt at using ldd/ldx for
9 :     * copying stuff around because this would require keeping
10 :     * more track of alignment issues.)
11 :     *
12 :     * C function calls for the Sparc
13 :     *
14 :     * Register conventions:
15 :     *
16 :     * ?
17 :     *
18 :     * Calling convention:
19 :     *
20 :     * Return result:
21 :     * + Integer and pointer results are returned in %o0
22 :     * + 64-bit integers (long long) returned in %o1/%o1
23 :     * + float results are returned in %f0; double in %f0/%f1
24 :     * + Struct results are returned in space provided by the caller.
25 :     * The address of this space is passed to the callee as a hidden
26 :     * implicit argument on the stack (in the caller's frame). It
27 :     * gets stored at [%sp+64] (from the caller's point of view).
28 :     * An UNIMP instruction must be placed after the call instruction,
29 :     * indicating how much space has been reserved for the return value.
30 :     * + long double results are returned like structs
31 :     *
32 :     * Function arguments:
33 :     * + Arguments that are smaller than a word are promoted to word-size.
34 :     * + Up to six argument words (words 0-5) are passed in registers
35 :     * %o0...%o5. This includes doubles and long longs. Alignment for
36 :     * those types is NOT maintained, i.e., it is possible for an 8-byte
37 :     * quantity to end up in an odd-even register pair.
38 :     * * Arguments beyond 6 words are passed on the stack in the caller's
39 :     * frame. For this, the caller must reserve space in its frame
40 :     * prior to the call. Argument word 6 appears at [%sp+92], word 7
41 :     * at [%sp+96], ...
42 :     * + struct arguments are passed as pointers to a copy of the struct.
43 :     * The copy itself is allocated by the caller in its stack frame.
44 :     * + long double arguments are passed like structs (i.e., via pointer
45 :     * to temp copy)
46 :     * + Space for argument words 0-5 is already allocated in the
47 :     * caller's frame. This space might be used by the callee to
48 :     * save those arguments that must be addressable. %o0 corresponds
49 :     * to [%sp+68], %o1 to [%sp+72], ...
50 :     *)
51 :     functor Sparc_CCalls
52 :     (structure T : MLTREE
53 :     val ix : (T.stm, T.rexp, T.fexp, T.ccexp) SparcInstrExt.sext
54 :     -> T.sext): C_CALLS =
55 :     struct
56 :     structure T = T
57 :     structure Ty = CTypes
58 :     structure C = SparcCells
59 :     structure IX = SparcInstrExt
60 :    
61 :     fun error msg = MLRiscErrorMsg.error ("SparcCompCCalls", msg)
62 :    
63 :     datatype c_arg =
64 :     ARG of T.rexp
65 :     | FARG of T.fexp
66 :     | ARGS of c_arg list
67 :    
68 :     val mem = T.Region.memory
69 :     val stack = T.Region.memory
70 :    
71 : blume 1045 val maxRegArgs = 6
72 : jhr 1043 val paramAreaOffset = 68
73 :    
74 : blume 840 fun LI i = T.LI (T.I.fromInt (32, i))
75 :    
76 :     val GP = C.GPReg
77 :     val FP = C.FPReg
78 :    
79 :     fun greg r = GP r
80 :     fun oreg r = GP (r + 8)
81 : jhr 1521 fun ireg r = GP (r + 24)
82 : blume 840 fun freg r = FP r
83 :    
84 :     fun reg32 r = T.REG (32, r)
85 :     fun freg64 r = T.FREG (64, r)
86 :    
87 :     val sp = oreg 6
88 :     val spreg = reg32 sp
89 :    
90 :     fun addli (x, 0) = x
91 :     | addli (x, d) = let
92 :     val d' = T.I.fromInt (32, d)
93 :     in
94 :     case x of
95 :     T.ADD (_, r, T.LI d) =>
96 :     T.ADD (32, r, T.LI (T.I.ADD (32, d, d')))
97 :     | _ => T.ADD (32, x, T.LI d')
98 :     end
99 :    
100 : jhr 1043 fun argaddr n = addli (spreg, paramAreaOffset + 4*n)
101 : blume 841
102 : blume 840 (* temp location for transfers through memory *)
103 : blume 841 val tmpaddr = argaddr 1
104 : blume 840
105 :     fun roundup (i, a) = a * ((i + a - 1) div a)
106 :    
107 :     (* calculate size and alignment for a C type *)
108 :     fun szal (Ty.C_void | Ty.C_float | Ty.C_PTR |
109 :     Ty.C_signed (Ty.I_int | Ty.I_long) |
110 :     Ty.C_unsigned (Ty.I_int | Ty.I_long)) = (4, 4)
111 :     | szal (Ty.C_double |
112 :     Ty.C_signed Ty.I_long_long |
113 :     Ty.C_unsigned Ty.I_long_long) = (8, 8)
114 :     | szal (Ty.C_long_double) = (16, 8)
115 :     | szal (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) = (1, 1)
116 :     | szal (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) = (2, 2)
117 :     | szal (Ty.C_ARRAY (t, n)) = let val (s, a) = szal t in (n * s, a) end
118 :     | szal (Ty.C_STRUCT l) =
119 :     let (* i: next free memory address (relative to struct start);
120 :     * a: current total alignment,
121 :     * l: list of struct member types *)
122 :     fun pack (i, a, []) =
123 :     (* when we are done with all elements, the total size
124 :     * of the struct must be padded out to its own alignment *)
125 :     (roundup (i, a), a)
126 :     | pack (i, a, t :: tl) = let
127 :     val (ts, ta) = szal t (* size and alignment for member *)
128 :     in
129 :     (* member must be aligned according to its own
130 :     * alignment requirement; the next free position
131 :     * is then at "aligned member-address plus member-size";
132 :     * new total alignment is max of current alignment
133 :     * and member alignment (assuming all alignments are
134 :     * powers of 2) *)
135 :     pack (roundup (i, ta) + ts, Int.max (a, ta), tl)
136 :     end
137 :     in
138 :     pack (0, 1, l)
139 :     end
140 : mblume 1552 | szal (Ty.C_UNION l) =
141 :     let (* m: current max size
142 :     * a: current total alignment *)
143 :     fun overlay (m, a, []) = (roundup (m, a), a)
144 :     | overlay (m, a, t :: tl) =
145 :     let val (ts, ta) = szal t
146 :     in
147 :     overlay (Int.max (m, ts), Int.max (a, ta), tl)
148 :     end
149 :     in
150 :     overlay (0, 1, l)
151 :     end
152 : blume 840
153 : jhr 1521 (**** START NEW CODE ****)
154 :    
155 :     (* the location of arguments/parameters; offsets are given with respect to the
156 :     * low end of the parameter area (see paramAreaOffset above).
157 :     *)
158 :     datatype arg_location
159 : jhr 1523 = Reg of T.ty * T.reg * T.I.machine_int option
160 :     (* integer/pointer argument in register *)
161 :     | FReg of T.fty * T.reg * T.I.machine_int option
162 :     (* floating-point argument in register *)
163 : jhr 1521 | Stk of T.ty * T.I.machine_int (* integer/pointer argument in parameter area *)
164 :     | FStk of T.fty * T.I.machine_int (* floating-point argument in parameter area *)
165 :     | Args of arg_location list
166 :    
167 :     fun layout {conv, retTy, paramTys} = let
168 :     in
169 :     raise Fail "layout not implemented yet"
170 :     end
171 :    
172 :     (* C callee-save registers *)
173 :     val calleeSaveRegs = (* %l0-%l7 and %i0-%i7 *)
174 :     List.tabulate (16, fn r => GP(r+16))
175 :     val calleeSaveFRegs = []
176 :    
177 :     (**** END NEW CODE ****)
178 :    
179 : jhr 1043 fun genCall { name, proto, paramAlloc, structRet, saveRestoreDedicated,
180 : blume 840 callComment, args } = let
181 :     val { conv, retTy, paramTys } = proto
182 :     val _ = case conv of
183 :     ("" | "ccall") => ()
184 :     | _ => error (concat ["unknown calling convention \"",
185 :     String.toString conv, "\""])
186 :     val res_szal =
187 :     case retTy of
188 : mblume 1552 (Ty.C_long_double | Ty.C_STRUCT _ | Ty.C_UNION _) =>
189 :     SOME (szal retTy)
190 : blume 840 | _ => NONE
191 :    
192 :     val nargwords = let
193 :     fun loop ([], n) = n
194 :     | loop (t :: tl, n) =
195 :     loop (tl, (case t of
196 :     (Ty.C_double | Ty.C_signed Ty.I_long_long |
197 :     Ty.C_unsigned Ty.I_long_long) => 2
198 :     | _ => 1) + n)
199 :     in
200 :     loop (paramTys, 0)
201 :     end
202 :    
203 : blume 1045 val regargwords = Int.min (nargwords, maxRegArgs)
204 :     val stackargwords = Int.max (nargwords, maxRegArgs) - maxRegArgs
205 : blume 840
206 : blume 1049 val stackargsstart = paramAreaOffset + 4 * maxRegArgs
207 : blume 840
208 : blume 1049 val scratchstart = stackargsstart + 4 * stackargwords
209 :    
210 : blume 840 (* Copy struct or part thereof to designated area on the stack.
211 :     * An already properly aligned address (relative to %sp) is
212 :     * in to_off. *)
213 :     fun struct_copy (sz, al, ARG a, t, to_off, cpc) =
214 :     (* Two main cases here:
215 : mblume 1552 * 1. t is C_STRUCT _ or C_UNION _;
216 :     * in this case "a" computes the address
217 : blume 840 * of the struct to be copied.
218 :     * 2. t is some other non-floating type; "a" computes the
219 :     * the corresponding value (i.e., not its address).
220 :     *)
221 :     let fun ldst ty =
222 :     T.STORE (ty, addli (spreg, to_off), a, stack) :: cpc
223 :     in
224 :     case t of
225 :     (Ty.C_void | Ty.C_PTR |
226 :     Ty.C_signed (Ty.I_int | Ty.I_long) |
227 :     Ty.C_unsigned (Ty.I_int | Ty.I_long)) => ldst 32
228 :     | (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) => ldst 8
229 :     | (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>
230 :     ldst 16
231 :     | (Ty.C_signed Ty.I_long_long |
232 :     Ty.C_unsigned Ty.I_long_long) => ldst 64
233 :     | (Ty.C_ARRAY _) =>
234 :     error "ARRAY within gather/scatter struct"
235 : mblume 1552 | (Ty.C_STRUCT _ | Ty.C_UNION _) =>
236 : blume 840 (* Here we have to do the equivalent of a "memcpy". *)
237 :     let val from = a (* argument is address of struct *)
238 :     fun cp (ty, incr) = let
239 :     fun load_from from_off =
240 :     T.LOAD (32, addli (from, from_off), mem)
241 :     (* from_off is relative to from,
242 :     * to_off is relative to %sp *)
243 :     fun loop (i, from_off, to_off, cpc) =
244 :     if i <= 0 then cpc
245 :     else loop (i - incr,
246 :     from_off + incr, to_off + incr,
247 :     T.STORE (ty, addli (spreg, to_off),
248 :     load_from from_off,
249 :     stack)
250 :     :: cpc)
251 :     in
252 :     loop (sz, 0, to_off, cpc)
253 :     end
254 :     in
255 :     case al of
256 :     1 => cp (8, 1)
257 :     | 2 => cp (16, 2)
258 :     | _ => (* 4 or more *) cp (32, 4)
259 :     end
260 :     | (Ty.C_float | Ty.C_double | Ty.C_long_double) =>
261 :     error "floating point type does not match ARG"
262 :     end
263 : mblume 1552 (*
264 : blume 840 | struct_copy (_, _, ARGS args, Ty.C_STRUCT tl, to_off, cpc) =
265 :     (* gather/scatter case *)
266 :     let fun loop ([], [], _, cpc) = cpc
267 :     | loop (t :: tl, a :: al, to_off, cpc) = let
268 :     val (tsz, tal) = szal t
269 :     val to_off' = roundup (to_off, tal)
270 :     val cpc' = struct_copy (tsz, tal, a, t, to_off', cpc)
271 :     in
272 :     loop (tl, al, to_off' + tsz, cpc')
273 :     end
274 :     | loop _ =
275 :     error "number of types does not match number of arguments"
276 :     in
277 :     loop (tl, args, to_off, cpc)
278 :     end
279 : mblume 1552 *)
280 : blume 840 | struct_copy (_, _, ARGS _, _, _, _) =
281 : mblume 1552 error "gather/scatter (ARGS) not supported (obsolete)"
282 : blume 840 | struct_copy (sz, al, FARG a, t, to_off, cpc) =
283 :     let fun fldst ty =
284 :     T.FSTORE (ty, addli (spreg, to_off), a, stack) :: cpc
285 :     in
286 :     case t of
287 :     Ty.C_float => fldst 32
288 :     | Ty.C_double => fldst 64
289 :     | Ty.C_long_double => fldst 128
290 :     | _ => error "non-floating-point type does not match FARG"
291 :     end
292 :    
293 :     val (stackdelta, argsetupcode, copycode) = let
294 : blume 1049 fun loop ([], [], _, ss, asc, cpc) =
295 :     (roundup (Int.max (0, ss - stackargsstart), 8), asc, cpc)
296 : blume 840 | loop (t :: tl, a :: al, n, ss, asc, cpc) = let
297 :     fun wordassign a =
298 :     if n < 6 then T.MV (32, oreg n, a)
299 : blume 841 else T.STORE (32, argaddr n, a, stack)
300 : blume 840 fun wordarg (a, cpc, ss) =
301 :     loop (tl, al, n + 1, ss, wordassign a :: asc, cpc)
302 :    
303 :     fun dwordmemarg (addr, region, tmpstore) = let
304 :     fun toreg (n, addr) =
305 :     T.MV (32, oreg n, T.LOAD (32, addr, region))
306 :     fun tomem (n, addr) =
307 :     T.STORE (32,
308 : blume 841 argaddr n,
309 : blume 840 T.LOAD (32, addr, region),
310 :     stack)
311 :     fun toany (n, addr) =
312 :     if n < 6 then toreg (n, addr) else tomem (n, addr)
313 :     in
314 : blume 841 (* if n < 6 andalso n div 2 = 0 then
315 :     * use ldd here once MLRISC gets its usage right
316 :     * else
317 :     * ... *)
318 : blume 840 loop (tl, al, n+2, ss,
319 :     tmpstore @
320 :     toany (n, addr)
321 :     :: toany (n+1, addli (addr, 4))
322 :     :: asc,
323 :     cpc)
324 :     end
325 : blume 841 fun dwordarg mkstore =
326 :     if n > 6 andalso n div 2 = 1 then
327 :     (* 8-byte aligned memory *)
328 :     loop (tl, al, n+2, ss,
329 :     mkstore (argaddr n) :: asc,
330 :     cpc)
331 :     else dwordmemarg (tmpaddr, stack, [mkstore tmpaddr])
332 : blume 840 in
333 :     case (t, a) of
334 :     ((Ty.C_void | Ty.C_PTR | Ty.C_ARRAY _ |
335 :     Ty.C_unsigned (Ty.I_int | Ty.I_long) |
336 :     Ty.C_signed (Ty.I_int | Ty.I_long)),
337 :     ARG a) => wordarg (a, cpc, ss)
338 :     | (Ty.C_signed Ty.I_char, ARG a) =>
339 :     wordarg (T.SX (32, 8, a), cpc, ss)
340 :     | (Ty.C_unsigned Ty.I_char, ARG a) =>
341 :     wordarg (T.ZX (32, 8, a), cpc, ss)
342 :     | (Ty.C_signed Ty.I_short, ARG a) =>
343 :     wordarg (T.SX (32, 16, a), cpc, ss)
344 :     | (Ty.C_unsigned Ty.I_short, ARG a) =>
345 :     wordarg (T.ZX (32, 16, a), cpc, ss)
346 :     | ((Ty.C_signed Ty.I_long_long |
347 :     Ty.C_unsigned Ty.I_long_long), ARG a) =>
348 :     (case a of
349 :     T.LOAD (_, addr, region) =>
350 :     dwordmemarg (addr, region, [])
351 : blume 841 | _ => dwordarg (fn addr =>
352 :     T.STORE (64, addr, a, stack)))
353 : blume 840 | (Ty.C_float, FARG a) =>
354 :     (* we use the stack region reserved for storing
355 :     * %o0-%o5 as temporary storage for transferring
356 :     * floating point values *)
357 :     (case a of
358 :     T.FLOAD (_, addr, region) =>
359 :     wordarg (T.LOAD (32, addr, region), cpc, ss)
360 :     | _ =>
361 :     if n < 6 then let
362 :     val ld = T.MV (32, oreg n,
363 :     T.LOAD (32, tmpaddr, stack))
364 :     val cp = T.FSTORE (32, tmpaddr, a, stack)
365 :     in
366 :     loop (tl, al, n + 1, ss, cp :: ld :: asc, cpc)
367 :     end
368 :     else loop (tl, al, n + 1, ss,
369 : blume 841 T.FSTORE (32, argaddr n, a, stack)
370 :     :: asc,
371 : blume 840 cpc))
372 :     | (Ty.C_double, FARG a) =>
373 : blume 841 (case a of
374 :     T.FLOAD (_, addr, region) =>
375 :     dwordmemarg (addr, region, [])
376 :     | _ => dwordarg (fn addr =>
377 :     T.FSTORE (64, addr, a, stack)))
378 : blume 840 | (Ty.C_long_double, FARG a) => let
379 :     (* Copy 128-bit floating point value (16 bytes)
380 :     * into scratch space (aligned at 8-byte boundary).
381 :     * The address of the scratch copy is then
382 :     * passed as a regular 32-bit argument. *)
383 :     val ss' = roundup (ss, 8)
384 :     val ssaddr = addli (spreg, ss')
385 :     in
386 :     wordarg (ssaddr,
387 :     T.FSTORE (128, ssaddr, a, stack) :: cpc,
388 :     ss' + 16)
389 :     end
390 : mblume 1552 | (t as (Ty.C_STRUCT _ | Ty.C_UNION _), a) => let
391 : blume 840 (* copy entire struct into scratch space
392 :     * (aligned according to struct's alignment
393 :     * requirements). The address of the scratch
394 :     * copy is then passed as a regular 32-bit
395 :     * argument. *)
396 :     val (sz, al) = szal t
397 :     val ss' = roundup (ss, al)
398 :     val ssaddr = addli (spreg, ss')
399 :     val cpc' = struct_copy (sz, al, a, t, ss', cpc)
400 :     in
401 :     wordarg (ssaddr, cpc', ss' + sz)
402 :     end
403 :     | _ => error "argument/type mismatch"
404 :     end
405 :     | loop _ = error "wrong number of arguments"
406 :     in
407 :     loop (paramTys, args, 0, scratchstart, [], [])
408 :     end
409 :    
410 :     val (defs, uses) = let
411 :     val gp = T.GPR o reg32
412 :     val fp = T.FPR o freg64
413 :     val g_regs = map (gp o greg) [1, 2, 3, 4, 5, 6, 7]
414 :     val a_regs = map (gp o oreg) [0, 1, 2, 3, 4, 5]
415 :     val l_reg = gp (oreg 7)
416 :     val f_regs = map (fp o freg)
417 :     [0, 2, 4, 6, 8, 10, 12, 14,
418 :     16, 18, 20, 22, 24, 26, 28, 30]
419 :     (* a call instruction defines all caller-save registers:
420 :     * - %g1 - %g7
421 :     * - %o0 - %o5 (argument registers)
422 :     * - %o7 (link register)
423 :     * - all fp registers *)
424 :    
425 :     val defs = g_regs @ a_regs @ l_reg :: f_regs
426 :     (* A call instruction "uses" just the argument registers. *)
427 : blume 1045 val uses = List.take (a_regs, regargwords)
428 : blume 840 in
429 :     (defs, uses)
430 :     end
431 :    
432 :     val result =
433 :     case retTy of
434 :     Ty.C_float => [T.FPR (T.FREG (32, FP 0))]
435 :     | Ty.C_double => [T.FPR (T.FREG (64, FP 0))] (* %f0/%f1 *)
436 :     | Ty.C_long_double => []
437 : mblume 1552 | (Ty.C_STRUCT _ | Ty.C_UNION _) => []
438 : blume 840 | Ty.C_ARRAY _ => error "array return type"
439 :     | (Ty.C_PTR | Ty.C_void |
440 :     Ty.C_signed (Ty.I_int | Ty.I_long) |
441 :     Ty.C_unsigned (Ty.I_int | Ty.I_long)) =>
442 :     [T.GPR (T.REG (32, oreg 0))]
443 :     | (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) =>
444 :     [T.GPR (T.REG (8, oreg 0))]
445 :     | (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>
446 :     [T.GPR (T.REG (16, oreg 0))]
447 :     | (Ty.C_signed Ty.I_long_long | Ty.C_unsigned Ty.I_long_long) =>
448 :     [T.GPR (T.REG (64, oreg 0))]
449 :    
450 :     val { save, restore } = saveRestoreDedicated defs
451 :    
452 :     val (sretsetup, srethandshake) =
453 :     case res_szal of
454 :     NONE => ([], [])
455 :     | SOME (sz, al) => let
456 :     val addr = structRet { szb = sz, align = al }
457 :     in
458 :     ([T.STORE (32, addli (spreg, 64), addr, stack)],
459 :     [T.EXT (ix (IX.UNIMP sz))])
460 :     end
461 :    
462 :     val call = T.CALL { funct = name, targets = [],
463 :     defs = defs, uses = uses,
464 :     region = mem, pops = 0 }
465 :    
466 :     val call =
467 :     case callComment of
468 :     NONE => call
469 :     | SOME c =>
470 :     T.ANNOTATION (call, #create MLRiscAnnotations.COMMENT c)
471 :    
472 : blume 1045 val (sp_sub, sp_add) =
473 :     if stackdelta = 0 then ([], []) else
474 :     if paramAlloc { szb = stackdelta, align = 4 } then ([], [])
475 :     else ([T.MV (32, sp, T.SUB (32, spreg, LI stackdelta))],
476 :     [T.MV (32, sp, addli (spreg, stackdelta))])
477 :    
478 : blume 840 val callseq =
479 : blume 1045 List.concat [sp_sub,
480 : blume 840 copycode,
481 :     argsetupcode,
482 :     sretsetup,
483 :     save,
484 :     [call],
485 :     srethandshake,
486 :     restore,
487 : blume 1045 sp_add]
488 : blume 840
489 :     in
490 :     { callseq = callseq, result = result }
491 :     end
492 :     end

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