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.
25 let (//) = Filename.concat
27 type pathname = string
31 kernel_version : string;
38 struct_total_size : int;
39 struct_fields : field list;
50 | FStructPointer of string
52 | FAnonListHeadPointer
53 | FListHeadPointer of (string * string) option
57 let string_of_info i =
58 sprintf "%s: %s (%d) %s" i.basename i.kernel_version i.kv_i i.arch
60 let rec string_of_structure s =
61 let fields = List.map string_of_field s.struct_fields in
62 let fields = String.concat "\n " fields in
63 sprintf "struct %s {\n %s\n}; /* total size = %d bytes */"
64 s.struct_name fields s.struct_total_size
66 and string_of_field f =
67 sprintf "%s %s; /* offset = %d, size = %d */"
68 (string_of_f_type f.field_type) f.field_name
69 f.field_offset f.field_size
71 and string_of_f_type = function
72 | FStructPointer struct_name -> sprintf "struct %s *" struct_name
73 | FVoidPointer -> "void *"
74 | FAnonListHeadPointer -> "struct list_head *"
75 | FListHeadPointer None ->
76 sprintf "struct /* self */ list_head *"
77 | FListHeadPointer (Some (struct_name, field_name)) ->
78 sprintf "struct /* to %s.%s */ list_head *" struct_name field_name
80 | FString width -> sprintf "char[%d]" width
82 let file_exists name =
83 try Unix.access name [Unix.F_OK]; true
84 with Unix.Unix_error _ -> false
86 (* Regular expressions. We really really should use ocaml-mikmatch ... *)
87 let re_oldformat = Pcre.regexp "^RPM: \\d+: \\(build \\d+\\) ([-\\w]+) ([\\w.]+) ([\\w.]+) \\(.*?\\) (\\w+)"
88 let re_keyvalue = Pcre.regexp "^(\\w+): (.*)"
90 let list_kernels path =
91 (* Get the *.info files from the kernels database. *)
92 let infos = Sys.readdir path in
93 let infos = Array.to_list infos in
94 let infos = List.filter (fun name -> String.ends_with name ".info") infos in
95 let infos = List.map ( (//) path) infos in
97 (* Parse in the *.info files. These have historically had a few different
98 * formats that we need to support.
100 let infos = List.mapi (
102 (* Get the basename (for getting the .data file later on). *)
103 let basename = Filename.chop_suffix filename ".info" in
105 let chan = open_in filename in
106 let line = input_line chan in
108 (* Kernel version string. *)
110 if Pcre.pmatch ~rex:re_oldformat line then (
111 (* If the file starts with "RPM: \d+: ..." then it's the
112 * original Fedora format. Everything in one line.
114 let subs = Pcre.exec ~rex:re_oldformat line in
115 (* let name = Pcre.get_substring subs 1 in *)
116 let version = Pcre.get_substring subs 2 in
117 let release = Pcre.get_substring subs 3 in
118 let arch = Pcre.get_substring subs 4 in
120 (* XXX Map name -> PAE, hugemem etc. *)
121 (* name, *) sprintf "%s-%s.%s" version release arch, arch
123 (* New-style "key: value" entries, up to end of file or the first
126 let (*name,*) version, release, arch =
127 (*ref "",*) ref "", ref "", ref "" in
130 let subs = Pcre.exec ~rex:re_keyvalue line in
131 let key = Pcre.get_substring subs 1 in
132 let value = Pcre.get_substring subs 2 in
133 (*if key = "Name" then name := value
134 else*) if key = "Version" then version := value
135 else if key = "Release" then release := value
136 else if key = "Architecture" then arch := value;
137 let line = input_line chan in
140 Not_found | End_of_file ->
144 let (*name,*) version, release, arch =
145 (*!name,*) !version, !release, !arch in
146 if (*name = "" ||*) version = "" || release = "" || arch = "" then
147 failwith (sprintf "%s: missing Name, Version, Release or Architecture key" filename);
148 (* XXX Map name -> PAE, hugemem etc. *)
149 (* name, *) sprintf "%s-%s.%s" version release arch, arch
152 (*printf "%s -> %s %s\n%!" basename version arch;*)
155 basename = basename; arch = arch;
156 kernel_version = version }
159 (* Check the .data, .data.gz or .data.bz2 file exists, and skip with
162 let infos = List.filter (
163 fun { basename = basename } ->
164 if not (file_exists (basename ^ ".data")) &&
165 not (file_exists (basename ^ ".data.gz")) &&
166 not (file_exists (basename ^ ".data.bz2")) then (
167 eprintf "warning: %s: no data file found for this kernel - skipping\n%!"
177 (* XXX This would be better as a proper lex/yacc parser.
178 * XXX Even better would be to have a proper interface to libdwarves.
180 let re_offsetsize = Pcre.regexp "/\\*\\s+(\\d+)\\s+(\\d+)\\s+\\*/"
181 let re_intfield = Pcre.regexp "(?:int|char)\\s+(\\w+);"
182 let re_ptrfield = Pcre.regexp "struct\\s+(\\w+)\\s*\\*\\s*(\\w+);"
183 let re_voidptrfield = Pcre.regexp "void\\s*\\*\\s*(\\w+);"
184 let re_strfield = Pcre.regexp "char\\s+(\\w+)\\[(\\d+)\\];"
185 let re_structopener = Pcre.regexp "(struct|union)\\s+.*{$"
186 let re_structcloser = Pcre.regexp "}\\s*(\\w+)?(\\[\\d+\\])?;"
188 let load_structures { basename = basename } struct_names =
189 (* For quick access to the opener strings, build a hash. *)
190 let openers = Hashtbl.create 13 in
193 let opener = sprintf "struct %s {" struct_name in
195 Hashtbl.add openers opener (closer, struct_name)
198 (* Now read the data file and parse out the structures of interest. *)
199 let close_process_in cmd chan =
200 match Unix.close_process_in chan with
201 | Unix.WEXITED 0 -> ()
203 eprintf "%s: command exited with code %d\n" cmd i; exit i
204 | Unix.WSIGNALED i ->
205 eprintf "%s: command exited with signal %d\n" cmd i; exit 1
207 eprintf "%s: command stopped by signal %d\n" cmd i; exit 1
210 (* Open the data file, uncompressing it on the fly if necessary. *)
212 if file_exists (basename ^ ".data") then
213 open_in (basename ^ ".data"), close_in
214 else if file_exists (basename ^ ".data.gz") then (
216 sprintf "gzip -cd %s" (Filename.quote (basename ^ ".data.gz")) in
217 Unix.open_process_in cmd, close_process_in cmd
219 else if file_exists (basename ^ ".data.bz2") then (
221 sprintf "bzip2 -cd %s" (Filename.quote (basename ^ ".data.bz2")) in
222 Unix.open_process_in cmd, close_process_in cmd
224 failwith (sprintf "%s: cannot find corresponding data file" basename) in
226 (* Read the data file in, looking for structures of interest to us. *)
227 let bodies = Hashtbl.create 13 in
229 let line = input_line chan in
231 (* If the line is an opener for one of the structures we
232 * are looking for, then for now just save all the text until
233 * we get to the closer line.
236 let closer, struct_name = Hashtbl.find openers line in
237 let rec loop2 lines =
238 let line = input_line chan in
239 let lines = line :: lines in
240 if String.starts_with line closer then List.rev lines
247 failwith (sprintf "%s: %s: %S not matched by closing %S" basename struct_name line closer) in
249 Hashtbl.replace bodies struct_name body
250 with Not_found -> ());
254 (try loop () with End_of_file -> ());
258 (* Now parse each structure body. *)
260 (* 'basename' is the source file, and second parameter ('body') is
261 * the list of text lines which covers this structure (minus the
262 * opener line). Result is the list of parsed fields from this
265 let rec parse basename = function
267 | [_] -> [] (* Just the closer line, finished. *)
268 | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
269 (* Recursively parse a sub-structure. First search for the
270 * corresponding closer line.
272 let rec loop depth acc = function
274 eprintf "%s: %S has no matching close structure line\n%!"
277 | line :: lines when Pcre.pmatch ~rex:re_structopener line ->
278 loop (depth+1) (line :: acc) lines
280 when depth = 0 && Pcre.pmatch ~rex:re_structcloser line ->
283 when depth > 0 && Pcre.pmatch ~rex:re_structcloser line ->
284 loop (depth-1) (line :: acc) lines
285 | line :: lines -> loop depth (line :: acc) lines
287 let nested_body, rest = loop 0 [] lines in
289 (* Then parse the sub-structure. *)
290 let struct_name, nested_body =
291 match nested_body with
294 let subs = Pcre.exec ~rex:re_structcloser closer in
296 try Some (Pcre.get_substring subs 1) with Not_found -> None in
297 struct_name, List.rev nested_body in
298 let nested_fields = parse basename nested_body in
300 (* Prefix the sub-fields with the name of the structure. *)
302 match struct_name with
303 | None -> nested_fields
306 fun ({ field_name = name } as field) ->
307 let name = prefix ^ "'" ^ name in
308 { field with field_name = name }
311 (* Parse the rest. *)
312 nested_fields @ parse basename rest
314 | line :: lines when Pcre.pmatch ~rex:re_intfield line ->
316 let subs = Pcre.exec ~rex:re_intfield line in
317 let name = Pcre.get_substring subs 1 in
319 let subs = Pcre.exec ~rex:re_offsetsize line in
320 let offset = int_of_string (Pcre.get_substring subs 1) in
321 let size = int_of_string (Pcre.get_substring subs 2) in
323 { field_name = name; field_type = FInteger;
324 field_offset = offset; field_size = size } in
325 field :: parse basename lines
327 Not_found -> parse basename lines
330 | line :: lines when Pcre.pmatch ~rex:re_ptrfield line ->
331 (* A pointer-to-struct field. *)
332 let subs = Pcre.exec ~rex:re_ptrfield line in
333 let struct_name = Pcre.get_substring subs 1 in
334 let name = Pcre.get_substring subs 2 in
336 let subs = Pcre.exec ~rex:re_offsetsize line in
337 let offset = int_of_string (Pcre.get_substring subs 1) in
338 let size = int_of_string (Pcre.get_substring subs 2) in
340 if struct_name <> "list_head" then
341 FStructPointer struct_name
343 FAnonListHeadPointer in
345 { field_name = name; field_type = field_type;
346 field_offset = offset; field_size = size } in
347 field :: parse basename lines
349 Not_found -> parse basename lines
352 | line :: lines when Pcre.pmatch ~rex:re_voidptrfield line ->
354 let subs = Pcre.exec ~rex:re_voidptrfield line in
355 let name = Pcre.get_substring subs 1 in
357 let subs = Pcre.exec ~rex:re_offsetsize line in
358 let offset = int_of_string (Pcre.get_substring subs 1) in
359 let size = int_of_string (Pcre.get_substring subs 2) in
361 { field_name = name; field_type = FVoidPointer;
362 field_offset = offset; field_size = size } in
363 field :: parse basename lines
365 Not_found -> parse basename lines
368 | line :: lines when Pcre.pmatch ~rex:re_strfield line ->
369 (* A string (char array) field. *)
370 let subs = Pcre.exec ~rex:re_strfield line in
371 let name = Pcre.get_substring subs 1 in
372 let width = int_of_string (Pcre.get_substring subs 2) in
374 let subs = Pcre.exec ~rex:re_offsetsize line in
375 let offset = int_of_string (Pcre.get_substring subs 1) in
376 let size = int_of_string (Pcre.get_substring subs 2) in
378 { field_name = name; field_type = FString width;
379 field_offset = offset; field_size = size } in
380 field :: parse basename lines
382 Not_found -> parse basename lines
386 (* Just ignore any other field we can't parse. *)
390 let structures = List.filter_map (
393 try Some (Hashtbl.find bodies struct_name)
394 with Not_found -> None in
398 let body = List.tl body in (* Don't care about opener line. *)
399 let fields = parse basename body in
401 (* Compute total size of the structure. *)
403 let fields = List.map (
404 fun { field_offset = offset;
405 field_size = size } -> offset + size
407 List.fold_left max 0 fields in
409 (* Sort the structure fields by field offset. They are
410 * probably already in this order, but just make sure.
412 let cmp { field_offset = o1 } { field_offset = o2 } = compare o1 o2 in
413 let fields = List.sort ~cmp fields in
417 { struct_name = struct_name;
418 struct_fields = fields;
419 struct_total_size = total_size }
425 (* XXX This loop is O(n^3), luckily n is small! *)
426 let transpose good_struct_names kernels =
431 fun (info, structures) ->
433 let s = List.assoc struct_name structures in
439 (* Sort the kernels, which makes the generated output more stable
440 * and makes patches more useful.
442 let kernels = List.sort kernels in
447 let get_fields structures =
448 (* Use a hash table to accumulate the fields as we find them.
449 * The key is the field name. The value is the field type and the
450 * kernel version where first seen (for error reporting). If
451 * we meet the field again, we check its type hasn't changed.
452 * Finally, we can use the hash to pull out all field names and
455 let h = Hashtbl.create 13 in
457 (* A hash to check for fields which aren't always available by
458 * counting the number of times we see each field.
461 let h = Hashtbl.create 13 in
462 let count field_name =
464 try Hashtbl.find h field_name
465 with Not_found -> let r = ref 0 in Hashtbl.add h field_name r; r in
468 let get field_name = try !(Hashtbl.find h field_name) with Not_found -> 0 in
473 fun ({kernel_version = version},
474 {struct_name = struct_name; struct_fields = fields}) ->
476 fun {field_name = name; field_type = typ} ->
479 let (field_type, version_first_seen) = Hashtbl.find h name in
480 if typ <> field_type then (
481 eprintf "Error: %s.%s: field changed type between kernel versions.\n"
483 eprintf "In version %s it had type %s.\n"
484 version_first_seen (string_of_f_type field_type);
485 eprintf "In version %s it had type %s.\n"
486 version (string_of_f_type typ);
487 eprintf "The code cannot handle fields which change type like this.\n";
488 eprintf "See extract/codegen/pahole_parser.mli for more details.\n";
492 Hashtbl.add h name (typ, version)
496 let nr_kernels = List.length structures in
500 fun name (typ, _) fields ->
501 let always_available = get name = nr_kernels in
502 (name, (typ, always_available)) :: fields