tools/alloc_free.ml

   1 (* The following finds out for each file, how it does deallocation for each
   2 allocator *)
   3
   4 let collect i =
   5   let info = ref [] in
   6   let rec loop _ =
   7     let l = input_line i in
   8     (if String.length l > 2 && String.get l 0 = '+'
   9     then info := (String.sub l 1 (String.length l - 1))::!info);
  10     loop() in
  11   try loop()
  12   with End_of_file -> List.rev !info
  13
  14 let split l =
  15   let rec loop acc = function
  16     [] -> acc
  17   | x::xs ->
  18       if String.get x 0 = '+' (* the start of a new file *)
  19       then
  20         (match Str.split (Str.regexp " ") x with
  21           _::x::_ -> loop ((x,[])::acc) xs
  22         | _ -> failwith ("no file: "^x))
  23       else
  24         let acc =
  25           match acc with
  26             (file,instances)::rest -> (file,x::instances)::rest
  27           | _ -> failwith "not possible" in
  28         loop acc xs in
  29   let res = List.rev (loop [] l) in
  30   List.map (function (x,l) -> (x,List.rev l)) res
  31
  32 let detect_alloc_free str l =
  33   let try_add a f l =
  34     let (same,diff) = List.partition (function (a1,f1) -> a = a1) l in
  35     match same with
  36       [(a1,f1)] -> if List.mem f f1 then l else (a1,f::f1) :: diff
  37     | _ -> (a,[f])::l in
  38   let rec loop acc = function
  39       [] -> acc
  40     | x::xs ->
  41         match Str.split (Str.regexp (str^"\", ")) x with
  42           _::matches ->
  43             let acc =
  44               List.fold_left
  45                 (function acc ->
  46                   function rest ->
  47                     (match Str.split (Str.regexp "[, )]+") rest with
  48                       alloc::free::_ -> try_add alloc free acc
  49                     | _ -> acc))
  50                 acc matches in
  51             loop acc xs
  52         | _ -> loop acc xs in
  53   List.sort compare
  54     (List.map (function (a,f) -> (a,List.sort compare f)) (loop [] l))
  55
  56 let rec iterate str = function
  57     [] -> []
  58   | (x,l)::xs ->
  59       List.fold_left
  60         (function rest ->
  61           function info ->
  62             let (same,diff) =
  63               List.partition (function (x1,l1) -> l1 = info) rest in
  64             match same with
  65               [(files,info)] -> (x::files,info)::diff
  66             |   _ -> ([x],info)::diff)
  67         (iterate str xs) (detect_alloc_free str l)
  68
  69 (* ------------------------------------------------------------------------ *)
  70 (* The following prints that information *)
  71
  72 let print_output l =
  73   List.iter
  74     (function (files,(a,fs)) ->
  75       List.iter (function x -> Printf.printf "%s\n" x) files;
  76       Printf.printf "   alloc: %s, free: %s\n" a (String.concat ", " fs);
  77       Printf.printf "\n")
  78     l
  79
  80 (* ------------------------------------------------------------------------ *)
  81 (* The following makes a semantic patch for that information *)
  82
  83 let sedify o generic_file dir l =
  84   List.iter
  85     (function (files,(a,fs)) ->
  86       match fs with
  87         [f] ->
  88           let _ =
  89             Sys.command
  90               (Printf.sprintf
  91                  "sed s/ALLOC/%s/ %s | sed s/FREE/%s/ > %s/%s-%s.cocci\n"
  92                  a generic_file f dir a f) in ()
  93       | _ -> ())
  94     l;
  95   List.iter
  96     (function (files,(a,fs)) ->
  97       match fs with
  98         [f] -> Printf.fprintf o "mono_spatch_linux %s-%s.cocci &\n" a f
  99       | _ -> ())
 100     l
 101
 102 let collect_allocs l =
 103   let union =
 104     List.fold_left
 105       (function rest -> function x ->
 106         if List.mem x rest then rest else x::rest) in
 107   List.fold_left
 108     (function rest ->
 109       function (files,(a,fs)) ->
 110         let (same,diff) =
 111           List.partition (function (a1,fs1) -> a = a1) rest in
 112         match same with
 113           [(a1,fs1)] -> (a,union fs fs1)::diff
 114         | [] -> (a,fs)::rest
 115         | _ -> failwith "not possible")
 116     [] l
 117
 118 let sedify_ors o generic_file dir l =
 119   let l = collect_allocs l in
 120   List.iter
 121     (function (a,fs) ->
 122       match fs with
 123         [_] | [] -> ()
 124       | (f::_) ->
 125           let sfs =
 126             Printf.sprintf "\"\\\\\\(%s\\\\\\)\""
 127               (String.concat "\\\\\\|" fs) in
 128           let _ =
 129             Sys.command
 130               (Printf.sprintf
 131                  "sed s/ALLOC/%s/ %s | sed s/FREE/%s/ > %s/%s-%s_et_al.cocci\n"
 132                  a generic_file sfs dir a f) in ())
 133     l;
 134   List.iter
 135     (function (a,fs) ->
 136       match fs with
 137         [_] | [] -> ()
 138       | (f::_) ->
 139           Printf.fprintf o "mono_spatch_linux %s-%s_et_al.cocci &\n" a f)
 140     l
 141
 142 (* ------------------------------------------------------------------------ *)
 143
 144 let sed = ref false
 145 let gen = ref "generic2.cocci"
 146 let dir = ref "p2"
 147 let file = ref ""
 148 let str = ref "detected allocator"
 149
 150 let options = [ "-sed", Arg.Set sed, "sed output";
 151                 "-sp", Arg.String (function x -> gen := x),
 152                 "detection string";
 153                 "-str", Arg.String (function x -> str := x),
 154                 "cocci file for use with sed";
 155                 "-dir", Arg.String (function x -> dir := x),
 156                 "dir for sed output"; ]
 157 let usage = ""
 158
 159 let _ =
 160   Arg.parse (Arg.align options) (fun x -> file := x) usage;
 161   let i = open_in !file in
 162   let l = collect i in
 163   close_in i;
 164   let l = split l in
 165   let l = iterate !str l in
 166   (if !sed
 167   then
 168     begin
 169       let o = open_out (Printf.sprintf "%s/files" !dir) in
 170       Printf.fprintf o "#!/bin/sh\n\n";
 171       sedify o !gen !dir l;
 172       sedify_ors o !gen !dir l;
 173       Printf.fprintf o "\nwait\n/bin/rm tmp*out\n";
 174       close_out o
 175     end);
 176   if not !sed then print_output l