}
and field_metadata_t =
| VoidPointerIsReally of string
- | ListHeadIsReally of string
+ | ListHeadIsReally of (string * string) option
(*----------------------------------------------------------------------
* This controls what structures & fields we will parse out.
"state"; "prio"; "static_prio"; "normal_prio";
"comm"; "pid" ];
field_metadata = [
- "tasks'next", ListHeadIsReally "task_struct";
- "tasks'prev", ListHeadIsReally "task_struct";
- "run_list'next", ListHeadIsReally "task_struct";
- "run_list'prev", ListHeadIsReally "task_struct";
+ "tasks'next", ListHeadIsReally None;
+ (*"tasks'prev", ListHeadIsReally None; XXX point to 'next *)
+ "run_list'next", ListHeadIsReally None;
+ (*"run_list'prev", ListHeadIsReally None; XXX point to 'next *)
];
};
"net_device", {
"name"; "flags"; "operstate"; "mtu"; "perm_addr";
"addr_len" ];
field_metadata = [
- "dev_list'next", ListHeadIsReally "net_device";
- "dev_list'prev", ListHeadIsReally "net_device";
+ "dev_list'next", ListHeadIsReally None;
+ (*"dev_list'prev", ListHeadIsReally None; XXX point to 'next *)
"ip_ptr", VoidPointerIsReally "in_device";
"ip6_ptr", VoidPointerIsReally "inet6_dev";
];
"net", {
good_fields = [ "dev_base_head'next"; "dev_base_head'prev" ];
field_metadata = [
- "dev_base_head'next", ListHeadIsReally "net_device";
- "dev_base_head'prev", ListHeadIsReally "net_device";
+ "dev_base_head'next",
+ ListHeadIsReally (Some ("net_device", "dev_list'next"));
+ "dev_base_head'prev",
+ ListHeadIsReally (Some ("net_device", "dev_list'next"));
];
};
"in_device", {
};
]
-let debug = true
+let debug = false
open Camlp4.PreCast
open Syntax
open Printf
module PP = Pahole_parser
-module SC = Struct_classify
+module MM = Minimizer
+module CG = Code_generation
let (//) = Filename.concat
-(* Couple of handy camlp4 construction functions which do some
- * things that ought to be easy/obvious but aren't.
- *
- * 'concat_str_items' concatenates a list of str_item together into
- * one big str_item.
- *
- * 'concat_record_fields' concatenates a list of records fields into
- * a record. The list must have at least one element.
- *
- * 'build_record' builds a record out of record fields.
- *
- * 'build_tuple_from_exprs' builds an arbitrary length tuple from
- * a list of expressions of length >= 2.
- *
- * Thanks to bluestorm on #ocaml for getting these working.
- *)
-let concat_str_items _loc items =
- match items with
- | [] -> <:str_item< >>
- | x :: xs ->
- List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
-
-let concat_sig_items _loc items =
- match items with
- | [] -> <:sig_item< >>
- | x :: xs ->
- List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
-
-let concat_record_fields _loc fields =
- match fields with
- | [] -> assert false
- | f :: fs ->
- List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
-
-let concat_record_bindings _loc rbs =
- match rbs with
- | [] -> assert false
- | rb :: rbs ->
- List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
-
-let build_record _loc rbs =
- Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
-
-let build_tuple_from_exprs _loc exprs =
- match exprs with
- | [] | [_] -> assert false
- | x :: xs ->
- Ast.ExTup (_loc,
- List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
-
(* Start of the main program. *)
let () =
let quick = ref false in
(List.length kernels);
printf " union of fields found:\n";
List.iter (
- fun (field_name, field_type) ->
- printf " %s %s\n" (PP.string_of_f_type field_type) field_name
+ fun (field_name, (field_type, always_available)) ->
+ printf " %s %s /* %s */\n"
+ (PP.string_of_f_type field_type) field_name
+ (if always_available then "always" else "optional")
) all_fields
) structures;
- (* Now perform the minimization step for each structure.
- * We do separate minimization for:
- * - shape field structures
- * - content field structures
- * - parsers
- *)
+ (* Now perform the minimization step for parsers. *)
let structures =
List.map (
fun (struct_name, (kernels, all_fields)) ->
- let sflist, sfhash =
- SC.minimize_shape_field_structs struct_name good_struct_names
- kernels in
-
- let cflist, cfhash =
- SC.minimize_content_field_structs struct_name good_struct_names
- kernels in
-
- let palist, pahash =
- SC.minimize_parsers struct_name kernels sfhash cfhash in
+ let palist, pahash = MM.minimize_parsers struct_name kernels in
- (struct_name, (kernels, all_fields,
- sflist, sfhash, cflist, cfhash, palist, pahash))
+ (struct_name, (kernels, all_fields, palist, pahash))
) structures in
if debug then
List.iter (
fun (struct_name,
- (kernels, all_fields,
- sflist, sfhash, cflist, cfhash, palist, pahash)) ->
+ (kernels, all_fields, palist, pahash)) ->
printf "struct %s:\n" struct_name;
- printf " shape field structures:\n";
- List.iter (
- fun { SC.sf_name = name; sf_fields = fields } ->
- printf " type %s = {\n" name;
- List.iter (
- fun { PP.field_name = name; field_type = typ } ->
- printf " %s %s;\n" (PP.string_of_f_type typ) name
- ) fields;
- printf " }\n";
- ) sflist;
-
- printf " content field structures:\n";
+ printf " parsers:\n";
List.iter (
- fun { SC.cf_name = name; cf_fields = fields } ->
- printf " type %s = {\n" name;
+ fun { MM.pa_name = name; pa_structure = structure } ->
+ printf " let %s bits =\n" name;
List.iter (
- fun { PP.field_name = name; field_type = typ } ->
+ fun ({ PP.field_name = name; field_type = typ }) ->
printf " %s %s;\n" (PP.string_of_f_type typ) name
- ) fields;
- printf " }\n";
- ) cflist;
-
- printf " parsers:\n";
- List.iter (
- fun { SC.pa_name = name;
- pa_shape_field_struct = sf;
- pa_content_field_struct = cf } ->
- printf " let %s = ...\n" name;
- printf " -> (%s, %s)\n" sf.SC.sf_name cf.SC.cf_name
+ ) structure.PP.struct_fields;
) palist
) structures;
+
+ (* Now let's generate some code. *)
+ let implem_types, interf_types =
+ CG.generate_types (
+ List.map (
+ fun (struct_name, (_, all_fields, _, _)) ->
+ (struct_name, all_fields)
+ ) structures
+ ) in
+
+ let implem_offsets, interf_offsets =
+ CG.generate_offsets (
+ List.map (
+ fun (struct_name, (kernels, all_fields, _, _)) ->
+ (struct_name, (kernels, all_fields))
+ ) structures
+ ) in
+
+ let (implem_parsers, interf_parsers), subst_parsers =
+ CG.generate_parsers (
+ List.map (
+ fun (struct_name, (_, all_fields, palist, _)) ->
+ (struct_name, (all_fields, palist))
+ ) structures
+ ) in
+
+ let implem_version_maps, interf_version_maps =
+ CG.generate_version_maps (
+ List.map (
+ fun (struct_name, (kernels, _, _, pahash)) ->
+ (struct_name, (kernels, pahash))
+ ) structures
+ ) in
+
+ let implem_followers, interf_followers =
+ CG.generate_followers good_struct_names (
+ List.map (
+ fun (struct_name, (_, all_fields, _, _)) -> (struct_name, all_fields)
+ ) structures
+ ) in
+
+ (* Output the generated code. *)
+ let output_file = outputdir // "kernel.mli" in
+ printf "Writing kernel data interface to %s ...\n%!" output_file;
+ CG.output_interf ~output_file
+ interf_types interf_offsets interf_parsers
+ interf_version_maps interf_followers;
+
+ let output_file = outputdir // "kernel.ml" in
+ printf "Writing kernel data parsers to %s ...\n%!" output_file;
+ CG.output_implem ~output_file
+ implem_types implem_offsets implem_parsers subst_parsers
+ implem_version_maps implem_followers;
+
+ printf "Finished.\n"
git.annexia.org / virt-mem.git / blobdiff