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