callgen.ml (13659B)
1 (* abi fuzzer, generates two modules one calling 2 * the other in two possibly different languages 3 *) 4 5 type _ bty = 6 | Char: int bty 7 | Short: int bty 8 | Int: int bty 9 | Long: int bty 10 | Float: float bty 11 | Double: float bty 12 13 type _ sty = 14 | Field: 'a bty * 'b sty -> ('a * 'b) sty 15 | Empty: unit sty 16 17 type _ aty = 18 | Base: 'a bty -> 'a aty 19 | Struct: 'a sty -> 'a aty 20 21 type anyb = AB: _ bty -> anyb (* kinda boring... *) 22 type anys = AS: _ sty -> anys 23 type anya = AA: _ aty -> anya 24 type testb = TB: 'a bty * 'a -> testb 25 type testa = TA: 'a aty * 'a -> testa 26 27 28 let align a x = 29 let m = x mod a in 30 if m <> 0 then x + (a-m) else x 31 32 let btysize: type a. a bty -> int = function 33 | Char -> 1 34 | Short -> 2 35 | Int -> 4 36 | Long -> 8 37 | Float -> 4 38 | Double -> 8 39 40 let btyalign = btysize 41 42 let styempty: type a. a sty -> bool = function 43 | Field _ -> false 44 | Empty -> true 45 46 let stysize s = 47 let rec f: type a. int -> a sty -> int = 48 fun sz -> function 49 | Field (b, s) -> 50 let a = btyalign b in 51 f (align a sz + btysize b) s 52 | Empty -> sz in 53 f 0 s 54 55 let rec styalign: type a. a sty -> int = function 56 | Field (b, s) -> max (btyalign b) (styalign s) 57 | Empty -> 1 58 59 60 (* Generate types and test vectors. *) 61 module Gen = struct 62 module R = Random 63 64 let init = function 65 | None -> 66 let f = open_in "/dev/urandom" in 67 let seed = 68 Char.code (input_char f) lsl 16 + 69 Char.code (input_char f) lsl 8 + 70 Char.code (input_char f) in 71 close_in f; 72 R.init seed; 73 seed 74 | Some seed -> 75 R.init seed; 76 seed 77 78 let int sz = 79 let bound = 1 lsl (8 * min sz 3 - 1) in 80 let i = R.int bound in 81 if R.bool () then - i else i 82 83 let float () = 84 let f = R.float 1000. in 85 if R.bool () then -. f else f 86 87 let testv: type a. a aty -> a = 88 let tb: type a. a bty -> a = function (* eh, dry... *) 89 | Float -> float () 90 | Double -> float () 91 | Char -> int (btysize Char) 92 | Short -> int (btysize Short) 93 | Int -> int (btysize Int) 94 | Long -> int (btysize Long) in 95 let rec ts: type a. a sty -> a = function 96 | Field (b, s) -> (tb b, ts s) 97 | Empty -> () in 98 function 99 | Base b -> tb b 100 | Struct s -> ts s 101 102 let b () = (* uniform *) 103 match R.int 6 with 104 | 0 -> AB Char 105 | 1 -> AB Short 106 | 2 -> AB Int 107 | 3 -> AB Long 108 | 4 -> AB Float 109 | _ -> AB Double 110 111 let smax = 5 (* max elements in structs *) 112 let structp = 0.3 (* odds of having a struct type *) 113 let amax = 8 (* max function arguments *) 114 115 let s () = 116 let rec f n = 117 if n = 0 then AS Empty else 118 let AB bt = b () in 119 let AS st = f (n-1) in 120 AS (Field (bt, st)) in 121 f (1 + R.int (smax-1)) 122 123 let a () = 124 if R.float 1.0 > structp then 125 let AB bt = b () in 126 AA (Base bt) 127 else 128 let AB bt = b () in 129 let AS st = s () in 130 AA (Struct (Field (bt, st))) 131 132 let test () = 133 let AA ty = a () in 134 let t = testv ty in 135 TA (ty, t) 136 137 let tests () = 138 let rec f n = 139 if n = 0 then [] else 140 test () :: f (n-1) in 141 f (R.int amax) 142 143 end 144 145 146 (* Code generation for C *) 147 module OutC = struct 148 open Printf 149 150 let ctypelong oc name = 151 let cb: type a. a bty -> unit = function 152 | Char -> fprintf oc "char" 153 | Short -> fprintf oc "short" 154 | Int -> fprintf oc "int" 155 | Long -> fprintf oc "long" 156 | Float -> fprintf oc "float" 157 | Double -> fprintf oc "double" in 158 let rec cs: type a. int -> a sty -> unit = 159 fun i -> function 160 | Field (b, s) -> 161 cb b; 162 fprintf oc " f%d; " i; 163 cs (i+1) s; 164 | Empty -> () in 165 function 166 | Base b -> 167 cb b; 168 | Struct s -> 169 fprintf oc "struct %s { " name; 170 cs 1 s; 171 fprintf oc "}"; 172 () 173 174 let ctype: type a. out_channel -> string -> a aty -> unit = 175 fun oc name -> function 176 | Struct _ -> fprintf oc "struct %s" name 177 | t -> ctypelong oc "" t 178 179 let base: type a. out_channel -> a bty * a -> unit = 180 fun oc -> function 181 | Char, i -> fprintf oc "%d" i 182 | Short, i -> fprintf oc "%d" i 183 | Int, i -> fprintf oc "%d" i 184 | Long, i -> fprintf oc "%d" i 185 | Float, f -> fprintf oc "%ff" f 186 | Double, f -> fprintf oc "%f" f 187 188 let init oc name (TA (ty, t)) = 189 let inits s = 190 let rec f: type a. a sty * a -> unit = function 191 | Field (b, s), (tb, ts) -> 192 base oc (b, tb); 193 fprintf oc ", "; 194 f (s, ts) 195 | Empty, () -> () in 196 fprintf oc "{ "; 197 f s; 198 fprintf oc "}"; in 199 ctype oc name ty; 200 fprintf oc " %s = " name; 201 begin match (ty, t) with 202 | Base b, tb -> base oc (b, tb) 203 | Struct s, ts -> inits (s, ts) 204 end; 205 fprintf oc ";\n"; 206 () 207 208 let extension = ".c" 209 210 let comment oc s = 211 fprintf oc "/* %s */\n" s 212 213 let prelude oc = List.iter (fprintf oc "%s\n") 214 [ "#include <stdio.h>" 215 ; "#include <stdlib.h>" 216 ; "" 217 ; "static void fail(char *chk)" 218 ; "{" 219 ; "\tfprintf(stderr, \"fail: checking %s\\n\", chk);" 220 ; "\tabort();" 221 ; "}" 222 ; "" 223 ] 224 225 let typedef oc name = function 226 | TA (Struct ts, _) -> 227 ctypelong oc name (Struct ts); 228 fprintf oc ";\n"; 229 | _ -> () 230 231 let check oc name = 232 let chkbase: type a. string -> a bty * a -> unit = 233 fun name t -> 234 fprintf oc "\tif (%s != " name; 235 base oc t; 236 fprintf oc ")\n\t\tfail(%S);\n" name; in 237 function 238 | TA (Base b, tb) -> chkbase name (b, tb) 239 | TA (Struct s, ts) -> 240 let rec f: type a. int -> a sty * a -> unit = 241 fun i -> function 242 | Field (b, s), (tb, ts) -> 243 chkbase (Printf.sprintf "%s.f%d" name i) (b, tb); 244 f (i+1) (s, ts); 245 | Empty, () -> () in 246 f 1 (s, ts) 247 248 let argname i = "arg" ^ string_of_int (i+1) 249 250 let proto oc (TA (tret, _)) args = 251 ctype oc "ret" tret; 252 fprintf oc " f("; 253 let narg = List.length args in 254 List.iteri (fun i (TA (targ, _)) -> 255 ctype oc (argname i) targ; 256 fprintf oc " %s" (argname i); 257 if i <> narg-1 then 258 fprintf oc ", "; 259 ) args; 260 fprintf oc ")"; 261 () 262 263 let caller oc ret args = 264 let narg = List.length args in 265 prelude oc; 266 typedef oc "ret" ret; 267 List.iteri (fun i arg -> 268 typedef oc (argname i) arg; 269 ) args; 270 proto oc ret args; 271 fprintf oc ";\n\nint main()\n{\n"; 272 List.iteri (fun i arg -> 273 fprintf oc "\t"; 274 init oc (argname i) arg; 275 ) args; 276 fprintf oc "\t"; 277 let TA (tret, _) = ret in 278 ctype oc "ret" tret; 279 fprintf oc " ret;\n\n"; 280 fprintf oc "\tret = f("; 281 List.iteri (fun i _ -> 282 fprintf oc "%s" (argname i); 283 if i <> narg-1 then 284 fprintf oc ", "; 285 ) args; 286 fprintf oc ");\n"; 287 check oc "ret" ret; 288 fprintf oc "\n\treturn 0;\n}\n"; 289 () 290 291 let callee oc ret args = 292 prelude oc; 293 typedef oc "ret" ret; 294 List.iteri (fun i arg -> 295 typedef oc (argname i) arg; 296 ) args; 297 fprintf oc "\n"; 298 proto oc ret args; 299 fprintf oc "\n{\n\t"; 300 init oc "ret" ret; 301 fprintf oc "\n"; 302 List.iteri (fun i arg -> 303 check oc (argname i) arg; 304 ) args; 305 fprintf oc "\n\treturn ret;\n}\n"; 306 () 307 308 end 309 310 (* Code generation for QBE *) 311 module OutIL = struct 312 open Printf 313 314 let comment oc s = 315 fprintf oc "# %s\n" s 316 317 let tmp, lbl = 318 let next = ref 0 in 319 (fun () -> incr next; "%t" ^ (string_of_int !next)), 320 (fun () -> incr next; "@l" ^ (string_of_int !next)) 321 322 let bvalue: type a. a bty * a -> string = function 323 | Char, i -> sprintf "%d" i 324 | Short, i -> sprintf "%d" i 325 | Int, i -> sprintf "%d" i 326 | Long, i -> sprintf "%d" i 327 | Float, f -> sprintf "s_%f" f 328 | Double, f -> sprintf "d_%f" f 329 330 let btype: type a. a bty -> string = function 331 | Char -> "w" 332 | Short -> "w" 333 | Int -> "w" 334 | Long -> "l" 335 | Float -> "s" 336 | Double -> "d" 337 338 let extension = ".ssa" 339 340 let argname i = "arg" ^ string_of_int (i+1) 341 342 let siter oc base s g = 343 let rec f: type a. int -> int -> a sty * a -> unit = 344 fun id off -> function 345 | Field (b, s), (tb, ts) -> 346 let off = align (btyalign b) off in 347 let addr = tmp () in 348 fprintf oc "\t%s =l add %d, %s\n" addr off base; 349 g id addr (TB (b, tb)); 350 f (id + 1) (off + btysize b) (s, ts); 351 | Empty, () -> () in 352 f 0 0 s 353 354 let bmemtype b = 355 if AB b = AB Char then "b" else 356 if AB b = AB Short then "h" else 357 btype b 358 359 let init oc = function 360 | TA (Base b, tb) -> bvalue (b, tb) 361 | TA (Struct s, ts) -> 362 let base = tmp () in 363 fprintf oc "\t%s =l alloc%d %d\n" 364 base (styalign s) (stysize s); 365 siter oc base (s, ts) 366 begin fun _ addr (TB (b, tb)) -> 367 fprintf oc "\tstore%s %s, %s\n" 368 (bmemtype b) (bvalue (b, tb)) addr; 369 end; 370 base 371 372 let check oc id name = 373 let bcheck = fun id name (b, tb) -> 374 let tcmp = tmp () in 375 let nxtl = lbl () in 376 fprintf oc "\t%s =w ceq%s %s, %s\n" 377 tcmp (btype b) name (bvalue (b, tb)); 378 fprintf oc "\tstorew %d, %%failcode\n" id; 379 fprintf oc "\tjnz %s, %s, @fail\n" tcmp nxtl; 380 fprintf oc "%s\n" nxtl; in 381 function 382 | TA (Base Char, i) -> 383 let tval = tmp () in 384 fprintf oc "\t%s =w extsb %s\n" tval name; 385 bcheck id tval (Int, i) 386 | TA (Base Short, i) -> 387 let tval = tmp () in 388 fprintf oc "\t%s =w extsh %s\n" tval name; 389 bcheck id tval (Int, i) 390 | TA (Base b, tb) -> 391 bcheck id name (b, tb) 392 | TA (Struct s, ts) -> 393 siter oc name (s, ts) 394 begin fun id' addr (TB (b, tb)) -> 395 let tval = tmp () in 396 let lsuffix = 397 if AB b = AB Char then "sb" else 398 if AB b = AB Short then "sh" else 399 "" in 400 fprintf oc "\t%s =%s load%s %s\n" 401 tval (btype b) lsuffix addr; 402 bcheck (100*id + id'+1) tval (b, tb); 403 end; 404 () 405 406 let ttype name = function 407 | TA (Base b, _) -> btype b 408 | TA (Struct _, _) -> ":" ^ name 409 410 let typedef oc name = 411 let rec f: type a. a sty -> unit = function 412 | Field (b, s) -> 413 fprintf oc "%s" (bmemtype b); 414 if not (styempty s) then 415 fprintf oc ", "; 416 f s; 417 | Empty -> () in 418 function 419 | TA (Struct ts, _) -> 420 fprintf oc "type :%s = { " name; 421 f ts; 422 fprintf oc " }\n"; 423 | _ -> () 424 425 let postlude oc = List.iter (fprintf oc "%s\n") 426 [ "@fail" 427 ; "# failure code" 428 ; "\t%fcode =w loadw %failcode" 429 ; "\t%f0 =w call $printf(l $failstr, w %fcode)" 430 ; "\t%f1 =w call $abort()" 431 ; "\tret 0" 432 ; "}" 433 ; "" 434 ; "data $failstr = { b \"fail on check %d\\n\", b 0 }" 435 ] 436 437 let caller oc ret args = 438 let narg = List.length args in 439 List.iteri (fun i arg -> 440 typedef oc (argname i) arg; 441 ) args; 442 typedef oc "ret" ret; 443 fprintf oc "\nexport function w $main() {\n"; 444 fprintf oc "@start\n"; 445 fprintf oc "\t%%failcode =l alloc4 4\n"; 446 let targs = List.mapi (fun i arg -> 447 comment oc ("define argument " ^ (string_of_int (i+1))); 448 (ttype (argname i) arg, init oc arg) 449 ) args in 450 comment oc "call test function"; 451 fprintf oc "\t%%ret =%s call $f(" (ttype "ret" ret); 452 List.iteri (fun i (ty, tmp) -> 453 fprintf oc "%s %s" ty tmp; 454 if i <> narg-1 then 455 fprintf oc ", "; 456 ) targs; 457 fprintf oc ")\n"; 458 comment oc "check the return value"; 459 check oc 0 "%ret" ret; 460 fprintf oc "\tret 0\n"; 461 postlude oc; 462 () 463 464 let callee oc ret args = 465 let narg = List.length args in 466 List.iteri (fun i arg -> 467 typedef oc (argname i) arg; 468 ) args; 469 typedef oc "ret" ret; 470 fprintf oc "\nexport function %s $f(" (ttype "ret" ret); 471 List.iteri (fun i arg -> 472 let a = argname i in 473 fprintf oc "%s %%%s" (ttype a arg) a; 474 if i <> narg-1 then 475 fprintf oc ", "; 476 ) args; 477 fprintf oc ") {\n"; 478 fprintf oc "@start\n"; 479 fprintf oc "\t%%failcode =l alloc4 4\n"; 480 List.iteri (fun i arg -> 481 comment oc ("checking argument " ^ (string_of_int (i+1))); 482 check oc (i+1) ("%" ^ argname i) arg; 483 ) args; 484 comment oc "define the return value"; 485 let rettmp = init oc ret in 486 fprintf oc "\tret %s\n" rettmp; 487 postlude oc; 488 () 489 490 end 491 492 493 module type OUT = sig 494 val extension: string 495 val comment: out_channel -> string -> unit 496 val caller: out_channel -> testa -> testa list -> unit 497 val callee: out_channel -> testa -> testa list -> unit 498 end 499 500 let _ = 501 let usage code = 502 Printf.eprintf "usage: abi.ml [-s SEED] DIR {c,ssa} {c,ssa}\n"; 503 exit code in 504 505 let outmod = function 506 | "c" -> (module OutC : OUT) 507 | "ssa" -> (module OutIL: OUT) 508 | _ -> usage 1 in 509 510 let seed, dir, mcaller, mcallee = 511 match Sys.argv with 512 | [| _; "-s"; seed; dir; caller; callee |] -> 513 let seed = 514 try Some (int_of_string seed) with 515 Failure _ -> usage 1 in 516 seed, dir, outmod caller, outmod callee 517 | [| _; dir; caller; callee |] -> 518 None, dir, outmod caller, outmod callee 519 | [| _; "-h" |] -> 520 usage 0 521 | _ -> 522 usage 1 in 523 524 let seed = Gen.init seed in 525 let tret = Gen.test () in 526 let targs = Gen.tests () in 527 let module OCaller = (val mcaller : OUT) in 528 let module OCallee = (val mcallee : OUT) in 529 let ocaller = open_out (dir ^ "/caller" ^ OCaller.extension) in 530 let ocallee = open_out (dir ^ "/callee" ^ OCallee.extension) in 531 OCaller.comment ocaller (Printf.sprintf "seed %d" seed); 532 OCallee.comment ocallee (Printf.sprintf "seed %d" seed); 533 OCaller.caller ocaller tret targs; 534 OCallee.callee ocallee tret targs; 535 ()