}
and field_t = {
mandatory_field : bool; (* Is this field mandatory? *)
+ list_head_adjustment : bool; (* Only applies if the field points to a
+ * struct list_head: If true, then we do the
+ * list_head adjustment, so the field points
+ * to the start of the structure. If false,
+ * leave the pointer intact. The list_head
+ * adjustment only works if the list_head
+ * is in the same type of structure.
+ *)
}
+let ordinary_field = { mandatory_field = true; list_head_adjustment = true; }
+
+(*----------------------------------------------------------------------
+ * This controls what structures & fields we will parse out.
+ *----------------------------------------------------------------------*)
let structs = [
"task_struct", {
opener = "struct task_struct {"; closer = "};"; mandatory_struct = true;
fields = [
- "state", { mandatory_field = true };
- "prio", { mandatory_field = true };
- "normal_prio", { mandatory_field = true };
- "static_prio", { mandatory_field = true };
- "tasks'prev", { mandatory_field = true };
- "tasks'next", { mandatory_field = true };
- "mm", { mandatory_field = true };
- "active_mm", { mandatory_field = true };
- "comm", { mandatory_field = true };
- "pid", { mandatory_field = true };
+ "state", ordinary_field;
+ "prio", ordinary_field;
+ "normal_prio", ordinary_field;
+ "static_prio", ordinary_field;
+ "tasks'prev", ordinary_field;
+ "tasks'next", ordinary_field;
+ "mm", ordinary_field;
+ "active_mm", ordinary_field;
+ "comm", ordinary_field;
+ "pid", ordinary_field;
]
};
(*
"net_device", {
opener = "struct net_device {"; closer = "};"; mandatory_struct = true;
fields = [
- "dev_list'prev", { mandatory_field = false };
- "dev_list'next", { mandatory_field = false };
- "next", { mandatory_field = false };
- "name", { mandatory_field = true };
- "dev_addr", { mandatory_field = true };
+ "dev_list'prev", { mandatory_field = false; list_head_adjustment = true };
+ "dev_list'next", { mandatory_field = false; list_head_adjustment = true };
+ "next", { mandatory_field = false; list_head_adjustment = true };
+ "name", ordinary_field;
+ "flags", ordinary_field;
+ "operstate", ordinary_field;
+ "mtu", ordinary_field;
+ "perm_addr", ordinary_field;
+ "addr_len", ordinary_field;
+ "ip_ptr", ordinary_field;
+ "ip6_ptr", ordinary_field;
]
};
"net", {
opener = "struct net {"; closer = "};"; mandatory_struct = false;
fields = [
- "dev_base_head'next", { mandatory_field = true };
+ "dev_base_head'next",
+ (* Don't do list_head adjustment on this field, because it points
+ * to a net_device struct.
+ *)
+ { mandatory_field = true; list_head_adjustment = false };
]
};
+ "in_device", {
+ opener = "struct in_device {"; closer = "};"; mandatory_struct = true;
+ fields = [
+ "ifa_list", ordinary_field;
+ ];
+ };
+ "inet6_dev", {
+ opener = "struct inet6_dev {"; closer = "};"; mandatory_struct = true;
+ fields = [
+ "addr_list", ordinary_field;
+ ];
+ };
+ "in_ifaddr", {
+ opener = "struct in_ifaddr {"; closer = "};"; mandatory_struct = true;
+ fields = [
+ "ifa_next", ordinary_field;
+ "ifa_local", ordinary_field;
+ "ifa_address", ordinary_field;
+ "ifa_mask", ordinary_field;
+ "ifa_broadcast", ordinary_field;
+ ];
+ };
+ "inet6_ifaddr", {
+ opener = "struct inet6_ifaddr {"; closer = "};"; mandatory_struct = true;
+ fields = [
+ (*"addr'in6_u'u6_addr8", ordinary_field;*)
+ "prefix_len", ordinary_field;
+ "lst_next", ordinary_field;
+ ];
+ };
]
let debug = false
* '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 the last one working.
+ * Thanks to bluestorm on #ocaml for getting these working.
*)
let concat_str_items _loc items =
match items with
| 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
* XXX Even better would be to have a proper interface to libdwarves.
*)
let re_offsetsize = Pcre.regexp "/\\*\\s+(\\d+)\\s+(\\d+)\\s+\\*/" in
- let re_intfield = Pcre.regexp "int\\s+(\\w+);" in
+ let re_intfield = Pcre.regexp "(?:int|char)\\s+(\\w+);" in
let re_ptrfield = Pcre.regexp "struct\\s+(\\w+)\\s*\\*\\s*(\\w+);" in
+ let re_voidptrfield = Pcre.regexp "void\\s*\\*\\s*(\\w+);" in
let re_strfield = Pcre.regexp "char\\s+(\\w+)\\[(\\d+)\\];" in
let re_structopener = Pcre.regexp "(struct|union)\\s+.*{$" in
let re_structcloser = Pcre.regexp "}\\s*(\\w+)?(\\[\\d+\\])?;" in
Not_found -> parse basename lines
);
+ | line :: lines when Pcre.pmatch ~rex:re_voidptrfield line ->
+ (* A void* field. *)
+ let subs = Pcre.exec ~rex:re_voidptrfield line in
+ let name = Pcre.get_substring subs 1 in
+ (try
+ let subs = Pcre.exec ~rex:re_offsetsize line in
+ let offset = int_of_string (Pcre.get_substring subs 1) in
+ let size = int_of_string (Pcre.get_substring subs 2) in
+ (name, (`VoidPtr, offset, size))
+ :: parse basename lines
+ with
+ Not_found -> parse basename lines
+ );
+
| line :: lines when Pcre.pmatch ~rex:re_strfield line ->
(* A string (char array) field. *)
let subs = Pcre.exec ~rex:re_strfield line in
(* That got us all the fields, but we only care about
* the wanted_fields.
*)
+ let all_fields = fields in
let fields = List.filter (
fun (name, _) -> List.mem_assoc name wanted_fields
) fields in
(* Also check we have all the mandatory fields. *)
List.iter (
fun (wanted_field, { mandatory_field = mandatory }) ->
- if mandatory && not (List.mem_assoc wanted_field fields) then
- failwith (sprintf "%s: structure %s is missing required field %s" basename struct_name wanted_field)
+ if mandatory && not (List.mem_assoc wanted_field fields)
+ then (
+ eprintf "%s: structure %s is missing required field %s\n" basename struct_name wanted_field;
+ eprintf "fields found in this structure:\n";
+ List.iter (
+ fun (name, _) -> eprintf "\t%s\n" name
+ ) all_fields;
+ exit 1
+ );
) wanted_fields;
(* Prefix all the field names with the structure name. *)
printf " int %s; " field_name
| `Ptr struct_name ->
printf " struct %s *%s; " struct_name field_name
+ | `VoidPtr ->
+ printf " void *%s; " field_name
| `Str width ->
printf " char %s[%d]; " field_name width
);
(* Now get a type for each structure field. *)
List.filter_map (
- fun (field_name, { mandatory_field = mandatory }) ->
+ fun (field_name, ft) ->
try
let field_name = struct_name ^ "_" ^ field_name in
let typ = Hashtbl.find hash field_name in
- Some (field_name, (typ, mandatory))
+ Some (field_name, (typ, ft))
with Not_found ->
let msg =
sprintf "%s.%s: this field was not found in any kernel version"
struct_name field_name in
- if mandatory then failwith msg else prerr_endline msg;
+ if ft.mandatory_field then failwith msg else prerr_endline msg;
None
) struct_fields in
(struct_name, kernels, field_types)
let struct_type, struct_sig =
let fields = List.map (
function
- | (name, (`Int, true)) ->
+ | (name, (`Int, { mandatory_field = true })) ->
<:ctyp< $lid:name$ : int64 >>
- | (name, (`Int, false)) ->
+ | (name, (`Int, { mandatory_field = false })) ->
<:ctyp< $lid:name$ : int64 option >>
- | (name, (`Ptr _, true)) ->
+ | (name, ((`VoidPtr|`Ptr _), { mandatory_field = true })) ->
<:ctyp< $lid:name$ : Virt_mem_mmap.addr >>
- | (name, (`Ptr _, false)) ->
+ | (name, ((`VoidPtr|`Ptr _), { mandatory_field = false })) ->
<:ctyp< $lid:name$ : Virt_mem_mmap.addr option >>
- | (name, (`Str _, true)) ->
+ | (name, (`Str _, { mandatory_field = true })) ->
<:ctyp< $lid:name$ : string >>
- | (name, (`Str _, false)) ->
+ | (name, (`Str _, { mandatory_field = false })) ->
<:ctyp< $lid:name$ : string option >>
) field_types in
let fields = concat_record_fields _loc fields in
let fieldsigs = fields @ fields_not_present in
let fsname = sprintf "fieldsig_%d" i in
let fieldsigs = concat_record_bindings _loc fieldsigs in
+ let fieldsigs = build_record _loc fieldsigs in
<:str_item<
- let $lid:fsname$ = { () with $fieldsigs$ }
+ let $lid:fsname$ = $fieldsigs$
>>
) parsers in
String.concat ";\n " (
List.map (
function
- | (field_name, (`Int, offset, size))
- | (field_name, (`Ptr _, offset, size)) ->
+ | (field_name, ((`Int|`Ptr _|`VoidPtr), offset, size)) ->
(* 'zero+' is a hack to force the type to int64. *)
sprintf "%s : zero+%d : offset(%d), %s"
field_name (size*8) (offset*8) endian
let assignments =
List.map (
fun (field_name, typ) ->
- let (_, mandatory) =
+ let (_, { mandatory_field = mandatory;
+ list_head_adjustment = list_head_adjustment }) =
try List.assoc field_name field_types
with Not_found ->
failwith (sprintf "%s: not found in field_types"
field_name) in
- match typ, mandatory with
- | (`Ptr "list_head", offset, size), true ->
+ match typ, mandatory, list_head_adjustment with
+ | (`Ptr "list_head", offset, size), true, true ->
sprintf "%s = Int64.sub %s %dL"
field_name field_name offset
- | (`Ptr "list_head", offset, size), false ->
+ | (`Ptr "list_head", offset, size), false, true ->
sprintf "%s = Some (Int64.sub %s %dL)"
field_name field_name offset
- | _, true ->
+ | _, true, _ ->
sprintf "%s = %s" field_name field_name
- | _, false ->
+ | _, false, _ ->
sprintf "%s = Some %s" field_name field_name
) fields in
let assignments_not_present =
git.annexia.org / virt-mem.git / blobdiff