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_exprs exprs =
  78   match exprs with
  79   | [] -> assert false
  80   | x :: xs ->
  81       List.fold_left (fun xs x -> <:expr< $xs$ ; $x$ >>) x xs
  82
  83 let concat_record_fields fields =
  84   match fields with
  85     | [] -> assert false
  86     | f :: fs ->
  87         List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
  88
  89 let concat_record_bindings rbs =
  90   match rbs with
  91     | [] -> assert false
  92     | rb :: rbs ->
  93         List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
  94
  95 let build_record rbs =
  96   Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
  97
  98 let build_tuple_from_exprs exprs =
  99   match exprs with
 100   | [] | [_] -> assert false
 101   | x :: xs ->
 102       Ast.ExTup (_loc,
 103                  List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
 104
 105 let build_tuple_from_patts patts =
 106   match patts with
 107   | [] | [_] -> assert false
 108   | x :: xs ->
 109       Ast.PaTup (_loc,
 110                  List.fold_left (fun xs x -> Ast.PaCom (_loc, x, xs)) x xs)
 111
 112 type code = Ast.str_item * Ast.sig_item
 113
 114 let ocaml_type_of_field_type = function
 115   | PP.FInteger -> <:ctyp< int64 >>
 116   | PP.FString _ -> <:ctyp< string >>
 117   | PP.FStructPointer _ | PP.FVoidPointer
 118   | PP.FAnonListHeadPointer | PP.FListHeadPointer _ ->
 119       <:ctyp< Virt_mem_mmap.addr >>
 120
 121 let generate_types xs =
 122   let strs = List.map (
 123     fun (struct_name, sflist, cflist) ->
 124       let sflist = List.map (
 125         fun { SC.sf_name = sf_name; sf_fields = fields } ->
 126           if fields <> [] then (
 127             let fields = List.map (
 128               fun (name, t) ->
 129                 match t with
 130                 | PP.FListHeadPointer _ ->
 131                     (* A list head turns into three fields, the pointer,
 132                      * the offset within current struct, and the adjustment
 133                      * (offset within destination struct).
 134                      *)
 135                     let t = ocaml_type_of_field_type t in
 136                     [ <:ctyp< $lid:sf_name^"_"^name$ : $t$ >>;
 137                       <:ctyp< $lid:sf_name^"_"^name^"_offset"$ : int >>;
 138                       <:ctyp< $lid:sf_name^"_"^name^"_adjustment"$ : int >> ]
 139                 | _ ->
 140                     let t = ocaml_type_of_field_type t in
 141                     [ <:ctyp< $lid:sf_name^"_"^name$ : $t$ >> ]
 142             ) fields in
 143             let fields = List.concat fields in
 144             let fields = concat_record_fields fields in
 145
 146             <:str_item<
 147               type $lid:sf_name$ = { $fields$ }
 148             >>
 149           ) else
 150             <:str_item< type $lid:sf_name$ = unit >>
 151       ) sflist in
 152       let sflist = concat_str_items sflist in
 153
 154       let cflist = List.map (
 155         fun { SC.cf_name = cf_name; cf_fields = fields } ->
 156           if fields <> [] then (
 157             let fields = List.map (
 158               fun (name, t) ->
 159                 let t = ocaml_type_of_field_type t in
 160                 <:ctyp< $lid:cf_name^"_"^name$ : $t$ >>
 161             ) fields in
 162             let fields = concat_record_fields fields in
 163
 164             <:str_item<
 165               type $lid:cf_name$ = { $fields$ }
 166             >>
 167           ) else
 168             <:str_item< type $lid:cf_name$ = unit >>
 169       ) cflist in
 170       let cflist = concat_str_items cflist in
 171
 172       <:str_item<
 173         type ('a, 'b) $lid:struct_name$ = 'a * 'b ;;
 174         $sflist$
 175         $cflist$
 176       >>
 177   ) xs in
 178
 179   concat_str_items strs, <:sig_item< >>
 180
 181 let generate_offsets xs =
 182   (* Only need to generate the offset_of_* functions for fields
 183    * which are cross-referenced from another field.  Which
 184    * ones are those?
 185    *)
 186   let fields =
 187     List.concat (
 188       List.map (
 189         fun (_, (_, all_fields)) ->
 190           List.filter_map (
 191             function
 192             | (_,
 193                PP.FListHeadPointer ((Some (struct_name, field_name)) as f)) ->
 194                 f
 195             | _ ->
 196                 None
 197           ) all_fields
 198       ) xs
 199     ) in
 200
 201   let fields = sort_uniq fields in
 202
 203   let strs =
 204     List.map (
 205       fun (struct_name, field_name) ->
 206         let kernels, _ =
 207           try List.assoc struct_name xs
 208           with Not_found ->
 209             failwith (
 210               sprintf "generate_offsets: structure %s not found. This is probably a list_head-related bug."
 211                 struct_name
 212             ) in
 213         (* Find the offset of this field in each kernel version. *)
 214         let offsets =
 215           List.filter_map (
 216             fun ({ PP.kernel_version = version },
 217                  { PP.struct_fields = fields }) ->
 218               try
 219                 let field =
 220                   List.find (fun { PP.field_name = name } -> field_name = name)
 221                     fields in
 222                 let offset = field.PP.field_offset in
 223                 Some (version, offset)
 224               with Not_found -> None
 225           ) kernels in
 226
 227         if offsets = [] then
 228           failwith (
 229             sprintf "generate_offsets: field %s.%s not found in any kernel. This is probably a list_head-related bug."
 230               struct_name field_name
 231           );
 232
 233         (* Generate a map of kernel version to offset. *)
 234         let map = List.fold_left (
 235           fun map (version, offset) ->
 236             <:expr< StringMap.add $str:version$ $`int:offset$ $map$ >>
 237         ) <:expr< StringMap.empty >> offsets in
 238
 239         let code =
 240           <:str_item<
 241             let $lid:"offset_of_"^struct_name^"_"^field_name$ =
 242               let map = $map$ in
 243               fun kernel_version -> StringMap.find kernel_version map
 244           >> in
 245         code
 246     ) fields in
 247
 248   let strs = concat_str_items strs in
 249
 250   strs, <:sig_item< >>
 251
 252 let generate_parsers xs =
 253   let strs =
 254     List.map (
 255       fun (struct_name, palist) ->
 256         let palist =
 257           List.map (
 258             fun { SC.pa_name = pa_name } ->
 259               <:str_item<
 260                 let $lid:pa_name$ kernel_version bits = $str:pa_name$
 261               >>
 262           ) palist in
 263         concat_str_items palist
 264     ) xs in
 265
 266   let strs = concat_str_items strs in
 267
 268   (* The shared parser functions.
 269    *
 270    * We could include bitmatch statements directly in here, but
 271    * what happens is that the macros get expanded here, resulting
 272    * in (even more) unreadable generated code.  So instead just
 273    * do a textual substitution later by post-processing the
 274    * generated files.  Not type-safe, but we can't have
 275    * everything.
 276    *)
 277   let subs = Hashtbl.create 13 in
 278   List.iter (
 279     fun (struct_name, palist) ->
 280       List.iter (
 281         fun ({ SC.pa_name = pa_name;
 282                pa_endian = endian; pa_structure = structure;
 283                pa_shape_field_struct = sf;
 284                pa_content_field_struct = cf }) ->
 285           (* Generate the code to match this structure. *)
 286           let endian =
 287             match endian with
 288             | Bitstring.LittleEndian -> "littleendian"
 289             | Bitstring.BigEndian -> "bigendian"
 290             | _ -> assert false in
 291           let patterns =
 292             String.concat ";\n      " (
 293               List.map (
 294                 function
 295                 | { PP.field_name = field_name;
 296                     field_type = PP.FInteger;
 297                     field_offset = offset;
 298                     field_size = size } ->
 299                     (* 'zero+' is a hack to force the type to int64. *)
 300                     sprintf "%s : zero+%d : offset(%d), %s"
 301                       field_name (size*8) (offset*8) endian
 302
 303                 | { PP.field_name = field_name;
 304                     field_type = (PP.FStructPointer _
 305                                   | PP.FVoidPointer
 306                                   | PP.FAnonListHeadPointer
 307                                   | PP.FListHeadPointer _);
 308                     field_offset = offset;
 309                     field_size = size } ->
 310                     sprintf "%s : zero+%d : offset(%d), %s"
 311                       field_name (size*8) (offset*8) endian
 312
 313                 | { PP.field_name = field_name;
 314                     field_type = PP.FString width;
 315                     field_offset = offset;
 316                     field_size = size } ->
 317                     sprintf "%s : %d : offset(%d), string"
 318                       field_name (width*8) (offset*8)
 319               ) structure.PP.struct_fields
 320             ) in
 321
 322           let shape_assignments =
 323             List.map (
 324               fun (field_name, field_type) ->
 325
 326                 (* Go and look up the field offset in the correct kernel. *)
 327                 let { PP.field_offset = offset } =
 328                   List.find (fun { PP.field_name = name } -> field_name = name)
 329                     structure.PP.struct_fields in
 330
 331                 (* Generate assignment code.  List_heads are treated
 332                  * specially because they have an implicit adjustment.
 333                  *)
 334                 match field_type with
 335                 | PP.FListHeadPointer None ->
 336                     sprintf "%s_%s = %s;
 337           %s_%s_offset = %d;
 338           %s_%s_adjustment = %d"
 339                       sf.SC.sf_name field_name field_name
 340                       sf.SC.sf_name field_name offset
 341                       sf.SC.sf_name field_name offset
 342
 343                 | PP.FListHeadPointer (Some (other_struct_name,
 344                                              other_field_name)) ->
 345                     (* A reference to a field in another structure.  We don't
 346                      * know the offset until runtime, so we have to call
 347                      * offset_of_<struct>_<field> to find it.
 348                      *)
 349                     sprintf "%s_%s = %s;
 350           %s_%s_offset = %d;
 351           %s_%s_adjustment = offset_of_%s_%s kernel_version"
 352                       sf.SC.sf_name field_name field_name
 353                       sf.SC.sf_name field_name offset (* in this struct *)
 354                       sf.SC.sf_name field_name        (* ... & in other struct*)
 355                         other_struct_name other_field_name
 356
 357                 | _ ->
 358                     sprintf "%s_%s = %s" sf.SC.sf_name field_name field_name
 359             ) sf.SC.sf_fields in
 360
 361           let shape_assignments =
 362             if shape_assignments = [] then "()"
 363             else
 364               "{ " ^ String.concat ";\n        " shape_assignments ^ " }" in
 365
 366           let content_assignments =
 367             List.map (
 368               fun (field_name, _) ->
 369                 sprintf "%s_%s = %s" cf.SC.cf_name field_name field_name
 370             ) cf.SC.cf_fields in
 371
 372           let content_assignments =
 373             if content_assignments = [] then "()"
 374             else
 375               "{ " ^ String.concat ";\n        " content_assignments ^ " }" in
 376
 377           let code =
 378             sprintf "
 379   bitmatch bits with
 380   | { %s } ->
 381       let s =
 382       %s in
 383       let c =
 384       %s in
 385       (s, c)
 386   | { _ } ->
 387       raise (Virt_mem_types.ParseError (%S, %S, match_err))"
 388               patterns shape_assignments content_assignments
 389               struct_name pa_name in
 390
 391           Hashtbl.add subs pa_name code
 392       ) palist;
 393   ) xs;
 394
 395   (strs, <:sig_item< >>), subs
 396
 397 (* Helper functions to store things in a fixed-length tuple very efficiently.
 398  * Note that the tuple length must be >= 2.
 399  *)
 400 type tuple = string list
 401
 402 let tuple_create fields : tuple = fields
 403
 404 (* Generates 'let _, _, resultpatt, _ = tupleexpr in body'. *)
 405 let tuple_generate_extract fields field resultpatt tupleexpr body =
 406   let patts = List.map (
 407     fun name -> if name = field then resultpatt else <:patt< _ >>
 408   ) fields in
 409   let result = build_tuple_from_patts patts in
 410   <:expr< let $result$ = $tupleexpr$ in $body$ >>
 411
 412 (* Generates '(fieldexpr1, fieldexpr2, ...)'. *)
 413 let tuple_generate_construct fieldexprs =
 414   build_tuple_from_exprs fieldexprs
 415
 416 type follower_t =
 417   | Missing of string | Follower of string | KernelVersion of string
 418
 419 let generate_followers xs =
 420   (* Tuple of follower functions, just a list of struct_names. *)
 421   let follower_tuple = tuple_create (List.map fst xs) in
 422
 423   (* A shape-follow function for every structure/shape. *)
 424   let strs = List.map (
 425     fun (struct_name, (_, sflist, _, _)) ->
 426       List.map (
 427         fun { SC.sf_name = sf_name; sf_fields = fields } ->
 428           let body = List.fold_right (
 429             fun (name, typ) body ->
 430               let follower_name =
 431                 match typ with
 432                 | PP.FListHeadPointer None -> struct_name
 433                 | PP.FListHeadPointer (Some (struct_name, _)) -> struct_name
 434                 | PP.FStructPointer struct_name -> struct_name
 435                 | _ -> assert false in
 436
 437               match typ with
 438               | PP.FListHeadPointer _ ->
 439                   tuple_generate_extract follower_tuple follower_name
 440                   <:patt< f >> <:expr< followers >>
 441                   <:expr<
 442                     (* For list head pointers, add the address of the base
 443                      * of this virtual structure to the map, then adjust
 444                      * the pointer.
 445                      *)
 446                     let offset = shape.$lid:sf_name^"_"^name^"_offset"$
 447                     and adj = shape.$lid:sf_name^"_"^name^"_adjustment"$ in
 448                     let offset = Int64.of_int offset
 449                     and adj = Int64.of_int adj in
 450                     (* 'addr' is base of the virtual struct *)
 451                     let addr = Int64.sub (Int64.add addr offset) adj in
 452                     let map = AddrMap.add addr ($str:follower_name$, 0) map in
 453                     let out_addr =
 454                       Int64.sub shape.$lid:sf_name^"_"^name$ adj in
 455                     let map =
 456                       f load followers map out_addr in
 457                     $body$
 458                   >>
 459
 460               | PP.FStructPointer _ ->
 461                   tuple_generate_extract follower_tuple follower_name
 462                   <:patt< f >> <:expr< followers >>
 463                   <:expr<
 464                     let map =
 465                       f load followers map shape.$lid:sf_name^"_"^name$ in
 466                     $body$
 467                   >>
 468
 469               | _ -> assert false
 470           ) fields <:expr< map >> in
 471
 472           <:str_item<
 473             let $lid:sf_name^"_follower"$ load followers map addr shape =
 474               $body$
 475           >>
 476       ) sflist
 477   ) xs in
 478   let strs = List.concat strs in
 479
 480   (* A follower function for every kernel version / structure.  When this
 481    * function is called starting at some known root, it will load every
 482    * reachable kernel structure.
 483    *)
 484   let strs =
 485     let common =
 486       (* Share as much common code as possible to minimize generated
 487        * code size and benefit i-cache.
 488        *)
 489       <:str_item<
 490         let kv_follower kernel_version struct_name total_size
 491             parserfn followerfn
 492             load followers map addr =
 493           if addr <> 0L && not (AddrMap.mem addr map) then (
 494             let map = AddrMap.add addr (struct_name, total_size) map in
 495             let bits = load struct_name addr total_size in
 496             let shape, _ = parserfn kernel_version bits in
 497             followerfn load followers map addr shape
 498           )
 499           else map
 500       >> in
 501
 502     let fs =
 503       List.map (
 504         fun (struct_name, (kernels, _, sfhash, pahash)) ->
 505           List.map (
 506             fun ({ PP.kernel_version = version; kv_i = kv_i },
 507                  { PP.struct_total_size = total_size }) ->
 508               let { SC.pa_name = pa_name } = Hashtbl.find pahash version in
 509               let { SC.sf_name = sf_name } = Hashtbl.find sfhash version in
 510
 511               let fname = sprintf "%s_kv%d_follower" struct_name kv_i in
 512
 513               <:str_item<
 514                 let $lid:fname$ =
 515                   kv_follower
 516                     $str:version$ $str:struct_name$ $`int:total_size$
 517                     $lid:pa_name$ $lid:sf_name^"_follower"$
 518               >>
 519           ) kernels
 520       ) xs in
 521
 522     let strs = strs @ [ common ] @ List.concat fs in
 523     strs in
 524
 525   (* A map from kernel versions to follower functions.
 526    *
 527    * For each struct, we have a list of kernel versions which contain
 528    * that struct.  Some kernels are missing a particular struct, so
 529    * that is turned into a ParseError exception.
 530    *)
 531   let strs =
 532     let nr_kernels =
 533       List.fold_left max 0
 534         (List.map (fun (_, (kernels, _, _, _)) -> List.length kernels) xs) in
 535     let nr_structs = List.length xs in
 536     let array = Array.make_matrix nr_kernels (nr_structs+1) (Missing "") in
 537     List.iteri (
 538       fun si (struct_name, _) ->
 539         for i = 0 to nr_kernels - 1 do
 540           array.(i).(si+1) <- Missing struct_name
 541         done
 542     ) xs;
 543     List.iteri (
 544       fun si (struct_name, (kernels, _, _, _)) ->
 545         List.iter (
 546           fun ({ PP.kernel_version = version; kv_i = kv_i }, _) ->
 547             array.(kv_i).(0) <- KernelVersion version;
 548             array.(kv_i).(si+1) <-
 549               Follower (sprintf "%s_kv%d_follower" struct_name kv_i)
 550         ) kernels
 551     ) xs;
 552
 553     let array = Array.map (
 554       fun row ->
 555         match Array.to_list row with
 556         | [] | (Missing _|Follower _) :: _ -> assert false
 557         | KernelVersion kernel_version :: followers -> kernel_version, followers
 558     ) array in
 559
 560     let map = List.fold_left (
 561       fun map (kernel_version, followers) ->
 562         let followers = List.map (
 563           function
 564           | Follower fname ->
 565               <:expr< $lid:fname$ >>
 566
 567           (* no follower for this kernel/struct combination *)
 568           | Missing struct_name ->
 569               <:expr<
 570                 fun _ _ _ _ ->
 571                   raise (
 572                     Virt_mem_types.ParseError (
 573                       $str:struct_name$, "follower_map", struct_missing_err
 574                     )
 575                   )
 576               >>
 577           | KernelVersion _ -> assert false
 578         ) followers in
 579         let followers = tuple_generate_construct followers in
 580
 581         <:expr< StringMap.add $str:kernel_version$ $followers$ $map$ >>
 582     ) <:expr< StringMap.empty >> (Array.to_list array) in
 583
 584     let str =
 585       <:str_item<
 586         let follower_map = $map$
 587       >> in
 588     strs @ [ str ] in
 589
 590   (* Finally a publicly exposed follower function. *)
 591   let strs =
 592     let fs =
 593       List.map (
 594         fun (struct_name, (kernels, _, _, _)) ->
 595           let fname = sprintf "%s_follower" struct_name in
 596
 597           let body =
 598             tuple_generate_extract follower_tuple struct_name
 599               <:patt< f >> <:expr< followers >>
 600               <:expr<
 601                 f load followers AddrMap.empty addr
 602               >> in
 603
 604           <:str_item<
 605             let $lid:fname$ kernel_version load addr =
 606               let followers =
 607                 try StringMap.find kernel_version follower_map
 608                 with Not_found ->
 609                   unknown_kernel_version kernel_version $str:struct_name$ in
 610               $body$
 611           >>
 612       ) xs in
 613
 614     strs @ fs in
 615
 616   let sigs =
 617     List.map (
 618       fun (struct_name, _) ->
 619         <:sig_item<
 620           val $lid:struct_name^"_follower"$ :
 621             kernel_version ->
 622             (string -> Virt_mem_mmap.addr -> int -> Bitstring.bitstring) ->
 623             Virt_mem_mmap.addr ->
 624             (string * int) AddrMap.t
 625           >>
 626     ) xs in
 627
 628   concat_str_items strs, concat_sig_items sigs
 629
 630 let output_interf ~output_file types offsets parsers followers =
 631   (* Some standard code that appears at the top of the interface file. *)
 632   let prologue =
 633     <:sig_item<
 634       module AddrMap : sig
 635         type key = Virt_mem_mmap.addr
 636         type 'a t = 'a Map.Make(Int64).t
 637         val empty : 'a t
 638         val is_empty : 'a t -> bool
 639         val add : key -> 'a -> 'a t -> 'a t
 640         val find : key -> 'a t -> 'a
 641         val remove : key -> 'a t -> 'a t
 642         val mem : key -> 'a t -> bool
 643         val iter : (key -> 'a -> unit) -> 'a t -> unit
 644         val map : ('a -> 'b) -> 'a t -> 'b t
 645         val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
 646         val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
 647         val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
 648         val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
 649       end ;;
 650       type kernel_version = string ;;
 651     >> in
 652
 653   let sigs =
 654     concat_sig_items [ prologue; types; offsets; parsers; followers ] in
 655   Printers.OCaml.print_interf ~output_file sigs;
 656
 657   ignore (Sys.command (sprintf "wc -l %s" (Filename.quote output_file)))
 658
 659 (* Finally generate the output files. *)
 660 let re_subst = Pcre.regexp "^(.*)\"(\\w+_parser_\\d+)\"(.*)$"
 661
 662 let output_implem ~output_file types offsets parsers parser_subs followers =
 663   (* Some standard code that appears at the top of the implementation file. *)
 664   let prologue =
 665     <:str_item<
 666       open Printf ;;
 667       module StringMap = Map.Make (String) ;;
 668       module AddrMap = Map.Make (Int64) ;;
 669       type kernel_version = string ;;
 670
 671       let match_err = "failed to match kernel structure" ;;
 672       let struct_missing_err = "struct does not exist in this kernel version" ;;
 673
 674       let unknown_kernel_version version struct_name =
 675         invalid_arg (Printf.sprintf "%s: unknown kernel version or
 676 struct %s is not supported in this kernel.
 677 Try a newer version of virt-mem, or if the guest is not from a
 678 supported Linux distribution, see this page about adding support:
 679   http://et.redhat.com/~rjones/virt-mem/faq.html\n"
 680                        version struct_name) ;;
 681
 682       let zero = 0 ;;
 683     >> in
 684
 685   let strs =
 686     concat_str_items [ prologue; types; offsets; parsers; followers ] in
 687
 688   (* Write the new implementation to .ml.new file. *)
 689   let new_output_file = output_file ^ ".new" in
 690   Printers.OCaml.print_implem ~output_file:new_output_file strs;
 691
 692   (* Substitute the parser bodies in the output file. *)
 693   let ichan = open_in new_output_file in
 694   let ochan = open_out output_file in
 695
 696   output_string ochan "\
 697 (* WARNING: This file and the corresponding mli (interface) are
 698  * automatically generated by the extract/codegen/ program.
 699  *
 700  * Any edits you make to this file will be lost.
 701  *
 702  * To update this file from the latest kernel database, it is recommended
 703  * that you do 'make update-kernel-structs'.
 704  *)\n\n";
 705
 706   let rec loop () =
 707     let line = input_line ichan in
 708     let line =
 709       if Pcre.pmatch ~rex:re_subst line then (
 710         let subs = Pcre.exec ~rex:re_subst line in
 711         let start = Pcre.get_substring subs 1 in
 712         let template = Pcre.get_substring subs 2 in
 713         let rest = Pcre.get_substring subs 3 in
 714         let sub =
 715           try Hashtbl.find parser_subs template
 716           with Not_found -> assert false in
 717         start ^ sub ^ rest
 718       ) else line in
 719     output_string ochan line; output_char ochan '\n';
 720     loop ()
 721   in
 722   (try loop () with End_of_file -> ());
 723
 724   close_out ochan;
 725   close_in ichan;
 726
 727   Unix.unlink new_output_file;
 728
 729   ignore (Sys.command (sprintf "wc -l %s" (Filename.quote output_file)))