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

Parent Directory | Revision Log

---

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

---

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