X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=extract%2Fcodegen%2Fkerneldb_to_parser.ml;h=1d56126b84fa964a5b585c0daa4fcc1f71aba373;hb=45b7766e66fb59ece5f07305553dc54a26b32d9d;hp=2bddb90a24c4f27cb9ed85bab1be7cc6dd5987a7;hpb=727fe72a983a94decbd6e99d8c7c85c34f0171da;p=virt-mem.git diff --git a/extract/codegen/kerneldb_to_parser.ml b/extract/codegen/kerneldb_to_parser.ml index 2bddb90..1d56126 100644 --- a/extract/codegen/kerneldb_to_parser.ml +++ b/extract/codegen/kerneldb_to_parser.ml @@ -32,7 +32,7 @@ let what = [ "task_struct", ( "struct task_struct {", "};", true, [ "state"; "prio"; "normal_prio"; "static_prio"; - "tasks'prev"; "tasks'next"; "mm"; "active_mm"; "comm"] + "tasks'prev"; "tasks'next"; "mm"; "active_mm"; "comm"; "pid" ] ); (* "mm_struct", ( @@ -80,7 +80,7 @@ Example (from toplevel of virt-mem source tree): let infos = Sys.readdir kernelsdir in let infos = Array.to_list infos in let infos = List.filter (fun name -> String.ends_with name ".info") infos in - let infos = List.map ((//) kernelsdir) infos in + let infos = List.map ( (//) kernelsdir) infos in (* Regular expressions. We really really should use ocaml-mikmatch ... *) let re_oldformat = Pcre.regexp "^RPM: \\d+: \\(build \\d+\\) ([-\\w]+) ([\\w.]+) ([\\w.]+) \\(.*?\\) (\\w+)" in @@ -286,9 +286,9 @@ Example (from toplevel of virt-mem source tree): match struct_name with | None -> nested_fields | Some prefix -> - List.map ( - fun (name, details) -> (prefix ^ "'" ^ name, details) - ) nested_fields in + List.map ( + fun (name, details) -> (prefix ^ "'" ^ name, details) + ) nested_fields in (* Parse the rest. *) nested_fields @ parse basename rest @@ -315,7 +315,8 @@ Example (from toplevel of virt-mem source tree): 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, (`Ptr struct_name, offset, size)) :: parse basename lines + (name, (`Ptr struct_name, offset, size)) + :: parse basename lines with Not_found -> parse basename lines ); @@ -329,7 +330,8 @@ Example (from toplevel of virt-mem source tree): 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, (`Str width, offset, size)) :: parse basename lines + (name, (`Str width, offset, size)) + :: parse basename lines with Not_found -> parse basename lines ); @@ -343,9 +345,10 @@ Example (from toplevel of virt-mem source tree): let datas = List.map ( fun (basename, version, arch, bodies) -> let structures = List.filter_map ( - fun (name, (_, _, _, wanted_fields)) -> + fun (struct_name, (_, _, _, wanted_fields)) -> let body = - try Some (Hashtbl.find bodies name) with Not_found -> None in + try Some (Hashtbl.find bodies struct_name) + with Not_found -> None in match body with | None -> None | Some body -> @@ -370,10 +373,15 @@ Example (from toplevel of virt-mem source tree): List.iter ( fun wanted_field -> if not (List.mem_assoc wanted_field fields) then - failwith (sprintf "%s: structure %s is missing required field %s" basename name wanted_field) + failwith (sprintf "%s: structure %s is missing required field %s" basename struct_name wanted_field) ) wanted_fields; - Some (name, (fields, total_size)) + (* Prefix all the field names with the structure name. *) + let fields = + List.map (fun (name, details) -> + struct_name ^ "_" ^ name, details) fields in + + Some (struct_name, (fields, total_size)) ) what in (basename, version, arch, structures) @@ -516,12 +524,8 @@ Example (from toplevel of virt-mem source tree): function | (name, `Int) -> <:ctyp< $lid:name$ : int64 >> - | (name, `Ptr "list_head") -> - <:ctyp< $lid:name$ : - [ `$lid:struct_name$ ] Virt_mem_mmap.typed_addr >> - | (name, `Ptr struct_name) -> - <:ctyp< $lid:name$ : - [ `$lid:struct_name$ ] Virt_mem_mmap.typed_addr >> + | (name, `Ptr _) -> + <:ctyp< $lid:name$ : Virt_mem_mmap.addr >> | (name, `Str _) -> <:ctyp< $lid:name$ : string >> ) field_types in @@ -593,9 +597,7 @@ Example (from toplevel of virt-mem source tree): List.map ( function | (field_name, (`Ptr "list_head", offset, size)) -> - sprintf "%s = (Virt_mem_mmap.unsafe_typed_addr_of_addr (Int64.sub %s %dL) : [ `%s ] Virt_mem_mmap.typed_addr)" field_name field_name offset struct_name - | (field_name, (`Ptr struct_name, offset, size)) -> - sprintf "%s = (Virt_mem_mmap.unsafe_typed_addr_of_addr %s : [ `%s ] Virt_mem_mmap.typed_addr)" field_name field_name struct_name + sprintf "%s = Int64.sub %s %dL" field_name field_name offset | (field_name, _) -> sprintf "%s = %s" field_name field_name ) fields @@ -626,7 +628,7 @@ Example (from toplevel of virt-mem source tree): ) <:str_item< let map = StringMap.empty >> kernels in <:str_item< - module StringMap = Map.Make (String) + module StringMap = Map.Make (String) ;; $stmts$ >> in @@ -640,16 +642,15 @@ Example (from toplevel of virt-mem source tree): $version_map$ type kernel_version = string - let known version = StringMap.mem version map - let size version = + let $lid:struct_name^"_known"$ version = StringMap.mem version map + let $lid:struct_name^"_size"$ version = let _, size = StringMap.find version map in size - let of_bits version bits = + let $lid:struct_name^"_of_bits"$ version bits = let parsefn, _ = StringMap.find version map in parsefn bits - let get version mem addr = + let $lid:"get_"^struct_name$ version mem addr = let parsefn, size = StringMap.find version map in - let addr = Virt_mem_mmap.unsafe_addr_of_typed_addr addr in let bytes = Virt_mem_mmap.get_bytes mem addr size in let bits = Bitstring.bitstring_of_string bytes in parsefn bits @@ -661,13 +662,12 @@ Example (from toplevel of virt-mem source tree): $struct_sig$ type kernel_version = string - val known : kernel_version -> bool - val size : kernel_version -> int - val of_bits : kernel_version -> Bitstring.bitstring -> t - val get : kernel_version -> - ('a, 'b, [`HasMapping]) Virt_mem_mmap.t -> - [ `$lid:struct_name$ ] Virt_mem_mmap.typed_addr -> - t + val $lid:struct_name^"_known"$ : kernel_version -> bool + val $lid:struct_name^"_size"$ : kernel_version -> int + val $lid:struct_name^"_of_bits"$ : + kernel_version -> Bitstring.bitstring -> t + val $lid:"get_"^struct_name$ : kernel_version -> + ('a, 'b, [`HasMapping]) Virt_mem_mmap.t -> Virt_mem_mmap.addr -> t >> in (struct_name, code, interface, parser_subs)