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 (* We don't care about locations when generating code, so it's
  32  * useful to just have a single global _loc.
  33  *)
  34 let _loc = Loc.ghost
  35
  36 (* Some handy camlp4 construction functions which do some
  37  * things that ought to be easy/obvious but aren't.
  38  *
  39  * 'concat_str_items' concatenates a list of str_item together into
  40  * one big str_item.
  41  *
  42  * 'concat_record_fields' concatenates a list of records fields into
  43  * a record.  The list must have at least one element.
  44  *
  45  * 'build_record' builds a record out of record fields.
  46  *
  47  * 'build_tuple_from_exprs' builds an arbitrary length tuple from
  48  * a list of expressions of length >= 2.
  49  *
  50  * Thanks to bluestorm on #ocaml for getting these working.
  51  *)
  52 let concat_str_items items =
  53   match items with
  54   | [] -> <:str_item< >>
  55   | x :: xs ->
  56       List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
  57
  58 let concat_sig_items items =
  59   match items with
  60   | [] -> <:sig_item< >>
  61   | x :: xs ->
  62       List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
  63
  64 let concat_record_fields fields =
  65   match fields with
  66     | [] -> assert false
  67     | f :: fs ->
  68         List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
  69
  70 let concat_record_bindings rbs =
  71   match rbs with
  72     | [] -> assert false
  73     | rb :: rbs ->
  74         List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
  75
  76 let build_record rbs =
  77   Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
  78
  79 let build_tuple_from_exprs exprs =
  80   match exprs with
  81   | [] | [_] -> assert false
  82   | x :: xs ->
  83       Ast.ExTup (_loc,
  84                  List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
  85
  86 let ocaml_type_of_field_type = function
  87   | PP.FInteger -> <:ctyp< int64 >>
  88   | PP.FString _ -> <:ctyp< string >>
  89   | PP.FStructPointer _ | PP.FVoidPointer
  90   | PP.FAnonListHeadPointer | PP.FListHeadPointer _ ->
  91       <:ctyp< Virt_mem_mmap.addr >>
  92
  93 let generate_types xs =
  94   let strs = List.map (
  95     fun (struct_name, sflist, cflist) ->
  96       let sflist = List.map (
  97         fun { SC.sf_name = sf_name; sf_fields = fields } ->
  98           if fields <> [] then (
  99             let fields = List.map (
 100               fun { PP.field_name = name; PP.field_type = t } ->
 101                 let t = ocaml_type_of_field_type t in
 102                 <:ctyp< $lid:sf_name^"_"^name$ : $t$ >>
 103             ) fields in
 104             let fields = concat_record_fields fields in
 105
 106             <:str_item<
 107               type $lid:sf_name$ = { $fields$ }
 108             >>
 109           ) else
 110             <:str_item< type $lid:sf_name$ = unit >>
 111       ) sflist in
 112       let sflist = concat_str_items sflist in
 113
 114       let cflist = List.map (
 115         fun { SC.cf_name = cf_name; cf_fields = fields } ->
 116           if fields <> [] then (
 117             let fields = List.map (
 118               fun { PP.field_name = name; PP.field_type = t } ->
 119                 let t = ocaml_type_of_field_type t in
 120                 <:ctyp< $lid:cf_name^"_"^name$ : $t$ >>
 121             ) fields in
 122             let fields = concat_record_fields fields in
 123
 124             <:str_item<
 125               type $lid:cf_name$ = { $fields$ }
 126             >>
 127           ) else
 128             <:str_item< type $lid:cf_name$ = unit >>
 129       ) cflist in
 130       let cflist = concat_str_items cflist in
 131
 132       <:str_item<
 133         type ('a, 'b) $lid:struct_name$ = {
 134           $lid:struct_name^"_shape"$ : 'a;
 135           $lid:struct_name^"_content"$ : 'b;
 136         }
 137         $sflist$
 138         $cflist$
 139       >>
 140   ) xs in
 141
 142   let sigs =
 143     List.map (
 144       fun (struct_name, _, _) ->
 145         <:sig_item<
 146           type ('a, 'b) $lid:struct_name$
 147         >>
 148     ) xs in
 149
 150   concat_str_items strs, concat_sig_items sigs
 151
 152 let generate_parsers xs =
 153   let strs =
 154     List.map (
 155       fun (struct_name, palist) ->
 156         let palist =
 157           List.map (
 158             fun { SC.pa_name = pa_name } ->
 159               <:str_item< let $lid:pa_name$ bits = $str:pa_name$ >>
 160           ) palist in
 161         concat_str_items palist
 162     ) xs in
 163
 164   let strs = concat_str_items strs in
 165   let strs =
 166     <:str_item<
 167       let match_err = "failed to match kernel structure" ;;
 168       let zero = 0 ;;
 169       $strs$
 170     >> in
 171
 172   (* The shared parser functions.
 173    *
 174    * We could include bitmatch statements directly in here, but
 175    * what happens is that the macros get expanded here, resulting
 176    * in (even more) unreadable generated code.  So instead just
 177    * do a textual substitution later by post-processing the
 178    * generated files.  Not type-safe, but we can't have
 179    * everything.
 180    *)
 181   let subs = Hashtbl.create 13 in
 182   List.iter (
 183     fun (struct_name, palist) ->
 184       List.iter (
 185         fun ({ SC.pa_name = pa_name;
 186                pa_endian = endian; pa_structure = structure;
 187                pa_shape_field_struct = sf;
 188                pa_content_field_struct = cf }) ->
 189           (* Generate the code to match this structure. *)
 190           let endian =
 191             match endian with
 192             | Bitstring.LittleEndian -> "littleendian"
 193             | Bitstring.BigEndian -> "bigendian"
 194             | _ -> assert false in
 195           let patterns =
 196             String.concat ";\n      " (
 197               List.map (
 198                 function
 199                 | { PP.field_name = field_name;
 200                     field_type = PP.FInteger;
 201                     field_offset = offset;
 202                     field_size = size } ->
 203                     (* 'zero+' is a hack to force the type to int64. *)
 204                     sprintf "%s : zero+%d : offset(%d), %s"
 205                       field_name (size*8) (offset*8) endian
 206
 207                 | { PP.field_name = field_name;
 208                     field_type = (PP.FStructPointer _
 209                                   | PP.FVoidPointer
 210                                   | PP.FAnonListHeadPointer
 211                                   | PP.FListHeadPointer _);
 212                     field_offset = offset;
 213                     field_size = size } ->
 214                     sprintf "%s : zero+%d : offset(%d), %s"
 215                       field_name (size*8) (offset*8) endian
 216
 217                 | { PP.field_name = field_name;
 218                     field_type = PP.FString width;
 219                     field_offset = offset;
 220                     field_size = size } ->
 221                     sprintf "%s : %d : offset(%d), string"
 222                       field_name (width*8) (offset*8)
 223               ) structure.PP.struct_fields
 224             ) in
 225
 226           let shape_assignments =
 227             List.map (
 228               fun { PP.field_name = field_name;
 229                     field_type = field_type;
 230                     field_offset = offset } ->
 231
 232                 match field_type with
 233                 | PP.FListHeadPointer None ->
 234                     sprintf "%s_%s = Int64.sub %s %dL"
 235                       sf.SC.sf_name field_name field_name offset
 236
 237                 | PP.FListHeadPointer (Some (other_struct_name, other_field_name)) ->
 238                     let other_offset = 666 in
 239                     sprintf "%s_%s = Int64.sub %s %dL"
 240                       sf.SC.sf_name field_name field_name other_offset
 241
 242                 | _ ->
 243                     sprintf "%s_%s = %s" sf.SC.sf_name field_name field_name
 244             ) sf.SC.sf_fields in
 245
 246           let shape_assignments =
 247             String.concat ";\n        " shape_assignments in
 248
 249           let content_assignments =
 250             List.map (
 251               fun { PP.field_name = field_name } ->
 252                 sprintf "%s_%s = %s" sf.SC.sf_name field_name field_name
 253             ) sf.SC.sf_fields in
 254
 255           let content_assignments =
 256             String.concat ";\n        " content_assignments in
 257
 258           let code =
 259             sprintf "
 260   bitmatch bits with
 261   | { %s } ->
 262       let shape =
 263       { %s } in
 264       let content =
 265       { %s } in
 266       { %s_shape = shape; %s_content = content }
 267   | { _ } ->
 268       raise (Virt_mem_types.ParseError (%S, %S, match_err))"
 269               patterns shape_assignments content_assignments
 270               struct_name struct_name
 271               struct_name pa_name in
 272
 273           Hashtbl.add subs pa_name code
 274       ) palist;
 275   ) xs;
 276
 277   strs, <:sig_item< >>, subs
 278
 279 let output_interf ~output_file types parsers =
 280   let sigs = concat_sig_items [ types; parsers ] in
 281   Printers.OCaml.print_interf ~output_file sigs
 282
 283 (* Finally generate the output files. *)
 284 let re_subst = Pcre.regexp "^(.*)\"(\\w+_parser_\\d+)\"(.*)$"
 285
 286 let output_implem ~output_file types parsers parser_subs =
 287   let new_output_file = output_file ^ ".new" in
 288
 289   let strs = concat_str_items [ types; parsers ] in
 290   Printers.OCaml.print_implem ~output_file:new_output_file strs;
 291
 292   (* Substitute the parser bodies in the output file. *)
 293   let ichan = open_in new_output_file in
 294   let ochan = open_out output_file in
 295
 296   output_string ochan "\
 297 (* WARNING: This file and the corresponding mli (interface) are
 298  * automatically generated by the extract/codegen/ program.
 299  *
 300  * Any edits you make to this file will be lost.
 301  *
 302  * To update this file from the latest kernel database, it is recommended
 303  * that you do 'make update-kernel-structs'.
 304  *)\n\n";
 305
 306   let rec loop () =
 307     let line = input_line ichan in
 308     let line =
 309       if Pcre.pmatch ~rex:re_subst line then (
 310         let subs = Pcre.exec ~rex:re_subst line in
 311         let start = Pcre.get_substring subs 1 in
 312         let template = Pcre.get_substring subs 2 in
 313         let rest = Pcre.get_substring subs 3 in
 314         let sub =
 315           try Hashtbl.find parser_subs template
 316           with Not_found -> assert false in
 317         start ^ sub ^ rest
 318       ) else line in
 319     output_string ochan line; output_char ochan '\n';
 320     loop ()
 321   in
 322   (try loop () with End_of_file -> ());
 323
 324   close_out ochan;
 325   close_in ichan;
 326
 327   Unix.unlink new_output_file