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

Parent Directory | Revision Log | Patch

	revision 1438, Mon Jan 12 03:12:20 2004 UTC	revision 1532, Tue Jul 13 03:49:10 2004 UTC
#	Line 80	Line 80
80	functor PPCMacOSX_CCalls (	functor PPCMacOSX_CCalls (
81
82	structure T : MLTREE	structure T : MLTREE
	val ix : (T.stm, T.rexp, T.fexp, T.ccexp) PPCInstrExt.sext -> T.sext
83
84	): PPC_MACOSX_C_CALLS = struct	): C_CALLS = struct
85
86	structure T  = T	structure T  = T
87	structure Ty = CTypes	structure CTy = CTypes
88	structure C = PPCCells	structure C = PPCCells
	structure IX = PPCInstrExt
89
90	fun error msg = MLRiscErrorMsg.error ("PPCCompCCalls", msg)	fun error msg = MLRiscErrorMsg.error ("PPCCompCCalls", msg)
91
92	datatype arg_loc	(* the location of arguments/parameters; offsets are given with respect to the
93	= GPR of C.cell	* low end of the parameter area.
94	| FPR of C.cell	*)
95	| STK	datatype arg_location
96		= Reg of T.ty * T.reg * T.I.machine_int option
97	type arg_pos = {	(* integer/pointer argument in register *)
98	offset : int,           (* stack offset of memory for argument *)	| FReg of T.fty * T.reg * T.I.machine_int option
99	loc : arg_loc           (* location where argument is passed *)	(* floating-point argument in register *)
100	}	| Stk of T.ty * T.I.machine_int   (* integer/pointer argument in parameter area *)
101		| FStk of T.fty * T.I.machine_int (* floating-point argument in parameter area *)
102		| Args of arg_location list
103
104		val wordTy = 32
105		val fltTy = 32      (* MLRISC type of float *)
106		val dblTy = 64      (* MLRISC type of double *)
107
108		(* stack pointer *)
109		val spReg = T.REG(wordTy, C.GPReg 1)
110
111		(* registers used for parameter passing *)
112		val argGPRs = List.map C.GPReg [3, 4, 5, 6, 7, 8, 9, 10]
113		val argFPRs = List.map C.FPReg [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13]
114		val resGPR = C.GPReg 3
115		val resRegLoc = Reg(wordTy, resGPR, NONE)
116		val resFPR = C.FPReg 1
117
118		(* C callee-save registers *)
119		val calleeSaveRegs = List.map C.GPReg [
120		13, 14, 15, 16, 17, 18, 19, 20, 21, 22,
121		23, 24, 25, 26, 27, 28, 29, 30, 31
122		]
123		val calleeSaveFRegs = List.map C.FPReg [
124		14, 15, 16, 17, 18, 19, 20, 21, 22,
125		23, 24, 25, 26, 27, 28, 29, 30, 31
126		]
127
128		(* C caller-save registers (including argument registers) *)
129		val callerSaveRegs =
130		T.FPR(T.FREG(dblTy, C.FPReg 0)) ::
131		(List.map (fn r => T.GPR(T.REG(wordTy, C.GPReg r))) [2, 11, 12])
132
133	datatype c_arg	val linkReg = T.GPR(T.REG(wordTy, C.lr))
	= ARG of T.rexp
	| FARG of T.fexp
	| ARGS of c_arg list
