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 /MLRISC/trunk/staged-allocation/test-staged-allocation-main.sml
ViewVC logotype

Annotation of /MLRISC/trunk/staged-allocation/test-staged-allocation-main.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3068 - (view) (download)

1 : mrainey 2990 (* test-staged-allocation-main.sml
2 :     *
3 :     * This module tests C calls for staged allocation. We generate tests for a variety
4 :     * of calls. To verify the test, we generate a dummy C function that prints out its
5 :     * parameters in order.
6 :     *
7 : mrainey 2992 * The example code below passes arguments x and y to the MLRISC-generated C call. The output
8 : mrainey 2997 * of main.c and sanity.c should be identical.
9 : mrainey 2990
10 : mrainey 2992 /* glue.c */
11 :     #define MAX_SZ 16
12 : mrainey 2990
13 : mrainey 2992 int target (int x, float y)
14 : mrainey 2990 {
15 :     printf("%d %f", x, y);
16 : mrainey 2992 return 23432;
17 : mrainey 2990 }
18 :    
19 :     void glueCode()
20 :     {
21 :     void* arr0[4096];
22 :     void** arr = arr0;
23 :     /* initialize arguments */
24 :     int x = 23423;
25 :     memcpy(arr, &x, sizeof(int));
26 : mrainey 2992 arr += MAX_SZ;
27 :     float y = 1024.013f;
28 : mrainey 2990 memcpy(arr, &y, sizeof(float));
29 : mrainey 2992 arr += MAX_SZ;
30 : mrainey 2990 /* call into the MLRISC glue code that will make the C call */
31 : mrainey 2992 int tmp = mlriscGlue(arr0);
32 :     printf("%d", tmp);
33 : mrainey 2990 }
34 :    
35 : mrainey 2997 /* main.c */
36 : mrainey 2992 int main ()
37 :     {
38 : mrainey 2990 glueCode();
39 :     return 0;
40 :     }
41 :    
42 : mrainey 2992 /* sanity.c */
43 :     int main ()
44 :     {
45 : mrainey 2997 int x = 23432;
46 :     float y = 1024.013f;
47 :     int tmp = target(x, y);
48 :     printf ("%d", tmp);
49 : mrainey 2992 return 0;
50 :     }
51 :    
52 :     * We also generate the mlriscGlue code in MLRISC. This code grabs the arguments from
53 :     * arr0 and then passes them to target using Staged Allocation.
54 : mrainey 2990 *
55 :     *)
56 :    
57 :     structure Main =
58 :     struct
59 :    
60 :     structure CTy = CTypes
61 : mrainey 3049 structure Test = TestSA
62 : mrainey 2990
63 : mrainey 2992 val retValVar = "retVal"
64 : mrainey 2990
65 : mrainey 3037 fun zip3 (ls1, ls2, ls3) = let
66 :     fun f ([], _, _, xs) = List.rev xs
67 :     | f (x1 ::xs1, x2::xs2, x3::xs3, xs) = f(xs1, xs2, xs3, (x1, x2, x3) :: xs)
68 :     in
69 :     f(ls1, ls2, ls3, [])
70 :     end
71 : mrainey 2993
72 : mrainey 2990 datatype c_argument =
73 :     INT of int
74 : mrainey 3010 | SHORT of int
75 :     | CHAR of int
76 : mrainey 2990 | FLOAT of real
77 : mrainey 2992 | DOUBLE of real
78 : mrainey 2990 | POINTER of int
79 : mrainey 2995 | STRUCT of c_argument list
80 : mrainey 2990
81 : mrainey 2995 fun flattenArg cArg = (case cArg
82 :     of STRUCT args => List.concat (List.map flattenArg args)
83 :     | cArg => [cArg])
84 :    
85 : mrainey 2990 fun cArgToString (cArg) = (case cArg
86 :     of INT i => Int.toString i
87 : mrainey 3010 | SHORT i => Int.toString i
88 :     | CHAR c => Int.toString c
89 : mrainey 2992 | FLOAT f => Real.toString f^"f"
90 :     | DOUBLE f => Real.toString f
91 :     | POINTER p => "(void*)0x"^Int.fmt StringCvt.HEX p
92 : mrainey 2995 | STRUCT args => "{"^String.concatWith ", " (List.map cArgToString args)^"}"
93 : mrainey 2990 (* end case *))
94 :    
95 :     fun tyToFormatString (ty) = (case ty
96 : mrainey 3010 of CTy.C_signed CTy.I_char => "%c"
97 :     | CTy.C_unsigned CTy.I_char => "%c"
98 :     | CTy.C_unsigned _ => "%u"
99 : mrainey 2990 | CTy.C_signed _ => "%d"
100 :     | CTy.C_float => "%f"
101 :     | CTy.C_double => "%f"
102 :     | CTy.C_PTR => "%p"
103 : mrainey 2995 | CTy.C_STRUCT cTys => String.concatWith " " (List.map tyToFormatString cTys)
104 : mrainey 2990 (* end case *))
105 :    
106 : mrainey 2995 fun cTyToName cTy = (case cTy
107 : mrainey 3010 of CTy.C_unsigned CTy.I_int => "u"
108 :     | CTy.C_signed CTy.I_int => "i"
109 :     | CTy.C_signed CTy.I_char => "c"
110 :     | CTy.C_unsigned CTy.I_char => "c"
111 :     | CTy.C_signed CTy.I_short => "i"
112 :     | CTy.C_unsigned CTy.I_short => "u"
113 : mrainey 2995 | CTy.C_float => "f"
114 :     | CTy.C_double => "d"
115 :     | CTy.C_PTR => "vs"
116 :     | CTy.C_STRUCT cTys => "s"^String.concat (List.map cTyToName cTys)
117 :     (* end case *))
118 :    
119 : mrainey 2990 fun cTyToString (ty) = (case ty
120 : mrainey 3010 of CTy.C_unsigned CTy.I_int => "unsigned int"
121 :     | CTy.C_signed CTy.I_int => "int"
122 :     | CTy.C_unsigned CTy.I_char => "char"
123 :     | CTy.C_signed CTy.I_char => "char"
124 :     | CTy.C_signed CTy.I_short => "short"
125 :     | CTy.C_unsigned CTy.I_short => "short"
126 : mrainey 2990 | CTy.C_float => "float"
127 :     | CTy.C_double => "double"
128 :     | CTy.C_PTR => "void*"
129 :     | CTy.C_void => "void"
130 : mrainey 2995 | CTy.C_STRUCT cTys => "struct "^cTyToName ty
131 : mrainey 2990 (* end case *))
132 :    
133 : mrainey 2995 val i = ref 0
134 :     fun freshName () = (
135 :     i := (!i) + 1;
136 :     "x"^Int.toString (!i))
137 :    
138 :     fun cTyDecl' cTy = (case cTy
139 :     of CTy.C_STRUCT cTys => cTyToString cTy^"{ "^(String.concatWith " " (List.map cTyDecl' cTys))^"}"^freshName()^";"
140 :     | cTy => cTyToString cTy^" "^freshName()^";"
141 :     (* end case *))
142 :    
143 :     fun cTyDecl cTy = let
144 :     val td = cTyDecl' cTy
145 :     in
146 :     i := 0;
147 :     td
148 :     end
149 :    
150 :     fun cTyNames' prefix (cTy) = (case cTy
151 :     of CTy.C_STRUCT cTys => List.concat (List.map (cTyNames' (prefix^"."^freshName())) cTys)
152 :     | cTy => [prefix^"."^freshName()]
153 :     (* end case *))
154 :    
155 :     fun cTyNames prefix cTy = let
156 :     val td = (case cTy
157 :     of CTy.C_STRUCT cTys => List.concat (List.map (cTyNames' prefix) cTys)
158 :     | cTy => [prefix])
159 :     in
160 :     i := 0;
161 :     td
162 :     end
163 :    
164 : mrainey 3010 fun genParamName i =
165 :     " a"^Int.toString i
166 : mrainey 2990
167 : mrainey 3010 (* generate parameter names for a list of types *)
168 :     fun genParamNames tys =
169 :     List.rev(#2 (List.foldl (fn (ty, (i, params)) => (i+1, genParamName(i) :: params)) (0, []) tys))
170 : mrainey 2997
171 : mrainey 3010 (* generate formal parameters for a list of types and variables *)
172 :     fun genFormals (paramTys, vars) = let
173 :     fun f (ty, name) = cTyToString ty^name
174 :     in
175 :     List.map f (ListPair.zip (paramTys, vars))
176 :     end
177 : mrainey 2997
178 : mrainey 3010 fun genTargetPrintfArgs (vars, paramTys) = let
179 :     fun f (prefix, ty) = cTyNames prefix ty
180 :     in
181 :     List.concat (ListPair.map f (vars, paramTys))
182 :     end
183 : mrainey 2997
184 : mrainey 2992 fun genPrintf (formatString, args) =
185 : mrainey 3010 "printf("^String.concatWith "," (formatString :: args)^");"
186 : mrainey 2992
187 :     fun genFormatString (elts) =
188 :     "\"" ^ String.concatWith " " elts ^ "\\n\""
189 :    
190 : mrainey 3037 fun fmtVar (arg, ty) = arg^"="^tyToFormatString ty^"\\n"
191 :    
192 : mrainey 3010 (* construct a format string printing the parameters of a proto *)
193 : mrainey 3037 fun protoToFormatString ({conv, retTy, paramTys}, args) =
194 :     genFormatString (ListPair.map fmtVar (args, paramTys))
195 : mrainey 2990
196 : mrainey 2997 fun protoToPrintf (proto, args) = genPrintf(protoToFormatString(proto, args), args)
197 : mrainey 2992
198 : mrainey 2990 (* generate a dummy target function that prints its parameters *)
199 : mrainey 2992 fun targetFun (targetName, proto as {conv, retTy, paramTys}, retVal) = let
200 : mrainey 2997 val vars = genParamNames paramTys
201 : mrainey 3010 val params = genFormals(paramTys, vars)
202 : mrainey 2997 val printfArgs = genTargetPrintfArgs(vars, paramTys)
203 : mrainey 2990 in
204 :     cTyToString retTy ^ " " ^ targetName ^ "(" ^ (String.concatWith ", " params) ^ ")" ^
205 :     "{" ^
206 : mrainey 2997 protoToPrintf(proto, printfArgs) ^
207 : mrainey 2992 "return "^(String.concat (List.map cArgToString retVal))^";"^
208 : mrainey 2990 "}"
209 :     end
210 :    
211 : mrainey 2997 fun genMLRISCGlueHdr (mlriscGlue, proto as {conv, retTy, paramTys}) =
212 :     cTyToString retTy ^ " " ^ mlriscGlue ^ "(void* arr0);"
213 : mrainey 2992
214 : mrainey 2997 fun genAssignArg (ty, var, arg) = cTyToString(ty)^" "^var^" = "^cArgToString(arg)^";"
215 :    
216 :     (* generate C code that initializes an argument in arr0 *)
217 :     fun genInitArr0 (ty, arg) =
218 : mrainey 2992 String.concatWith "\t" [
219 :     "{",
220 : mrainey 2997 genAssignArg(ty, "tmp", arg),
221 : mrainey 2992 "memcpy(arr, &tmp, sizeof("^cTyToString(ty)^"));",
222 :     "arr += MAX_SZ;",
223 :     "}\n"
224 :     ]
225 : mrainey 2990
226 :     (* generate C code that calls the MLRISC-generated function *)
227 :     fun genCGlueCode (mlriscGlue, proto as {conv, retTy, paramTys}, args) = let
228 : mrainey 2997 val stms = List.rev (ListPair.map genInitArr0 (paramTys, args))
229 : mrainey 2992 val glueCall = if retTy <> CTy.C_void
230 :     then cTyToString retTy ^ " " ^retValVar^" = " ^ mlriscGlue^"(arr0);\n\t"^
231 :     genPrintf(genFormatString([tyToFormatString retTy]), [retValVar])
232 :     else mlriscGlue^"(arr0);"
233 : mrainey 2990 in
234 :     String.concatWith "\n\t" [
235 :     "void glueCode(){",
236 :     (* initialize arguments *)
237 :     "void* arr0[4096];",
238 :     "void** arr = arr0;",
239 :     String.concatWith "\t " (List.rev stms),
240 : mrainey 2992 glueCall,
241 : mrainey 2990 "}"
242 :     ]
243 :     end
244 :    
245 : mrainey 2997 (* generate C code that calls the MLRISC-generated function *)
246 :     fun genTestCode (proto as {conv, retTy, paramTys}, args) = let
247 :     val paramNames = genParamNames paramTys
248 :     val stms = List.map genAssignArg (zip3(paramTys, paramNames, args))
249 :     val callTarget = "target("^String.concatWith ", " paramNames^");"
250 :     val glueCall = if retTy <> CTy.C_void
251 :     then cTyToString retTy ^ " " ^retValVar^" = " ^ callTarget^"\n\t"^
252 :     genPrintf(genFormatString([tyToFormatString retTy]), [retValVar])
253 :     else callTarget
254 :     in
255 :     String.concatWith "\n\t" [
256 :     "void testCode(){",
257 :     String.concatWith "\t " (List.rev stms),
258 :     glueCall,
259 :     "}"
260 :     ]
261 :     end
262 :    
263 : mrainey 2992 val cIncludes = String.concatWith "\n" [
264 :     "#include <stdio.h>",
265 :     "#include <stdlib.h>",
266 :     "#include <string.h>\n"
267 :     ]
268 :    
269 : mrainey 2997 fun isStruct (CTy.C_STRUCT _) = true
270 :     | isStruct _ = false
271 :    
272 : mrainey 3037 (* number of bytes to represent ty *)
273 :     fun szOfTy ty = if ty = CTy.C_void then 0 else #sz (CSizes.sizeOfTy ty)
274 : mrainey 2997
275 : mrainey 3037 (* returns the maximum size type for a C prototype *)
276 :     fun maxSzOfProto ({conv, paramTys, retTy}) =
277 :     List.foldl Int.max 0 (List.map szOfTy (retTy :: paramTys))
278 :    
279 : mrainey 2992 fun genGlue (target, mlriscGlue, proto, args, retVal) = String.concatWith "\n" [
280 :     cIncludes,
281 : mrainey 3010 "#define MAX_SZ "^Int.toString(Int.max(1,(maxSzOfProto proto) div wordSzB)),
282 : mrainey 2997 (* tyep declarations for structs *)
283 :     String.concatWith "\n" (List.map cTyDecl (List.filter isStruct (#paramTys proto))),
284 :     (* C prototype for the MLRISC assembly stub *)
285 : mrainey 2992 genMLRISCGlueHdr(mlriscGlue, proto),
286 : mrainey 2997 (* target function *)
287 : mrainey 2992 targetFun(target, proto, retVal),
288 : mrainey 2997 (* C glue code for calling into the MLRISC assembly stub *)
289 :     genCGlueCode(mlriscGlue, proto, args),
290 :     (* C test code that directly calls the target function *)
291 :     genTestCode(proto, args)
292 : mrainey 2990 ]
293 :    
294 :     fun genCMain () = "int main () { glueCode(); return 0; }"
295 : mrainey 2992
296 : mrainey 2997 fun genSanityCheck (proto, args, retVal) = "int main () { testCode(); return 0; }"
297 : mrainey 2992
298 : mrainey 3037 fun offset szB arr0 i = T.ADD(wordTy, arr0, T.LI (T.I.fromInt (wordTy, i*szB)))
299 : mrainey 2995
300 : mrainey 3037 (* generate the ith argument to the MLRISC code *)
301 :     fun genGlueArg szB arr0 (ty, (i, args)) = (i+1,
302 : mrainey 2992 (case ty
303 : mrainey 3037 of CTy.C_signed CTy.I_int => CCalls.ARG (T.LOAD(32, offset szB arr0 i, ()))
304 :     | CTy.C_unsigned CTy.I_int => CCalls.ARG (T.LOAD(32, offset szB arr0 i, ()))
305 :     | CTy.C_unsigned CTy.I_char => CCalls.ARG (T.LOAD(8, offset szB arr0 i, ()))
306 :     | CTy.C_signed CTy.I_char => CCalls.ARG (T.LOAD(8, offset szB arr0 i, ()))
307 :     | CTy.C_PTR => CCalls.ARG (T.LOAD(wordTy, offset szB arr0 i, ()))
308 :     | CTy.C_STRUCT _ => CCalls.ARG (T.LOAD(wordTy, offset szB arr0 i, ()))
309 :     | CTy.C_float => CCalls.FARG (T.FLOAD(32, offset szB arr0 i, ()))
310 :     | CTy.C_double => CCalls.FARG (T.FLOAD(64, offset szB arr0 i, ()))
311 : mrainey 2992 (* end case *)) :: args)
312 :    
313 :     val rand = Random.rand (0, 255)
314 : mrainey 2995
315 : mrainey 3010 fun genRandArg ty = (case ty
316 : mrainey 2992 of CTy.C_float => FLOAT (Random.randReal(rand))
317 :     | CTy.C_double => DOUBLE(Random.randReal(rand))
318 : mrainey 3010 | CTy.C_unsigned CTy.I_int => INT (Random.randNat(rand))
319 :     | CTy.C_signed CTy.I_int => INT (Random.randNat(rand))
320 :     | CTy.C_signed CTy.I_char => CHAR (Random.randNat rand mod 255)
321 : mrainey 2992 | CTy.C_PTR => POINTER(Random.randNat(rand))
322 : mrainey 2995 | CTy.C_STRUCT cTys => STRUCT(List.map genRandArg cTys)
323 : mrainey 2992 (* end case *))
324 :    
325 : mrainey 2993 fun output (strm, s) = TextIO.output(strm, s^"\n")
326 :    
327 : mrainey 2995 val pty1 = [CTy.C_double, CTy.C_unsigned CTy.I_int, CTy.C_PTR, CTy.C_double,
328 :     CTy.C_float, CTy.C_PTR, CTy.C_float, CTy.C_PTR, CTy.C_PTR, CTy.C_PTR,
329 :     CTy.C_signed CTy.I_int,
330 :     CTy.C_double, CTy.C_double, CTy.C_double, CTy.C_double, CTy.C_double,
331 :     CTy.C_double, CTy.C_double]
332 :     val pty2 = [CTy.C_STRUCT [CTy.C_float]]
333 :     val pty3 = [CTy.C_STRUCT [CTy.C_float,CTy.C_float]]
334 :     val pty3 = [CTy.C_STRUCT [CTy.C_float,CTy.C_float,CTy.C_float,CTy.C_float]]
335 :     val pty4 = [CTy.C_STRUCT [CTy.C_PTR,CTy.C_float,CTy.C_float,CTy.C_float]]
336 : mrainey 2997 val pty5 = [CTy.C_double, CTy.C_unsigned CTy.I_int, CTy.C_PTR]
337 : mrainey 3043 val pty6 = [CTy.C_PTR, CTy.C_PTR, CTy.C_PTR, CTy.C_PTR, CTy.C_PTR, CTy.C_PTR, CTy.C_PTR, CTy.C_PTR]
338 : mrainey 2998 val pty7 = [CTy.C_float]
339 :     val pty8 = [CTy.C_PTR]
340 : mrainey 3010 val pty9 = [CTy.C_signed CTy.I_int]
341 :     val pty10 = [CTy.C_signed CTy.I_int, CTy.C_signed CTy.I_int]
342 :     val pty11 = [CTy.C_signed CTy.I_int, CTy.C_signed CTy.I_char, CTy.C_float]
343 : mrainey 3043 val pty12 = [CTy.C_STRUCT [CTy.C_PTR, CTy.C_PTR, CTy.C_PTR, CTy.C_PTR, CTy.C_PTR, CTy.C_PTR, CTy.C_PTR, CTy.C_PTR]]
344 : mrainey 3068 val pty13 = [CTy.C_float, CTy.C_double]
345 : mrainey 2995
346 : mrainey 3038 fun main _ = BackTrace.monitor (fn () => let
347 : mrainey 3010 val retTy = CTy.C_signed CTy.I_int
348 : mrainey 3068 val paramTys = pty13
349 : mrainey 2992
350 :     val cArgs = List.map genRandArg paramTys
351 :     val retVal = if retTy <> CTy.C_void then [genRandArg retTy] else []
352 :     val proto = {conv="ccall", retTy=retTy, paramTys=paramTys}
353 : mrainey 2990 val mlriscGlue = "mlriscGlue"
354 :     val target = "target"
355 :    
356 : mrainey 2992 (* output C code that glues to the MLRISC code *)
357 : mrainey 2990 val cOutStrm = TextIO.openOut "glue.c"
358 : mrainey 2992 val cCode = genGlue(target, mlriscGlue, proto, cArgs, retVal)
359 : mrainey 2993 val _ = output(cOutStrm, cCode)
360 : mrainey 2990 val _ = TextIO.closeOut cOutStrm
361 :    
362 : mrainey 2992 (* output C code for santity check *)
363 :     val cOutStrm = TextIO.openOut "sanity.c"
364 : mrainey 2995 val cCode = genSanityCheck(proto, cArgs, retVal)
365 : mrainey 2993 val _ = output(cOutStrm, cCode)
366 : mrainey 2992 val _ = TextIO.closeOut cOutStrm
367 :    
368 : mrainey 2990 (* output main *)
369 :     val cMainOutStrm = TextIO.openOut "main.c"
370 :     val cMain = genCMain()
371 : mrainey 2993 val _ = output(cMainOutStrm, cMain)
372 : mrainey 2990 val _ = TextIO.closeOut cMainOutStrm
373 : mrainey 3038
374 : mrainey 2995 (* output MLRISC code *)
375 : mrainey 3009 val tmpReg = Cells.newReg()
376 : mrainey 2992 val tmpR = T.REG(wordTy, tmpReg)
377 : mrainey 3037 val szB = Int.max(wordSzB, maxSzOfProto proto)
378 :     val (_, glueArgs) = List.foldl (genGlueArg szB tmpR) (0, []) paramTys
379 : mrainey 2990 val asmOutStrm = TextIO.openOut "mlrisc.s"
380 : mrainey 2992 fun doit () = Test.dumpOutput(Test.codegen(mlriscGlue, target, proto, [T.MV(wordTy, tmpReg, param0)], List.rev glueArgs))
381 : mrainey 2990 val _ = AsmStream.withStream asmOutStrm doit ()
382 :     val _ = TextIO.closeOut asmOutStrm
383 :     in
384 : mrainey 2992 0
385 : mrainey 3038 end)
386 : mrainey 2990
387 :    
388 :     end

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