let strs = List.map (
fun (struct_name, sflist, cflist) ->
let sflist = List.map (
- fun { SC.sf_name = name; sf_fields = fields } ->
+ fun { SC.sf_name = sf_name; sf_fields = fields } ->
if fields <> [] then (
let fields = List.map (
fun { PP.field_name = name; PP.field_type = t } ->
let t = ocaml_type_of_field_type t in
- <:ctyp< $lid:name$ : $t$ >>
+ <:ctyp< $lid:sf_name^"_"^name$ : $t$ >>
) fields in
let fields = concat_record_fields fields in
<:str_item<
- type $lid:name$ = { $fields$ }
+ type $lid:sf_name$ = { $fields$ }
>>
) else
- <:str_item< type $lid:name$ = unit >>
+ <:str_item< type $lid:sf_name$ = unit >>
) sflist in
let sflist = concat_str_items sflist in
let cflist = List.map (
- fun { SC.cf_name = name; cf_fields = fields } ->
+ fun { SC.cf_name = cf_name; cf_fields = fields } ->
if fields <> [] then (
let fields = List.map (
fun { PP.field_name = name; PP.field_type = t } ->
let t = ocaml_type_of_field_type t in
- <:ctyp< $lid:name$ : $t$ >>
+ <:ctyp< $lid:cf_name^"_"^name$ : $t$ >>
) fields in
let fields = concat_record_fields fields in
<:str_item<
- type $lid:name$ = { $fields$ }
+ type $lid:cf_name$ = { $fields$ }
>>
) else
- <:str_item< type $lid:name$ = unit >>
+ <:str_item< type $lid:cf_name$ = unit >>
) cflist in
let cflist = concat_str_items cflist in
concat_str_items strs, concat_sig_items sigs
-let output_interf ~output_file types =
- let sigs = concat_sig_items [ types ] in
+let generate_parsers xs =
+ let strs =
+ List.map (
+ fun (struct_name, palist) ->
+ let palist =
+ List.map (
+ fun { SC.pa_name = pa_name } ->
+ <:str_item< let $lid:pa_name$ bits = $str:pa_name$ >>
+ ) palist in
+ concat_str_items palist
+ ) xs in
+
+ let strs = concat_str_items strs in
+ let strs =
+ <:str_item<
+ let match_err = "failed to match kernel structure" ;;
+ let zero = 0 ;;
+ $strs$
+ >> in
+
+ (* The shared parser functions.
+ *
+ * We could include bitmatch statements directly in here, but
+ * what happens is that the macros get expanded here, resulting
+ * in (even more) unreadable generated code. So instead just
+ * do a textual substitution later by post-processing the
+ * generated files. Not type-safe, but we can't have
+ * everything.
+ *)
+ let subs = Hashtbl.create 13 in
+ List.iter (
+ fun (struct_name, palist) ->
+ List.iter (
+ fun ({ SC.pa_name = pa_name;
+ pa_endian = endian; pa_structure = structure;
+ pa_shape_field_struct = sf;
+ pa_content_field_struct = cf }) ->
+ (* Generate the code to match this structure. *)
+ let endian =
+ match endian with
+ | Bitstring.LittleEndian -> "littleendian"
+ | Bitstring.BigEndian -> "bigendian"
+ | _ -> assert false in
+ let patterns =
+ String.concat ";\n " (
+ List.map (
+ function
+ | { PP.field_name = field_name;
+ field_type = PP.FInteger;
+ field_offset = offset;
+ field_size = 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
+
+ | { PP.field_name = field_name;
+ field_type = (PP.FStructPointer _
+ | PP.FVoidPointer
+ | PP.FAnonListHeadPointer
+ | PP.FListHeadPointer _);
+ field_offset = offset;
+ field_size = size } ->
+ sprintf "%s : zero+%d : offset(%d), %s"
+ field_name (size*8) (offset*8) endian
+
+ | { PP.field_name = field_name;
+ field_type = PP.FString width;
+ field_offset = offset;
+ field_size = size } ->
+ sprintf "%s : %d : offset(%d), string"
+ field_name (width*8) (offset*8)
+ ) structure.PP.struct_fields
+ ) in
+
+ let shape_assignments =
+ List.map (
+ fun { PP.field_name = field_name;
+ field_type = field_type;
+ field_offset = offset } ->
+
+ match field_type with
+ | PP.FListHeadPointer None ->
+ sprintf "%s_%s = Int64.sub %s %dL"
+ sf.SC.sf_name field_name field_name offset
+
+ | PP.FListHeadPointer (Some (other_struct_name, other_field_name)) ->
+ let other_offset = 666 in
+ sprintf "%s_%s = Int64.sub %s %dL"
+ sf.SC.sf_name field_name field_name other_offset
+
+ | _ ->
+ sprintf "%s_%s = %s" sf.SC.sf_name field_name field_name
+ ) sf.SC.sf_fields in
+
+ let shape_assignments =
+ String.concat ";\n " shape_assignments in
+
+ let content_assignments =
+ List.map (
+ fun { PP.field_name = field_name } ->
+ sprintf "%s_%s = %s" sf.SC.sf_name field_name field_name
+ ) sf.SC.sf_fields in
+
+ let content_assignments =
+ String.concat ";\n " content_assignments in
+
+ let code =
+ sprintf "
+ bitmatch bits with
+ | { %s } ->
+ let shape =
+ { %s } in
+ let content =
+ { %s } in
+ { %s_shape = shape; %s_content = content }
+ | { _ } ->
+ raise (Virt_mem_types.ParseError (%S, %S, match_err))"
+ patterns shape_assignments content_assignments
+ struct_name struct_name
+ struct_name pa_name in
+
+ Hashtbl.add subs pa_name code
+ ) palist;
+ ) xs;
+
+ strs, <:sig_item< >>, subs
+
+let output_interf ~output_file types parsers =
+ let sigs = concat_sig_items [ types; parsers ] in
Printers.OCaml.print_interf ~output_file sigs
-let output_implem ~output_file types =
- let strs = concat_str_items [ types ] in
- Printers.OCaml.print_implem ~output_file strs
+(* Finally generate the output files. *)
+let re_subst = Pcre.regexp "^(.*)\"(\\w+_parser_\\d+)\"(.*)$"
+
+let output_implem ~output_file types parsers parser_subs =
+ let new_output_file = output_file ^ ".new" in
+
+ let strs = concat_str_items [ types; parsers ] in
+ Printers.OCaml.print_implem ~output_file:new_output_file strs;
+
+ (* Substitute the parser bodies in the output file. *)
+ let ichan = open_in new_output_file in
+ let ochan = open_out output_file in
+
+ output_string ochan "\
+(* WARNING: This file and the corresponding mli (interface) are
+ * automatically generated by the extract/codegen/ program.
+ *
+ * Any edits you make to this file will be lost.
+ *
+ * To update this file from the latest kernel database, it is recommended
+ * that you do 'make update-kernel-structs'.
+ *)\n\n";
+
+ let rec loop () =
+ let line = input_line ichan in
+ let line =
+ if Pcre.pmatch ~rex:re_subst line then (
+ let subs = Pcre.exec ~rex:re_subst line in
+ let start = Pcre.get_substring subs 1 in
+ let template = Pcre.get_substring subs 2 in
+ let rest = Pcre.get_substring subs 3 in
+ let sub =
+ try Hashtbl.find parser_subs template
+ with Not_found -> assert false in
+ start ^ sub ^ rest
+ ) else line in
+ output_string ochan line; output_char ochan '\n';
+ loop ()
+ in
+ (try loop () with End_of_file -> ());
+
+ close_out ochan;
+ close_in ichan;
+
+ Unix.unlink new_output_file
git.annexia.org / virt-mem.git / blobdiff