134
135	val mem = T.Region.memory	(* the parameter area lies just above the linkage area in the caller's frame.
136	val stack = T.Region.memory	* The linkage area is 24 bytes, so the first parameter is at 24(sp).
137		*)
138		val paramAreaOffset = 24
139
140	val maxRegArgs = 6	(* size, padding, and natural alignment for integer types.  Note that the
141	val paramAreaOffset = 68	* padding is based on the parameter-passing description on p. 35 of the
142		* documentation and the alignment is from p. 31.
143		*)
144		fun sizeOf CTy.I_char = {sz = 1, pad = 3, align = 1}
145		| sizeOf CTy.I_short = {sz = 2, pad = 2, align = 2}
146		| sizeOf CTy.I_int = {sz = 4, pad = 0, align = 4}
147		| sizeOf CTy.I_long = {sz = 4, pad = 0, align = 4}
148		| sizeOf CTy.I_long_long = {sz = 8, pad = 0, align = 8}
149
150	fun LI i = T.LI (T.I.fromInt (32, i))	(* sizes of other C types *)
151		val sizeOfPtr = {sz = 4, pad = 0, align = 4}
152
153	val GP = C.GPReg	(* compute the size and alignment information for a struct; tys is the list
154	val FP = C.FPReg	* of member types.  The alignment is what Apple calls the "embedding" alignment.
	fun greg r = GP r
	fun oreg r = GP (r + 8)
	fun freg r = FP r
	fun reg32 r = T.REG (32, r)
	fun freg64 r = T.FREG (64, r)
	val sp = oreg 6
	val spreg = reg32 sp
	fun addli (x, 0) = x
	| addli (x, d) = let
	val d' = T.I.fromInt (32, d)
	in
	case x
	of T.ADD (_, r, T.LI d) =>
	T.ADD (32, r, T.LI (T.I.ADD (32, d, d')))
	| _ => T.ADD (32, x, T.LI d')
	end
	fun argaddr n = addli (spreg, paramAreaOffset + 4*n)
	(* temp location for transfers through memory *)
	val tmpaddr = argaddr 1
	fun roundup (i, a) = a * ((i + a - 1) div a)
	fun intSizeAndAlign Ty.I_char = (1, 1)
	| intSizeAndAlign Ty.I_short = (2, 2)
	| intSizeAndAlign Ty.I_int = (4, 4)
	| intSizeAndAlign Ty.I_long = (4, 4)
	| intSizeAndAlign Ty.I_long_long = (8, 8)
	(* calculate size and alignment for a C type *)
	fun szal (T.C_unsigned ty) = intSizeAndAlign ty
	| szal (T.C_signed ty) = intSizeAndAlign ty
	| szal Ty.C_void = raise Fail "unexpected void type"
	| szal Ty.C_float = (4, 4)
	| szal Ty.C_PTR = (4, 4)
	| szal Ty.C_double = (8, 8)
	| szal (Ty.C_long_double) = (8, 8)
	| szal (Ty.C_ARRAY(t, n)) = let val (s, a) = szal t in (n * s, a) end
	| szal (Ty.C_STRUCT l) = let
	(* FIXME: the rules for structs are more complicated (and they also depend
	* on the alignment mode).  In Power alignment, 8-byte quantites like
	* long long and double are 4-byte aligned in structs.
	*)
	(* i: next free memory address (relative to struct start);
	* a: current total alignment,
	* l: list of struct member types
155	*)	*)
156	fun pack (i, a, []) =	fun sizeOfStruct tys = let
157	(* when we are done with all elements, the total size	(* align the address to the given alignment, which must be a power of 2 *)
158	* of the struct must be padded out to its own alignment	fun alignAddr (addr, align) = let
159	*)	val mask = Word.fromInt(align-1)
160	(roundup (i, a), a)	in
161	| pack (i, a, t :: tl) = let	Word.toIntX(Word.andb(Word.fromInt addr + mask, Word.notb mask))
162	val (ts, ta) = szal t (* size and alignment for member *)	end
163	in	fun sz CTy.C_void = error "unexpected void argument type"
164	(* member must be aligned according to its own	| sz CTy.C_float = {sz = 4, align = 4}
165	* alignment requirement; the next free position	| sz CTy.C_double = {sz = 8, align = 8}
166	* is then at "aligned member-address plus member-size";	| sz CTy.C_long_double = {sz = 8, align = 8}
167	* new total alignment is max of current alignment	| sz (CTy.C_unsigned isz) = let
168	* and member alignment (assuming all alignments are	val {sz, align, ...} = sizeOf isz
169	* powers of 2) *)	in
170	pack (roundup (i, ta) + ts, Int.max (a, ta), tl)	{sz = sz, align = align}
171	end	end
172		| sz (CTy.C_signed isz) = let
173		val {sz, align, ...} = sizeOf isz
174		in
175		{sz = sz, align = align}
176		end
177		| sz CTy.C_PTR = {sz = 4, align = 4}
178		| sz (CTy.C_ARRAY(ty, n)) = let
179		val {sz, align} = sz ty
180		in
181		{sz = n*sz, align = align}
182		end
183		| sz (CTy.C_STRUCT tys) = ssz tys
184		and ssz [] = {sz = 0, align = 4}
185		| ssz (first::rest) = let
186		fun f ([], maxAlign, offset) =
187		{sz = alignAddr(offset, maxAlign), align = maxAlign}
188		| f (ty::tys, maxAlign, offset) = let
189		val {sz, align} = sz ty
190		val align = Int.min(align, 4)
191		val offset = alignAddr(offset, align)
192		in
193		f (tys, Int.max(maxAlign, align), offset+sz)
194		end
195		val {sz, align} = sz first
196		in
197		f (rest, align, sz)
198		end
199		in
200		#sz(ssz tys)
201		end
202
203		(* compute the layout of a C call's arguments *)
204		fun layout {conv, retTy, paramTys} = let
205		fun gprRes isz = (case #sz(sizeOf isz)
206		of 8 => raise Fail "register pairs not yet supported"
207		| _ => SOME resRegLoc
208		(* end case *))
209		val (resLoc, argGPRs, structRet) = (case retTy
210		of CTy.C_void => (NONE, argGPRs, NONE)
211		| CTy.C_float => (SOME(FReg(fltTy, resFPR, NONE)), argGPRs, NONE)
212		| CTy.C_double => (SOME(FReg(dblTy, resFPR, NONE)), argGPRs, NONE)
213		| CTy.C_long_double => (SOME(FReg(dblTy, resFPR, NONE)), argGPRs, NONE)
214		| CTy.C_unsigned isz => (gprRes isz, argGPRs, NONE)
215		| CTy.C_signed isz => (gprRes isz, argGPRs, NONE)
216		| CTy.C_PTR => (SOME resRegLoc, argGPRs, NONE)
217		| CTy.C_ARRAY _ => error "array return type"
218		| CTy.C_STRUCT s => let
219		val sz = sizeOfStruct s
220	in	in
221	pack (0, 1, l)	(* Note that this is a place where the MacOS X and Linux ABIs differ.
222	end	* In Linux, GPR3/GPR4 are used to return composite values of 8 bytes.
	fun genCall { name, proto, paramAlloc, structRet, saveRestoreDedicated,
	callComment, args } = let
	val { conv, retTy, paramTys } = proto
	val _ = case conv of
	("" | "ccall") => ()
	| _ => error (concat ["unknown calling convention \"",
	String.toString conv, "\""])
	val res_szal =
	case retTy of
	(Ty.C_long_double | Ty.C_STRUCT _) => SOME (szal retTy)
	| _ => NONE
	val nargwords = let
	fun loop ([], n) = n
	| loop (t :: tl, n) =
	loop (tl, (case t of
	(Ty.C_double | Ty.C_signed Ty.I_long_long |
	Ty.C_unsigned Ty.I_long_long) => 2
	| _ => 1) + n)
	in
	loop (paramTys, 0)
	end
	val regargwords = Int.min (nargwords, maxRegArgs)
	val stackargwords = Int.max (nargwords, maxRegArgs) - maxRegArgs
	val stackargsstart = paramAreaOffset + 4 * maxRegArgs
	val scratchstart = stackargsstart + 4 * stackargwords
	(* Copy struct or part thereof to designated area on the stack.
	* An already properly aligned address (relative to %sp) is
	* in to_off. *)
	fun struct_copy (sz, al, ARG a, t, to_off, cpc) =
	(* Two main cases here:
	*   1. t is C_STRUCT _: in this case "a" computes the address
	*      of the struct to be copied.
	*   2. t is some other non-floating type; "a" computes the
	*      the corresponding value (i.e., not its address).
223	*)	*)
224	let fun ldst ty =	if (sz > 4)
225	T.STORE (ty, addli (spreg, to_off), a, stack) :: cpc	then (SOME resRegLoc, List.tl argGPRs, SOME{szb=sz, align=4})
226	in	else (SOME resRegLoc, argGPRs, NONE)
227	case t of	end
228	(Ty.C_void | Ty.C_PTR |	(* end case *))
229	Ty.C_signed (Ty.I_int | Ty.I_long) |	fun assign ([], offset, _, _, layout) = List.rev layout
230	Ty.C_unsigned (Ty.I_int | Ty.I_long)) => ldst 32	| assign (ty::tys, offset, availGPRs, availFPRs, layout) = (
231	| (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) => ldst 8	case ty
232	| (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>	of CTy.C_void => error "unexpected void tyument type"
233	ldst 16	| CTy.C_float => (case (availGPRs, availFPRs)
234	| (Ty.C_signed Ty.I_long_long |	of (_::gprs, fpr::fprs) =>
235	Ty.C_unsigned Ty.I_long_long) => ldst 64	assign (tys, offset+4, gprs, fprs, FReg(fltTy, fpr, SOME offset)::layout)
236	| (Ty.C_ARRAY _) =>	| ([], fpr::fprs) =>
237	error "ARRAY within gather/scatter struct"	assign (tys, offset+4, [], fprs, FReg(fltTy, fpr, SOME offset)::layout)
238	| (Ty.C_STRUCT _) =>	| ([], []) =>
239	(* Here we have to do the equivalent of a "memcpy". *)	assign (tys, offset+4, [], [], FStk(fltTy, offset)::layout)
240	let val from = a (* argument is address of struct *)	(* end case *))
241	fun cp (ty, incr) = let	| CTy.C_double =>
242	fun load_from from_off =	assignFPR (tys, offset, availGPRs, availFPRs, layout)
243	T.LOAD (32, addli (from, from_off), mem)	| CTy.C_long_double =>
244	(* from_off is relative to from,	assignFPR (tys, offset, availGPRs, availFPRs, layout)
245	* to_off is relative to %sp *)	| CTy.C_unsigned isz =>
246	fun loop (i, from_off, to_off, cpc) =	assignGPR(sizeOf isz, tys, offset, availGPRs, availFPRs, layout)
247	if i <= 0 then cpc	| CTy.C_signed isz =>
248	else loop (i - incr,	assignGPR(sizeOf isz, tys, offset, availGPRs, availFPRs, layout)
249	from_off + incr, to_off + incr,	| CTy.C_PTR =>
250	T.STORE (ty, addli (spreg, to_off),	assignGPR(sizeOfPtr, tys, offset, availGPRs, availFPRs, layout)
251	load_from from_off,	| CTy.C_ARRAY _ =>
252	stack)	assignGPR(sizeOfPtr, tys, offset, availGPRs, availFPRs, layout)
253	:: cpc)	| CTy.C_STRUCT tys' => raise Fail "struct arguments not supported yet"
254	in	(* end case *))
255	loop (sz, 0, to_off, cpc)	(* assign a GP register and memory for an integer/pointer argument. *)
256	end	and assignGPR ({sz, pad, ...}, args, offset, availGPRs, availFPRs, layout) = let
257	in	val (loc, availGPRs) = (case (sz, availGPRs)
258	case al of	of (8, _) => raise Fail "register pairs not yet supported"
259	1 => cp (8, 1)	| (_, []) => (Stk(wordTy, offset), [])
260	| 2 => cp (16, 2)	| (_, r1::rs) => (Reg(wordTy, r1, SOME offset), rs)
261	| _ => (* 4 or more *) cp (32, 4)	(* end case *))
262	end	val offset = offset + IntInf.fromInt(sz + pad)
263	| (Ty.C_float | Ty.C_double | Ty.C_long_double) =>	in
264	error "floating point type does not match ARG"	assign (args, offset, availGPRs, availFPRs, loc::layout)
265	end	end
266	| struct_copy (_, _, ARGS args, Ty.C_STRUCT tl, to_off, cpc) =	(* assign a FP register and memory/GPRs for double-precision argument. *)
267	(* gather/scatter case *)	and assignFPR (args, offset, availGPRs, availFPRs, layout) = let
268	let fun loop ([], [], _, cpc) = cpc	fun continue (availGPRs, availFPRs, loc) =
269	| loop (t :: tl, a :: al, to_off, cpc) = let	assign (args, offset+8, availGPRs, availFPRs, loc::layout)
270	val (tsz, tal) = szal t	fun freg fpr = FReg(dblTy, fpr, SOME offset)
271	val to_off' = roundup (to_off, tal)	in
272	val cpc' = struct_copy (tsz, tal, a, t, to_off', cpc)	case (availGPRs, availFPRs)
273	in	of (_::_::gprs, fpr::fprs) => continue (gprs, fprs, freg fpr)
274	loop (tl, al, to_off' + tsz, cpc')	| (_, fpr::fprs) => continue ([], fprs, freg fpr)
275	end	| ([], []) => continue ([], [], FStk(dblTy, offset))
276	| loop _ =	(* end case *)
277	error "number of types does not match number of arguments"	end
278	in	in {
279	loop (tl, args, to_off, cpc)	argLocs = assign (paramTys, 0, argGPRs, argFPRs, []),
280	end	resLoc = resLoc,
281	| struct_copy (_, _, ARGS _, _, _, _) =	structRetLoc = structRet
282	error "gather/scatter for non-struct"	} end
	| struct_copy (sz, al, FARG a, t, to_off, cpc) =
	let fun fldst ty =
	T.FSTORE (ty, addli (spreg, to_off), a, stack) :: cpc
	in
	case t of
	Ty.C_float => fldst 32
	| Ty.C_double => fldst 64
	| Ty.C_long_double => fldst 128
	| _ => error "non-floating-point type does not match FARG"
	end
	val (stackdelta, argsetupcode, copycode) = let
	fun loop ([], [], _, ss, asc, cpc) =
	(roundup (Int.max (0, ss - stackargsstart), 8), asc, cpc)
	| loop (t :: tl, a :: al, n, ss, asc, cpc) = let
	fun wordassign a =
	if n < 6 then T.MV (32, oreg n, a)
	else T.STORE (32, argaddr n, a, stack)
	fun wordarg (a, cpc, ss) =
	loop (tl, al, n + 1, ss, wordassign a :: asc, cpc)
	fun dwordmemarg (addr, region, tmpstore) = let
	fun toreg (n, addr) =
	T.MV (32, oreg n, T.LOAD (32, addr, region))
	fun tomem (n, addr) =
	T.STORE (32,
	argaddr n,
	T.LOAD (32, addr, region),
	stack)
	fun toany (n, addr) =
	if n < 6 then toreg (n, addr) else tomem (n, addr)
	in
	(* if n < 6 andalso n div 2 = 0 then
	*     use ldd here once MLRISC gets its usage right
	* else
	*   ... *)
	loop (tl, al, n+2, ss,
	tmpstore @
	toany (n, addr)
	:: toany (n+1, addli (addr, 4))
	:: asc,
	cpc)
	end
	fun dwordarg mkstore =
	if n > 6 andalso n div 2 = 1 then
	(* 8-byte aligned memory *)
	loop (tl, al, n+2, ss,
	mkstore (argaddr n) :: asc,
	cpc)
	else dwordmemarg (tmpaddr, stack, [mkstore tmpaddr])
	in
	case (t, a) of
	((Ty.C_void | Ty.C_PTR | Ty.C_ARRAY _ |
	Ty.C_unsigned (Ty.I_int | Ty.I_long) |
	Ty.C_signed (Ty.I_int | Ty.I_long)),
	ARG a) => wordarg (a, cpc, ss)
	| (Ty.C_signed Ty.I_char, ARG a) =>
	wordarg (T.SX (32, 8, a), cpc, ss)
	| (Ty.C_unsigned Ty.I_char, ARG a) =>
	wordarg (T.ZX (32, 8, a), cpc, ss)
	| (Ty.C_signed Ty.I_short, ARG a) =>
	wordarg (T.SX (32, 16, a), cpc, ss)
	| (Ty.C_unsigned Ty.I_short, ARG a) =>
	wordarg (T.ZX (32, 16, a), cpc, ss)
	| ((Ty.C_signed Ty.I_long_long |
	Ty.C_unsigned Ty.I_long_long), ARG a) =>
	(case a of
	T.LOAD (_, addr, region) =>
	dwordmemarg (addr, region, [])
	| _ => dwordarg (fn addr =>
	T.STORE (64, addr, a, stack)))
	| (Ty.C_float, FARG a) =>
	(* we use the stack region reserved for storing
	* %o0-%o5 as temporary storage for transferring
	* floating point values *)
	(case a of
	T.FLOAD (_, addr, region) =>
	wordarg (T.LOAD (32, addr, region), cpc, ss)
	| _ =>
	if n < 6 then let
	val ld = T.MV (32, oreg n,
	T.LOAD (32, tmpaddr, stack))
	val cp = T.FSTORE (32, tmpaddr, a, stack)
	in
	loop (tl, al, n + 1, ss, cp :: ld :: asc, cpc)
	end
	else loop (tl, al, n + 1, ss,
	T.FSTORE (32, argaddr n, a, stack)
	:: asc,
	cpc))
	| (Ty.C_double, FARG a) =>
	(case a of
	T.FLOAD (_, addr, region) =>
	dwordmemarg (addr, region, [])
	| _ => dwordarg (fn addr =>
	T.FSTORE (64, addr, a, stack)))
	| (Ty.C_long_double, FARG a) => let
	(* Copy 128-bit floating point value (16 bytes)
	* into scratch space (aligned at 8-byte boundary).
	* The address of the scratch copy is then
	* passed as a regular 32-bit argument. *)
	val ss' = roundup (ss, 8)
	val ssaddr = addli (spreg, ss')
	in
	wordarg (ssaddr,
	T.FSTORE (128, ssaddr, a, stack) :: cpc,
	ss' + 16)
	end
	| (t as Ty.C_STRUCT _, a) => let
	(* copy entire struct into scratch space
	* (aligned according to struct's alignment
	* requirements).  The address of the scratch
	* copy is then passed as a regular 32-bit
	* argument. *)
	val (sz, al) = szal t
	val ss' = roundup (ss, al)
	val ssaddr = addli (spreg, ss')
	val cpc' = struct_copy (sz, al, a, t, ss', cpc)
	in
	wordarg (ssaddr, cpc', ss' + sz)
	end
	| _ => error "argument/type mismatch"
	end
	| loop _ = error "wrong number of arguments"
	in
	loop (paramTys, args, 0, scratchstart, [], [])
	end
	val (defs, uses) = let
	val gp = T.GPR o reg32
	val fp = T.FPR o freg64
	val g_regs = map (gp o greg) [1, 2, 3, 4, 5, 6, 7]
	val a_regs = map (gp o oreg) [0, 1, 2, 3, 4, 5]
	val l_reg = gp (oreg 7)
	val f_regs = map (fp o freg)
	[0, 2, 4, 6, 8, 10, 12, 14,
	16, 18, 20, 22, 24, 26, 28, 30]
	(* a call instruction defines all caller-save registers:
	*   - %g1 - %g7
	*   - %o0 - %o5 (argument registers)
	*   - %o7       (link register)
	*   - all fp registers *)
	val defs = g_regs @ a_regs @ l_reg :: f_regs
	(* A call instruction "uses" just the argument registers. *)
	val uses = List.take (a_regs, regargwords)
	in
	(defs, uses)
	end
	val result =
	case retTy of
	Ty.C_float => [T.FPR (T.FREG (32, FP 0))]
	| Ty.C_double => [T.FPR (T.FREG (64, FP 0))] (* %f0/%f1 *)
	| Ty.C_long_double => []
	| Ty.C_STRUCT _ => []
	| Ty.C_ARRAY _ => error "array return type"
	| (Ty.C_PTR | Ty.C_void |
	Ty.C_signed (Ty.I_int | Ty.I_long) |
	Ty.C_unsigned (Ty.I_int | Ty.I_long)) =>
	[T.GPR (T.REG (32, oreg 0))]
	| (Ty.C_signed Ty.I_char | Ty.C_unsigned Ty.I_char) =>
	[T.GPR (T.REG (8, oreg 0))]
	| (Ty.C_signed Ty.I_short | Ty.C_unsigned Ty.I_short) =>
	[T.GPR (T.REG (16, oreg 0))]
	| (Ty.C_signed Ty.I_long_long | Ty.C_unsigned Ty.I_long_long) =>
	[T.GPR (T.REG (64, oreg 0))]
283
284	val { save, restore } = saveRestoreDedicated defs	datatype c_arg
285		= ARG of T.rexp
286		| FARG of T.fexp
287		| ARGS of c_arg list
288
289	val (sretsetup, srethandshake) =	val memRg = T.Region.memory
290	case res_szal of	val stkRg = T.Region.memory
	NONE => ([], [])
	| SOME (sz, al) => let
	val addr = structRet { szb = sz, align = al }
	in
	([T.STORE (32, addli (spreg, 64), addr, stack)],
	[T.EXT (ix (IX.UNIMP sz))])
	end
291
292	val call = T.CALL { funct = name, targets = [],	(* SP-based address of parameter at given offset *)
293		fun paramAddr off =
294		T.ADD(wordTy, spReg, T.LI(off + IntInf.fromInt paramAreaOffset))
295
296		fun genCall {
297		name, proto, paramAlloc, structRet, saveRestoreDedicated,
298		callComment, args
299		} = let
300		val {conv, retTy, paramTys} = proto
301		val {argLocs, resLoc, structRetLoc} = layout proto
302		(* generate code to assign the arguments to their locations *)
303		fun assignArgs ([], [], stms) = stms
304		| assignArgs (Reg(ty, r, _) :: locs, ARG exp :: args, stms) =
305		assignArgs (locs, args, T.MV(ty, r, exp) :: stms)
306		| assignArgs (Stk(ty, off) :: locs, ARG exp :: args, stms) =
307		assignArgs (locs, args, T.STORE(ty, paramAddr off, exp, stkRg) :: stms)
308		| assignArgs (FReg(ty, r, _) :: locs, FARG fexp :: args, stms) =
309		assignArgs (locs, args, T.FMV(ty, r, fexp) :: stms)
310		| assignArgs (FStk(ty, off) :: locs, FARG fexp :: args, stms) =
311		assignArgs (locs, args, T.FSTORE(ty, paramAddr off, fexp, stkRg) :: stms)
312		| assignArgs ((Args locs') :: locs, (ARGS args') :: args, stms) =
313		assignArgs (locs, args, assignArgs(locs', args', stms))
314		| assignArgs _ = error "argument/formal mismatch"
315		val argSetupCode = List.rev(assignArgs(argLocs, args, []))
316		(* convert the result location to an MLRISC expression list *)
317		val result = (case resLoc
318		of NONE => []
319		| SOME(Reg(ty, r, _)) => [T.GPR(T.REG(ty, r))]
320		| SOME(FReg(ty, r, _)) => [T.FPR(T.FREG(ty, r))]
321		| SOME _ => raise Fail "bogus result location"
322		(* end case *))
323		(* make struct return-area setup (if necessary) *)
324		val setupStructRet = (case structRetLoc
325		of NONE => []
326		| SOME loc => let
327		val structAddr = structRet loc
328		in
329		[T.MV(wordTy, resGPR, structAddr)]
330		end
331		(* end case *))
332		(* determine the registers used and defined by this call *)
333		val (uses, defs) = let
334		val locs = (case resLoc
335		of NONE => argLocs
336		| SOME loc => loc::argLocs
337		(* end case *))
338		(* get the list of registers used to pass arguments and results *)
339		fun addArgReg (Reg(ty, r, _)::locs, argRegs) =
340		addArgReg (locs, T.GPR(T.REG(ty, r))::argRegs)
341		| addArgReg (FReg(ty, r, _)::locs, argRegs) =
342		addArgReg (locs, T.FPR(T.FREG(ty, r))::argRegs)
343		| addArgReg ((Args locs')::locs, argRegs) =
344		addArgReg (locs, addArgReg(locs', argRegs))
345		| addArgReg (_::locs, argRegs) = addArgReg(locs, argRegs)
346		| addArgReg ([], argRegs) = rev argRegs
347		val argRegs = addArgReg (locs, [])
348		in
349		(argRegs, linkReg :: callerSaveRegs)
350		end
351		(* the actual call instruction *)
352		val callStm = T.CALL {
353		funct = name, targets = [],
354	defs = defs, uses = uses,	defs = defs, uses = uses,
355	region = mem, pops = 0 }	region = memRg, pops = 0
356		}
357	val call =	(* annotate, if necessary *)
358	case callComment of	val callStm = (case callComment
359	NONE => call	of NONE => callStm
360	| SOME c =>	| SOME c => T.ANNOTATION(callStm, #create MLRiscAnnotations.COMMENT c)
361	T.ANNOTATION (call, #create MLRiscAnnotations.COMMENT c)	(* end case *))
362		(* take care of dedicated client registers *)
363	val (sp_sub, sp_add) =	val {save, restore} = saveRestoreDedicated defs
364	if stackdelta = 0 then ([], []) else	val callseq = List.concat [
365	if paramAlloc { szb = stackdelta, align = 4 } then ([], [])	setupStructRet,
366	else ([T.MV (32, sp, T.SUB (32, spreg, LI stackdelta))],	argSetupCode,
	[T.MV (32, sp, addli (spreg, stackdelta))])
	val callseq =
	List.concat [sp_sub,
	copycode,
	argsetupcode,
	sretsetup,
367	save,	save,
368	[call],	[callStm],
369	srethandshake,	restore
370	restore,	]
371	sp_add]	in
372		(* check calling convention *)
373	in	case conv
374		of ("" | "ccall") => ()
375		| _ => error (concat [
376		"unknown calling convention \"",
377		String.toString conv, "\""
378		])
379		(* end case *);
380	{ callseq = callseq, result = result }	{ callseq = callseq, result = result }
381	end	end
382
383	end	end

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.1438   changed lines   Added in v.1532

---

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