1 (* Memory info command for virtual domains.
2 (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
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.
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.
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.
28 module PP = Pahole_parser
29 module SC = Struct_classify
31 let rec uniq ?(cmp = Pervasives.compare) = function
34 | x :: y :: xs when cmp x y = 0 ->
39 let sort_uniq ?cmp xs =
40 let xs = List.sort ?cmp xs in
41 let xs = uniq ?cmp xs in
44 (* We don't care about locations when generating code, so it's
45 * useful to just have a single global _loc.
49 (* Some handy camlp4 construction functions which do some
50 * things that ought to be easy/obvious but aren't.
52 * 'concat_str_items' concatenates a list of str_item together into
55 * 'concat_record_fields' concatenates a list of records fields into
56 * a record. The list must have at least one element.
58 * 'build_record' builds a record out of record fields.
60 * 'build_tuple_from_exprs' builds an arbitrary length tuple from
61 * a list of expressions of length >= 2.
63 * Thanks to bluestorm on #ocaml for getting these working.
65 let concat_str_items items =
67 | [] -> <:str_item< >>
69 List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
71 let concat_sig_items items =
73 | [] -> <:sig_item< >>
75 List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
77 let concat_exprs exprs =
81 List.fold_left (fun xs x -> <:expr< $xs$ ; $x$ >>) x xs
83 let concat_record_fields fields =
87 List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
89 let concat_record_bindings rbs =
93 List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
95 let build_record rbs =
96 Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
98 let build_tuple_from_exprs exprs =
100 | [] | [_] -> assert false
103 List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
105 let build_tuple_from_patts patts =
107 | [] | [_] -> assert false
110 List.fold_left (fun xs x -> Ast.PaCom (_loc, x, xs)) x xs)
112 type code = Ast.str_item * Ast.sig_item
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 >>
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 (
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).
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 >> ]
140 let t = ocaml_type_of_field_type t in
141 [ <:ctyp< $lid:sf_name^"_"^name$ : $t$ >> ]
143 let fields = List.concat fields in
144 let fields = concat_record_fields fields in
147 type $lid:sf_name$ = { $fields$ }
150 <:str_item< type $lid:sf_name$ = unit >>
152 let sflist = concat_str_items sflist in
154 let cflist = List.map (
155 fun { SC.cf_name = cf_name; cf_fields = fields } ->
156 if fields <> [] then (
157 let fields = List.map (
159 let t = ocaml_type_of_field_type t in
160 <:ctyp< $lid:cf_name^"_"^name$ : $t$ >>
162 let fields = concat_record_fields fields in
165 type $lid:cf_name$ = { $fields$ }
168 <:str_item< type $lid:cf_name$ = unit >>
170 let cflist = concat_str_items cflist in
173 type ('a, 'b) $lid:struct_name$ = 'a * 'b ;;
179 concat_str_items strs, <:sig_item< >>
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
189 fun (_, (_, all_fields)) ->
193 PP.FListHeadPointer ((Some (struct_name, field_name)) as f)) ->
201 let fields = sort_uniq fields in
205 fun (struct_name, field_name) ->
207 try List.assoc struct_name xs
210 sprintf "generate_offsets: structure %s not found. This is probably a list_head-related bug."
213 (* Find the offset of this field in each kernel version. *)
216 fun ({ PP.kernel_version = version },
217 { PP.struct_fields = fields }) ->
220 List.find (fun { PP.field_name = name } -> field_name = name)
222 let offset = field.PP.field_offset in
223 Some (version, offset)
224 with Not_found -> None
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
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
241 let $lid:"offset_of_"^struct_name^"_"^field_name$ =
243 fun kernel_version -> StringMap.find kernel_version map
248 let strs = concat_str_items strs in
252 let generate_parsers xs =
255 fun (struct_name, palist) ->
258 fun { SC.pa_name = pa_name } ->
260 let $lid:pa_name$ kernel_version bits = $str:pa_name$
263 concat_str_items palist
266 let strs = concat_str_items strs in
268 (* The shared parser functions.
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
277 let subs = Hashtbl.create 13 in
279 fun (struct_name, palist) ->
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. *)
288 | Bitstring.LittleEndian -> "littleendian"
289 | Bitstring.BigEndian -> "bigendian"
290 | _ -> assert false in
292 String.concat ";\n " (
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
303 | { PP.field_name = field_name;
304 field_type = (PP.FStructPointer _
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
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
322 let shape_assignments =
324 fun (field_name, field_type) ->
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
331 (* Generate assignment code. List_heads are treated
332 * specially because they have an implicit adjustment.
334 match field_type with
335 | PP.FListHeadPointer None ->
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
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.
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
358 sprintf "%s_%s = %s" sf.SC.sf_name field_name field_name
361 let shape_assignments =
362 if shape_assignments = [] then "()"
364 "{ " ^ String.concat ";\n " shape_assignments ^ " }" in
366 let content_assignments =
368 fun (field_name, _) ->
369 sprintf "%s_%s = %s" cf.SC.cf_name field_name field_name
372 let content_assignments =
373 if content_assignments = [] then "()"
375 "{ " ^ String.concat ";\n " content_assignments ^ " }" in
387 raise (Virt_mem_types.ParseError (%S, %S, match_err))"
388 patterns shape_assignments content_assignments
389 struct_name pa_name in
391 Hashtbl.add subs pa_name code
395 (strs, <:sig_item< >>), subs
397 (* Helper functions to store things in a fixed-length tuple very efficiently.
398 * Note that the tuple length must be >= 2.
400 type tuple = string list
402 let tuple_create fields : tuple = fields
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< _ >>
409 let result = build_tuple_from_patts patts in
410 <:expr< let $result$ = $tupleexpr$ in $body$ >>
412 (* Generates '(fieldexpr1, fieldexpr2, ...)'. *)
413 let tuple_generate_construct fieldexprs =
414 build_tuple_from_exprs fieldexprs
417 | Missing of string | Follower of string | KernelVersion of string
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
423 (* A shape-follow function for every structure/shape. *)
424 let strs = List.map (
425 fun (struct_name, (_, sflist, _, _)) ->
427 fun { SC.sf_name = sf_name; sf_fields = fields } ->
428 let body = List.fold_right (
429 fun (name, typ) body ->
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
438 | PP.FListHeadPointer _ ->
439 tuple_generate_extract follower_tuple follower_name
440 <:patt< f >> <:expr< followers >>
442 (* For list head pointers, add the address of the base
443 * of this virtual structure to the map, then adjust
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
454 Int64.sub shape.$lid:sf_name^"_"^name$ adj in
456 f load followers map out_addr in
460 | PP.FStructPointer _ ->
461 tuple_generate_extract follower_tuple follower_name
462 <:patt< f >> <:expr< followers >>
465 f load followers map shape.$lid:sf_name^"_"^name$ in
470 ) fields <:expr< map >> in
473 let $lid:sf_name^"_follower"$ load followers map addr shape =
478 let strs = List.concat strs in
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.
486 (* Share as much common code as possible to minimize generated
487 * code size and benefit i-cache.
490 let kv_follower kernel_version struct_name total_size
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
504 fun (struct_name, (kernels, _, sfhash, pahash)) ->
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
511 let fname = sprintf "%s_kv%d_follower" struct_name kv_i in
516 $str:version$ $str:struct_name$ $`int:total_size$
517 $lid:pa_name$ $lid:sf_name^"_follower"$
522 let strs = strs @ [ common ] @ List.concat fs in
525 (* A map from kernel versions to follower functions.
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.
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
538 fun si (struct_name, _) ->
539 for i = 0 to nr_kernels - 1 do
540 array.(i).(si+1) <- Missing struct_name
544 fun si (struct_name, (kernels, _, _, _)) ->
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)
553 let array = Array.map (
555 match Array.to_list row with
556 | [] | (Missing _|Follower _) :: _ -> assert false
557 | KernelVersion kernel_version :: followers -> kernel_version, followers
560 let map = List.fold_left (
561 fun map (kernel_version, followers) ->
562 let followers = List.map (
565 <:expr< $lid:fname$ >>
567 (* no follower for this kernel/struct combination *)
568 | Missing struct_name ->
572 Virt_mem_types.ParseError (
573 $str:struct_name$, "follower_map", struct_missing_err
577 | KernelVersion _ -> assert false
579 let followers = tuple_generate_construct followers in
581 <:expr< StringMap.add $str:kernel_version$ $followers$ $map$ >>
582 ) <:expr< StringMap.empty >> (Array.to_list array) in
586 let follower_map = $map$
590 (* Finally a publicly exposed follower function. *)
594 fun (struct_name, (kernels, _, _, _)) ->
595 let fname = sprintf "%s_follower" struct_name in
598 tuple_generate_extract follower_tuple struct_name
599 <:patt< f >> <:expr< followers >>
601 f load followers AddrMap.empty addr
605 let $lid:fname$ kernel_version load addr =
607 try StringMap.find kernel_version follower_map
609 unknown_kernel_version kernel_version $str:struct_name$ in
618 fun (struct_name, _) ->
620 val $lid:struct_name^"_follower"$ :
622 (string -> Virt_mem_mmap.addr -> int -> Bitstring.bitstring) ->
623 Virt_mem_mmap.addr ->
624 (string * int) AddrMap.t
628 concat_str_items strs, concat_sig_items sigs
630 let output_interf ~output_file types offsets parsers followers =
631 (* Some standard code that appears at the top of the interface file. *)
635 type key = Virt_mem_mmap.addr
636 type 'a t = 'a Map.Make(Int64).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
650 type kernel_version = string ;;
654 concat_sig_items [ prologue; types; offsets; parsers; followers ] in
655 Printers.OCaml.print_interf ~output_file sigs;
657 ignore (Sys.command (sprintf "wc -l %s" (Filename.quote output_file)))
659 (* Finally generate the output files. *)
660 let re_subst = Pcre.regexp "^(.*)\"(\\w+_parser_\\d+)\"(.*)$"
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. *)
667 module StringMap = Map.Make (String) ;;
668 module AddrMap = Map.Make (Int64) ;;
669 type kernel_version = string ;;
671 let match_err = "failed to match kernel structure" ;;
672 let struct_missing_err = "struct does not exist in this kernel version" ;;
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) ;;
686 concat_str_items [ prologue; types; offsets; parsers; followers ] in
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;
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
696 output_string ochan "\
697 (* WARNING: This file and the corresponding mli (interface) are
698 * automatically generated by the extract/codegen/ program.
700 * Any edits you make to this file will be lost.
702 * To update this file from the latest kernel database, it is recommended
703 * that you do 'make update-kernel-structs'.
707 let line = input_line ichan in
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
715 try Hashtbl.find parser_subs template
716 with Not_found -> assert false in
719 output_string ochan line; output_char ochan '\n';
722 (try loop () with End_of_file -> ());
727 Unix.unlink new_output_file;
729 ignore (Sys.command (sprintf "wc -l %s" (Filename.quote output_file)))