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
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 concat_bindings bs =
99 List.fold_left (fun bs b -> <:binding< $bs$ and $b$ >>) b bs
101 let concat_sum_types ts =
105 List.fold_left (fun ts t -> <:ctyp< $ts$ | $t$ >>) t ts
107 let build_record rbs =
108 Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
110 let build_tuple_from_exprs exprs =
112 | [] | [_] -> assert false
115 List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
117 let build_tuple_from_patts patts =
119 | [] | [_] -> assert false
122 List.fold_left (fun xs x -> Ast.PaCom (_loc, x, xs)) x xs)
124 (* Helper functions to store things in a fixed-length tuple very efficiently.
125 * Note that the tuple length must be >= 2.
127 type tuple = string list
129 let tuple_create fields : tuple = fields
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< _ >>
136 let result = build_tuple_from_patts patts in
137 <:expr< let $result$ = $tupleexpr$ in $body$ >>
139 (* Generates '(fieldexpr1, fieldexpr2, ...)'. *)
140 let tuple_generate_construct fieldexprs =
141 build_tuple_from_exprs fieldexprs
143 type code = Ast.str_item * Ast.sig_item
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 >>
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)) ->
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).
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 >> ]
173 let t = ocaml_type_of_field_type (typ, always_available) in
174 [ <:ctyp< $lid:struct_name^"_"^name$ : $t$ >> ]
176 let fields = List.concat fields in
177 let fields = concat_record_fields fields in
180 type $lid:struct_name$ = { $fields$ }
183 type $lid:struct_name$ = { $fields$ }
187 (* Generate a sum-type which can use to store any type of kernel
188 * structure, ie. Task_struct | Net_device | ...
190 let types = types @ [
193 fun (struct_name, _) ->
194 let struct_name_uc = String.capitalize struct_name in
195 <:ctyp< $uid:struct_name_uc$ of $lid:struct_name$ >>
197 let constrs = concat_sum_types constrs in
199 type kernel_struct = $constrs$
202 type kernel_struct = $constrs$
206 let strs, sigs = List.split types in
207 concat_str_items strs, concat_sig_items sigs
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
217 fun (_, (_, all_fields)) ->
222 ((Some (struct_name, field_name)) as f),
231 let fields = sort_uniq fields in
235 fun (struct_name, field_name) ->
237 try List.assoc struct_name xs
240 sprintf "generate_offsets: structure %s not found. This is probably a list_head-related bug."
243 (* Find the offset of this field in each kernel version. *)
246 fun ({ PP.kernel_version = version },
247 { PP.struct_fields = fields }) ->
250 List.find (fun { PP.field_name = name } -> field_name = name)
252 let offset = field.PP.field_offset in
253 Some (version, offset)
254 with Not_found -> None
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
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
271 let $lid:"offset_of_"^struct_name^"_"^field_name$ =
273 fun kernel_version -> StringMap.find kernel_version map
278 let strs = concat_str_items strs in
282 let generate_parsers xs =
285 fun (struct_name, (all_fields, palist)) ->
288 fun { MM.pa_name = pa_name } ->
290 let $lid:pa_name$ kernel_version bits = $str:pa_name$
293 concat_str_items palist
296 let strs = concat_str_items strs in
298 (* The shared parser functions.
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
307 let subs = Hashtbl.create 13 in
309 fun (struct_name, (all_fields, palist)) ->
311 fun ({ MM.pa_name = pa_name;
312 pa_endian = endian; pa_structure = structure }) ->
313 (* Generate the code to match this structure. *)
316 | Bitstring.LittleEndian -> "littleendian"
317 | Bitstring.BigEndian -> "bigendian"
318 | _ -> assert false in
320 String.concat ";\n " (
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
331 | { PP.field_name = field_name;
332 field_type = (PP.FStructPointer _
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
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
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 } ->
358 structure.PP.struct_fields in
360 (* Generate assignment code. List_heads are treated
361 * specially because they have an implicit adjustment.
363 match field_type with
364 | PP.FListHeadPointer None ->
367 %s_%s_adjustment = %d"
368 struct_name field_name field_name
369 struct_name field_name offset
370 struct_name field_name offset
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.
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
387 sprintf "%s_%s = %s" struct_name field_name field_name
389 (* Field is optional. Is it available in this kernel
390 * version? If so, get its offset, else throw Not_found.
393 let { PP.field_offset = offset } =
394 List.find (fun { PP.field_name = name } ->
396 structure.PP.struct_fields in
398 (* Generate assignment code. List_heads are treated
399 * specially because they have an implicit adjustment.
401 match field_type with
402 | PP.FListHeadPointer None ->
403 sprintf "%s_%s = Some %s;
405 %s_%s_adjustment = %d"
406 struct_name field_name field_name
407 struct_name field_name offset
408 struct_name field_name offset
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.
416 sprintf "%s_%s = Some %s;
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
425 sprintf "%s_%s = Some %s"
426 struct_name field_name field_name
429 (* Field is not available in this kernel version. *)
430 match field_type with
431 | PP.FListHeadPointer _ ->
432 sprintf "%s_%s = None;
434 %s_%s_adjustment = -1"
435 struct_name field_name
436 struct_name field_name
437 struct_name field_name
439 sprintf "%s_%s = None" struct_name field_name
443 let assignments = String.concat ";\n " assignments in
451 raise (ParseError (%S, %S, match_err))"
453 struct_name pa_name in
455 Hashtbl.add subs pa_name code
459 (strs, <:sig_item< >>), subs
461 let generate_version_maps xs =
462 (* size_of_<struct> kernel_version *)
463 let strs = List.map (
464 fun (struct_name, (kernels, _)) ->
467 fun ({ PP.kernel_version = version },
468 { PP.struct_total_size = size }) map ->
470 StringMap.add $str:version$ $`int:size$ $map$
472 ) kernels <:expr< StringMap.empty >> in
475 let $lid:"size_of_"^struct_name$ =
477 fun kernel_version ->
478 try StringMap.find kernel_version map
480 unknown_kernel_version kernel_version $str:struct_name$
484 (* parser_of_<struct> kernel_version *)
485 let strs = strs @ List.map (
486 fun (struct_name, (kernels, pahash)) ->
489 fun ({ PP.kernel_version = version }, _) map ->
490 let { MM.pa_name = pa_name } = Hashtbl.find pahash version in
492 StringMap.add $str:version$ $lid:pa_name$ $map$
494 ) kernels <:expr< StringMap.empty >> in
497 let $lid:"parser_of_"^struct_name$ =
499 fun kernel_version ->
500 try StringMap.find kernel_version map
502 unknown_kernel_version kernel_version $str:struct_name$
506 concat_str_items strs, <:sig_item< >>
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 ->
516 | PP.FListHeadPointer None -> true
517 | PP.FListHeadPointer (Some (struct_name, _))
518 | PP.FStructPointer struct_name
519 when List.mem struct_name names -> true
521 if not is_shape_field then rest
523 let dest_struct_name =
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
532 | PP.FListHeadPointer _ ->
535 eprintf "%s_follower: %s: list_head pointing at a %s\n"
536 $str:struct_name$ $str:name$ $str:dest_struct_name$;
538 (* For list head pointers, add the address of the base
539 * of this virtual structure to the map, then adjust
542 let offset = data.$lid:struct_name^"_"^name^"_offset"$
543 and adj = data.$lid:struct_name^"_"^name^"_adjustment"$ in
546 eprintf "%s_follower: %s: offset=%d adjustment=%d\n"
547 $str:struct_name$ $str:name$ offset adj;
549 let offset = Int64.of_int offset
550 and adj = Int64.of_int adj in
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).
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
562 (* 'dest_addr' is the destination address of
563 * this pointer. It needs the usual list_head
564 * adjustment applied.
566 let dest_addr = Int64.sub dest_addr adj in
569 eprintf "%s_follower: %s: dest_addr=%Lx\n"
570 $str:struct_name$ $str:name$ dest_addr;
573 $lid:dest_struct_name^"_follower"$
574 debug kernel_version load map dest_addr in
578 | PP.FStructPointer _ ->
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;
586 $lid:dest_struct_name^"_follower"$
587 debug kernel_version load map dest_addr in
591 | _ -> assert false in
593 if always_available then
595 let dest_addr = data.$lid:struct_name^"_"^name$ in
602 match data.$lid:struct_name^"_"^name$ with
604 | Some dest_addr -> $body$ in
608 ) all_fields <:expr< map >> in
610 let struct_name_uc = String.capitalize struct_name in
613 $lid:struct_name^"_follower"$ debug kernel_version load map addr =
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))
630 let bindings = concat_bindings bindings in
631 let strs = <:str_item< let rec $bindings$ >> in
633 (* Function signatures for the interface. *)
634 let sigs = List.map (
635 fun (struct_name, _) ->
637 val $lid:struct_name^"_follower"$ :
638 bool -> kernel_version -> load_fn -> addrmap -> Virt_mem_mmap.addr ->
642 let sigs = concat_sig_items sigs in
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.
653 type key = Virt_mem_mmap.addr
654 type 'a t = 'a Map.Make(Int64).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
668 exception ParseError of string * string * string ;;
670 type kernel_version = string
673 string -> Virt_mem_mmap.addr -> int -> Bitstring.bitstring
678 (string * (int * Bitstring.bitstring * kernel_struct) option)
683 concat_sig_items [ prologue;
690 Printers.OCaml.print_interf ~output_file sigs;
692 ignore (Sys.command (sprintf "wc -l %s" (Filename.quote output_file)))
694 (* Finally generate the output files. *)
695 let re_subst = Pcre.regexp "^(.*)\"(\\w+_parser_\\d+)\"(.*)$"
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.
705 module StringMap = Map.Make (String) ;;
706 module AddrMap = Map.Make (Int64) ;;
707 exception ParseError of string * string * string ;;
709 let match_err = "failed to match kernel structure"
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"
719 type kernel_version = string
720 type load_fn = string -> Virt_mem_mmap.addr -> int -> Bitstring.bitstring
727 (string * (int * Bitstring.bitstring * kernel_struct) option)
732 concat_str_items [ prologue;
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;
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
748 output_string ochan "\
749 (* WARNING: This file and the corresponding mli (interface) are
750 * automatically generated by the extract/codegen/ program.
752 * Any edits you make to this file will be lost.
754 * To update this file from the latest kernel database, it is recommended
755 * that you do 'make update-kernel-structs'.
759 let line = input_line ichan in
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
767 try Hashtbl.find parser_subs template
768 with Not_found -> assert false in
771 output_string ochan line; output_char ochan '\n';
774 (try loop () with End_of_file -> ());
779 Unix.unlink new_output_file;
781 ignore (Sys.command (sprintf "wc -l %s" (Filename.quote output_file)))