extract/codegen/code_generation.ml

   1 (* Memory info command for virtual domains.
   2    (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
   3    http://libvirt.org/
   4
   5    This program is free software; you can redistribute it and/or modify
   6    it under the terms of the GNU General Public License as published by
   7    the Free Software Foundation; either version 2 of the License, or
   8    (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful,
  11    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13    GNU General Public License for more details.
  14
  15    You should have received a copy of the GNU General Public License
  16    along with this program; if not, write to the Free Software
  17    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18  *)
  19
  20 open Camlp4.PreCast
  21 open Syntax
  22 (*open Ast*)
  23
  24 open ExtList
  25 open ExtString
  26 open Printf
  27
  28 module PP = Pahole_parser
  29 module SC = Struct_classify
  30
  31 let rec uniq ?(cmp = Pervasives.compare) = function
  32     [] -> []
  33   | [x] -> [x]
  34   | x :: y :: xs when cmp x y = 0 ->
  35       uniq (x :: xs)
  36   | x :: y :: xs ->
  37       x :: uniq (y :: xs)
  38
  39 let sort_uniq ?cmp xs =
  40   let xs = List.sort ?cmp xs in
  41   let xs = uniq ?cmp xs in
  42   xs
  43
  44 (* We don't care about locations when generating code, so it's
  45  * useful to just have a single global _loc.
  46  *)
  47 let _loc = Loc.ghost
  48
  49 (* Some handy camlp4 construction functions which do some
  50  * things that ought to be easy/obvious but aren't.
  51  *
  52  * 'concat_str_items' concatenates a list of str_item together into
  53  * one big str_item.
  54  *
  55  * 'concat_record_fields' concatenates a list of records fields into
  56  * a record.  The list must have at least one element.
  57  *
  58  * 'build_record' builds a record out of record fields.
  59  *
  60  * 'build_tuple_from_exprs' builds an arbitrary length tuple from
  61  * a list of expressions of length >= 2.
  62  *
  63  * Thanks to bluestorm on #ocaml for getting these working.
  64  *)
  65 let concat_str_items items =
  66   match items with
  67   | [] -> <:str_item< >>
  68   | x :: xs ->
  69       List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
  70
  71 let concat_sig_items items =
  72   match items with
  73   | [] -> <:sig_item< >>
  74   | x :: xs ->
  75       List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
  76
  77 let concat_record_fields fields =
  78   match fields with
  79     | [] -> assert false
  80     | f :: fs ->
  81         List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
  82
  83 let concat_record_bindings rbs =
  84   match rbs with
  85     | [] -> assert false
  86     | rb :: rbs ->
  87         List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
  88
  89 let build_record rbs =
  90   Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
  91
  92 let build_tuple_from_exprs exprs =
  93   match exprs with
  94   | [] | [_] -> assert false
  95   | x :: xs ->
  96       Ast.ExTup (_loc,
  97                  List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
  98
  99 type code = Ast.str_item * Ast.sig_item
 100
 101 let ocaml_type_of_field_type = function
 102   | PP.FInteger -> <:ctyp< int64 >>
 103   | PP.FString _ -> <:ctyp< string >>
 104   | PP.FStructPointer _ | PP.FVoidPointer
 105   | PP.FAnonListHeadPointer | PP.FListHeadPointer _ ->
 106       <:ctyp< Virt_mem_mmap.addr >>
 107
 108 let generate_types xs =
 109   let strs = List.map (
 110     fun (struct_name, sflist, cflist) ->
 111       let sflist = List.map (
 112         fun { SC.sf_name = sf_name; sf_fields = fields } ->
 113           if fields <> [] then (
 114             let fields = List.map (
 115               fun { PP.field_name = name; PP.field_type = t } ->
 116                 let t = ocaml_type_of_field_type t in
 117                 <:ctyp< $lid:sf_name^"_"^name$ : $t$ >>
 118             ) fields in
 119             let fields = concat_record_fields fields in
 120
 121             <:str_item<
 122               type $lid:sf_name$ = { $fields$ }
 123             >>
 124           ) else
 125             <:str_item< type $lid:sf_name$ = unit >>
 126       ) sflist in
 127       let sflist = concat_str_items sflist in
 128
 129       let cflist = List.map (
 130         fun { SC.cf_name = cf_name; cf_fields = fields } ->
 131           if fields <> [] then (
 132             let fields = List.map (
 133               fun { PP.field_name = name; PP.field_type = t } ->
 134                 let t = ocaml_type_of_field_type t in
 135                 <:ctyp< $lid:cf_name^"_"^name$ : $t$ >>
 136             ) fields in
 137             let fields = concat_record_fields fields in
 138
 139             <:str_item<
 140               type $lid:cf_name$ = { $fields$ }
 141             >>
 142           ) else
 143             <:str_item< type $lid:cf_name$ = unit >>
 144       ) cflist in
 145       let cflist = concat_str_items cflist in
 146
 147       <:str_item<
 148         type ('a, 'b) $lid:struct_name$ = {
 149           $lid:struct_name^"_shape"$ : 'a;
 150           $lid:struct_name^"_content"$ : 'b;
 151         }
 152         $sflist$
 153         $cflist$
 154       >>
 155   ) xs in
 156
 157   let sigs =
 158     List.map (
 159       fun (struct_name, _, _) ->
 160         <:sig_item<
 161           type ('a, 'b) $lid:struct_name$
 162         >>
 163     ) xs in
 164
 165   concat_str_items strs, concat_sig_items sigs
 166
 167 let generate_offsets xs =
 168   (* Only need to generate the offset_of_* functions for fields
 169    * which are cross-referenced from another field.  Which
 170    * ones are those?
 171    *)
 172   let fields =
 173     List.concat (
 174       List.map (
 175         fun (_, (_, all_fields)) ->
 176           List.filter_map (
 177             function
 178             | (_,
 179                PP.FListHeadPointer ((Some (struct_name, field_name)) as f)) ->
 180                 f
 181             | _ ->
 182                 None
 183           ) all_fields
 184       ) xs
 185     ) in
 186
 187   let fields = sort_uniq fields in
 188
 189   let strs =
 190     List.map (
 191       fun (struct_name, field_name) ->
 192         let kernels, _ =
 193           try List.assoc struct_name xs
 194           with Not_found ->
 195             failwith (
 196               sprintf "generate_offsets: structure %s not found. This is probably a list_head-related bug."
 197                 struct_name
 198             ) in
 199         (* Find the offset of this field in each kernel version. *)
 200         let offsets =
 201           List.filter_map (
 202             fun ({ PP.kernel_version = version },
 203                  { PP.struct_fields = fields }) ->
 204               try
 205                 let field =
 206                   List.find (fun { PP.field_name = name } -> field_name = name)
 207                     fields in
 208                 let offset = field.PP.field_offset in
 209                 Some (version, offset)
 210               with Not_found -> None
 211           ) kernels in
 212
 213         if offsets = [] then
 214           failwith (
 215             sprintf "generate_offsets: field %s.%s not found in any kernel. This is probably a list_head-related bug."
 216               struct_name field_name
 217           );
 218
 219         (* Generate a map of kernel version to offset. *)
 220         let map = List.fold_left (
 221           fun map (version, offset) ->
 222             <:expr< StringMap.add $str:version$ $`int:offset$ $map$ >>
 223         ) <:expr< StringMap.empty >> offsets in
 224
 225         let code =
 226           <:str_item<
 227             let $lid:"offset_of_"^struct_name^"_"^field_name$ =
 228               let map = $map$ in
 229               fun kernel_version -> StringMap.find kernel_version map
 230           >> in
 231         code
 232     ) fields in
 233
 234   let strs = concat_str_items strs in
 235   let strs =
 236     <:str_item<
 237       module StringMap = Map.Make (String) ;;
 238       $strs$
 239     >> in
 240
 241   strs, <:sig_item< >>
 242
 243 let generate_parsers xs =
 244   let strs =
 245     List.map (
 246       fun (struct_name, palist) ->
 247         let palist =
 248           List.map (
 249             fun { SC.pa_name = pa_name } ->
 250               <:str_item<
 251                 let $lid:pa_name$ kernel_version bits = $str:pa_name$
 252               >>
 253           ) palist in
 254         concat_str_items palist
 255     ) xs in
 256
 257   let strs = concat_str_items strs in
 258   let strs =
 259     <:str_item<
 260       let match_err = "failed to match kernel structure" ;;
 261       let zero = 0 ;;
 262       $strs$
 263     >> in
 264
 265   (* The shared parser functions.
 266    *
 267    * We could include bitmatch statements directly in here, but
 268    * what happens is that the macros get expanded here, resulting
 269    * in (even more) unreadable generated code.  So instead just
 270    * do a textual substitution later by post-processing the
 271    * generated files.  Not type-safe, but we can't have
 272    * everything.
 273    *)
 274   let subs = Hashtbl.create 13 in
 275   List.iter (
 276     fun (struct_name, palist) ->
 277       List.iter (
 278         fun ({ SC.pa_name = pa_name;
 279                pa_endian = endian; pa_structure = structure;
 280                pa_shape_field_struct = sf;
 281                pa_content_field_struct = cf }) ->
 282           (* Generate the code to match this structure. *)
 283           let endian =
 284             match endian with
 285             | Bitstring.LittleEndian -> "littleendian"
 286             | Bitstring.BigEndian -> "bigendian"
 287             | _ -> assert false in
 288           let patterns =
 289             String.concat ";\n      " (
 290               List.map (
 291                 function
 292                 | { PP.field_name = field_name;
 293                     field_type = PP.FInteger;
 294                     field_offset = offset;
 295                     field_size = size } ->
 296                     (* 'zero+' is a hack to force the type to int64. *)
 297                     sprintf "%s : zero+%d : offset(%d), %s"
 298                       field_name (size*8) (offset*8) endian
 299
 300                 | { PP.field_name = field_name;
 301                     field_type = (PP.FStructPointer _
 302                                   | PP.FVoidPointer
 303                                   | PP.FAnonListHeadPointer
 304                                   | PP.FListHeadPointer _);
 305                     field_offset = offset;
 306                     field_size = size } ->
 307                     sprintf "%s : zero+%d : offset(%d), %s"
 308                       field_name (size*8) (offset*8) endian
 309
 310                 | { PP.field_name = field_name;
 311                     field_type = PP.FString width;
 312                     field_offset = offset;
 313                     field_size = size } ->
 314                     sprintf "%s : %d : offset(%d), string"
 315                       field_name (width*8) (offset*8)
 316               ) structure.PP.struct_fields
 317             ) in
 318
 319           let shape_assignments =
 320             List.map (
 321               fun { PP.field_name = field_name;
 322                     field_type = field_type;
 323                     field_offset = offset } ->
 324
 325                 match field_type with
 326                 | PP.FListHeadPointer None ->
 327                     sprintf "%s_%s = Int64.sub %s %dL"
 328                       sf.SC.sf_name field_name field_name offset
 329
 330                 | PP.FListHeadPointer (Some (other_struct_name,
 331                                              other_field_name)) ->
 332                     (* A reference to a field in another structure.  We don't
 333                      * know the offset until runtime, so we have to call
 334                      * offset_of_<struct>_<field> to find it.
 335                      *)
 336                     sprintf "%s_%s = (
 337                       let offset = offset_of_%s_%s kernel_version in
 338                       let offset = Int64.of_int offset in
 339                       Int64.sub %s offset
 340                     )"
 341                       sf.SC.sf_name field_name
 342                       other_struct_name other_field_name
 343                       field_name
 344                 | _ ->
 345                     sprintf "%s_%s = %s" sf.SC.sf_name field_name field_name
 346             ) sf.SC.sf_fields in
 347
 348           let shape_assignments =
 349             if shape_assignments = [] then "()"
 350             else
 351               "{ " ^ String.concat ";\n        " shape_assignments ^ " }" in
 352
 353           let content_assignments =
 354             List.map (
 355               fun { PP.field_name = field_name } ->
 356                 sprintf "%s_%s = %s" cf.SC.cf_name field_name field_name
 357             ) cf.SC.cf_fields in
 358
 359           let content_assignments =
 360             if content_assignments = [] then "()"
 361             else
 362               "{ " ^ String.concat ";\n        " content_assignments ^ " }" in
 363
 364           let code =
 365             sprintf "
 366   bitmatch bits with
 367   | { %s } ->
 368       let shape =
 369       %s in
 370       let content =
 371       %s in
 372       { %s_shape = shape; %s_content = content }
 373   | { _ } ->
 374       raise (Virt_mem_types.ParseError (%S, %S, match_err))"
 375               patterns shape_assignments content_assignments
 376               struct_name struct_name
 377               struct_name pa_name in
 378
 379           Hashtbl.add subs pa_name code
 380       ) palist;
 381   ) xs;
 382
 383   (strs, <:sig_item< >>), subs
 384
 385 let output_interf ~output_file types offsets parsers =
 386   let sigs = concat_sig_items [ types; offsets; parsers ] in
 387   Printers.OCaml.print_interf ~output_file sigs
 388
 389 (* Finally generate the output files. *)
 390 let re_subst = Pcre.regexp "^(.*)\"(\\w+_parser_\\d+)\"(.*)$"
 391
 392 let output_implem ~output_file types offsets parsers parser_subs =
 393   let new_output_file = output_file ^ ".new" in
 394
 395   let strs = concat_str_items [ types; offsets; parsers ] in
 396   Printers.OCaml.print_implem ~output_file:new_output_file strs;
 397
 398   (* Substitute the parser bodies in the output file. *)
 399   let ichan = open_in new_output_file in
 400   let ochan = open_out output_file in
 401
 402   output_string ochan "\
 403 (* WARNING: This file and the corresponding mli (interface) are
 404  * automatically generated by the extract/codegen/ program.
 405  *
 406  * Any edits you make to this file will be lost.
 407  *
 408  * To update this file from the latest kernel database, it is recommended
 409  * that you do 'make update-kernel-structs'.
 410  *)\n\n";
 411
 412   let rec loop () =
 413     let line = input_line ichan in
 414     let line =
 415       if Pcre.pmatch ~rex:re_subst line then (
 416         let subs = Pcre.exec ~rex:re_subst line in
 417         let start = Pcre.get_substring subs 1 in
 418         let template = Pcre.get_substring subs 2 in
 419         let rest = Pcre.get_substring subs 3 in
 420         let sub =
 421           try Hashtbl.find parser_subs template
 422           with Not_found -> assert false in
 423         start ^ sub ^ rest
 424       ) else line in
 425     output_string ochan line; output_char ochan '\n';
 426     loop ()
 427   in
 428   (try loop () with End_of_file -> ());
 429
 430   close_out ochan;
 431   close_in ichan;
 432
 433   Unix.unlink new_output_file