[Libguestfs] [PATCH 1/3] inspection: Add rules compiler to the generator.
Richard W.M. Jones
rjones at redhat.com
Wed Dec 2 22:05:28 UTC 2015
---
.gitignore | 4 +
README | 4 +
bootstrap | 2 +
generator/Makefile.am | 39 ++-
generator/rules_compiler.ml | 757 +++++++++++++++++++++++++++++++++++++++++++
generator/rules_compiler.mli | 21 ++
generator/rules_parser.mly | 111 +++++++
generator/rules_scanner.mll | 112 +++++++
generator/types.ml | 49 +++
generator/utils.ml | 16 +
generator/utils.mli | 6 +
m4/guestfs_ocaml.m4 | 2 +
12 files changed, 1121 insertions(+), 2 deletions(-)
create mode 100644 generator/rules_compiler.ml
create mode 100644 generator/rules_compiler.mli
create mode 100644 generator/rules_parser.mly
create mode 100644 generator/rules_scanner.mll
diff --git a/.gitignore b/.gitignore
index 11557b6..288a853 100644
--- a/.gitignore
+++ b/.gitignore
@@ -221,7 +221,11 @@ Makefile.in
/generator/files-generated.txt
/generator/generator
/generator/.pod2text.data*
+/generator/rules_parser.ml
+/generator/rules_parser.mli
+/generator/rules_scanner.ml
/generator/stamp-generator
+/generator/stamp-rules-parser
/get-kernel/.depend
/get-kernel/stamp-virt-get-kernel.pod
/get-kernel/virt-get-kernel
diff --git a/README b/README
index 2c79c0d..26198fc 100644
--- a/README
+++ b/README
@@ -88,6 +88,10 @@ The full requirements are described below.
| | | | Optional if compiling from tarball. |
| | | | To build generated files and OCaml bindings.
+--------------+-------------+---+-----------------------------------------+
+| ocamllex | 3.11 |R/O| Required if compiling from git. |
+| ocamlyacc | | | Optional if compiling from tarball. |
+| | | | To build generated files and OCaml bindings.
++--------------+-------------+---+-----------------------------------------+
| findlib | |R/O| Required if compiling from git. |
| | | | Optional if compiling from tarball. |
| | | | To build generated files and OCaml bindings.
diff --git a/bootstrap b/bootstrap
index 5df6f0f..f932c0c 100755
--- a/bootstrap
+++ b/bootstrap
@@ -36,6 +36,7 @@ gnulib_tool=$GNULIB_SRCDIR/gnulib-tool
modules='
accept4
+array-oset
areadlink
areadlinkat
arpa_inet
@@ -97,6 +98,7 @@ warnings
xalloc
xalloc-die
xgetcwd
+xoset
xstrtol
xstrtoll
xvasprintf
diff --git a/generator/Makefile.am b/generator/Makefile.am
index 9177e6f..fe6d35d 100644
--- a/generator/Makefile.am
+++ b/generator/Makefile.am
@@ -18,6 +18,9 @@
include $(top_srcdir)/subdir-rules.mk
# In alphabetical order.
+#
+# Note we include ocamllex/ocamlyacc-generated files here, since
+# we want to distribute these in the tarball for convenience.
sources = \
actions.ml \
actions.mli \
@@ -48,6 +51,13 @@ sources = \
prepopts.mli \
python.ml \
ruby.ml \
+ rules_compiler.ml \
+ rules_compiler.mli \
+ rules_parser.ml \
+ rules_parser.mli \
+ rules_parser.mly \
+ rules_scanner.ml \
+ rules_scanner.mll \
structs.ml \
structs.mli \
tests_c_api.ml \
@@ -88,6 +98,9 @@ objects = \
bindtests.cmo \
errnostring.cmo \
customize.cmo \
+ rules_scanner.cmo \
+ rules_parser.cmo \
+ rules_compiler.cmo \
main.cmo
EXTRA_DIST = $(sources) files-generated.txt
@@ -101,6 +114,22 @@ if HAVE_OCAML
generator: $(objects)
$(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -linkpkg $^ -o $@
+rules_parser.ml rules_parser.mli: stamp-rules-parser
+
+stamp-rules-parser: rules_parser.mly
+ rm -f $@
+ $(OCAMLYACC) $<
+ touch $@
+
+rules_scanner.ml: rules_scanner.mll
+ $(OCAMLLEX) $<
+
+# Apparently because rules_parser.mli and rules_scanner.ml may not
+# exist before the Makefile is run, the pattern dependencies below
+# don't add these rules automatically, so we have to be explicit.
+rules_parser.cmi: rules_parser.mli
+rules_scanner.cmi: rules_scanner.ml
+
# Dependencies.
%.cmi: %.mli
$(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -c $< -o $@
@@ -111,7 +140,7 @@ generator: $(objects)
depend: .depend
-.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml)
+.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rules_parser.ml rules_scanner.ml
rm -f $@ $@-t
$(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) $^ | \
$(SED) 's/ *$$//' | \
@@ -154,6 +183,12 @@ stamp-generator: generator
CLEANFILES = $(noinst_DATA) $(noinst_PROGRAM) *.cmi *.cmo *~
-DISTCLEANFILES = .depend .pod2text.data.version.2
+DISTCLEANFILES = \
+ .depend \
+ .pod2text.data.version.2 \
+ rules_parser.ml \
+ rules_parser.mli \
+ rules_scanner.ml \
+ stamp-rules-parser
SUFFIXES = .cmo .cmi .cmx .ml .mli .mll .mly
diff --git a/generator/rules_compiler.ml b/generator/rules_compiler.ml
new file mode 100644
index 0000000..8e0fc6c
--- /dev/null
+++ b/generator/rules_compiler.ml
@@ -0,0 +1,757 @@
+(* libguestfs
+ * Copyright (C) 2009-2015 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *)
+
+(* This is the compiler that turns inspection rules into C code. *)
+
+open Printf
+
+open Utils
+open Types
+open Pr
+open Docstrings
+
+module StringSet = Set.Make (String)
+
+let (//) = Filename.concat
+
+type env = {
+ free_vars : string list;
+ assign_vars : string list;
+ list_assign_vars : string list;
+
+ (* Name of the C environment struct. *)
+ env_struct : string;
+}
+
+let rec compile filename () =
+ let rules = parse filename in
+ type_checking filename rules;
+
+ generate_header ~extra_inputs:[filename] CStyle GPLv2plus;
+
+ pr "\
+#include <config.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdarg.h>
+#include <string.h>
+#include <inttypes.h>
+#include <unistd.h>
+#include <error.h>
+
+/* XXX At the moment we have to hard-code any headers needed by
+ * C code snippets from the input here. We could fix this by
+ * allowing the source to define a C prologue.
+ */
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <errno.h>
+
+#include \"gl_oset.h\"
+#include \"gl_xoset.h\"
+#include \"gl_array_oset.h\"
+
+#include \"inspection.h\"
+
+#include \"guestfs-internal-all.h\"
+
+/* Disable a few warnings, so we can take a few short-cuts with the
+ * generated code.
+ */
+#pragma GCC diagnostic ignored \"-Wunused-variable\"
+#pragma GCC diagnostic ignored \"-Wunused-macros\"
+#pragma GCC diagnostic ignored \"-Wunused-function\"
+
+static gl_oset_t
+new_string_set (void)
+{
+ /* Note that we don't need a dispose function because all the
+ * strings added to the set will be \"owned\" by other code, either
+ * static (all_strings) or owned by facts.
+ */
+ return gl_oset_create_empty (GL_ARRAY_OSET,
+ (gl_setelement_compar_fn) strcmp, NULL);
+}
+
+static void
+add_all_strings (gl_oset_t set)
+{
+ size_t i;
+
+ for (i = 0; all_strings[i] != NULL; ++i)
+ gl_oset_add (set, all_strings[i]);
+}
+
+";
+
+ get_all_strings filename rules;
+
+ (* Give each rule a unique number. The number is used for rule
+ * function names, environments and so on. eg: 'rule_0 ()'
+ * 'struct rule_0_env'.
+ *)
+ let rules = mapi (fun i rule -> (i, rule)) rules in
+
+ (* Create the environment struct for each rule. This contains all
+ * the variables either consumed or set by the function.
+ *)
+ let rules =
+ List.map (fun (i, rule) ->
+ let env = compile_rule_environment filename i rule in
+ (i, rule, env))
+ rules in
+
+ (* Write all C code snippets to functions. *)
+ iteri (
+ fun j (i, rule, env) ->
+ let rec loop = function
+ | And (e1, e2) | Or (e1, e2) -> loop e1; loop e2
+ | Code code -> compile_code filename i rule env j code
+ | AssignCode _ -> ()
+(*
+ | AssignCode (vs, code) ->
+ compile_assign_code filename i rule env j vs code
+ *)
+ | ListAssignCode (vs, code) ->
+ compile_list_assign_code filename i rule env j vs code
+ | Term _ | Not _ | True | False -> ()
+ in
+ loop rule.body
+ ) rules;
+
+ (* Compile all rules into functions. *)
+ let rules =
+ List.map (
+ fun (i, rule, env) ->
+ let rule_fn = sprintf "rule_%d" i in
+ compile_rule filename rule rule_fn env;
+ (rule, rule_fn)
+ ) rules in
+
+ pr "\
+void
+rules (void)
+{
+ clear_true_facts ();
+ clear_false_facts ();
+
+ /* Loop over all the rules until no more true facts can be added. */
+ for (;;) {
+ size_t nr_true_facts = count_true_facts ();
+
+";
+
+ List.iter (
+ fun (rule, rule_fn) ->
+ pr " if (verbose)\n";
+ pr " printf (\"trying rule %%s\\n\", %S);\n"
+ (string_of_term rule.head);
+ pr " %s ();\n" rule_fn;
+ pr "\n";
+ ) rules;
+
+ pr " /* Added a true fact during this iteration? */
+ if (nr_true_facts == count_true_facts ())
+ break;
+ } /* for (;;) */
+}
+
+/* EOF */\n"
+
+and get_all_strings filename rules =
+ let rec loop = function
+ | True | False | Code _ | AssignCode _ | ListAssignCode _ -> []
+ | And (e1, e2) | Or (e1, e2) -> loop e1 @ loop e2
+ | Term term | Not term -> get_term_strings term
+ and get_term_strings { term_args = args } =
+ filter_map (function Variable _ -> None | Constant s -> Some s) args
+ in
+ let all_strings =
+ List.map (fun rule -> get_term_strings rule.head @ loop rule.body) rules in
+ let all_strings = List.concat all_strings in
+ let all_strings = sort_uniq all_strings in
+ pr "const char *all_strings[] = {\n";
+ pr " ";
+ let col = ref 0 in
+ List.iter (
+ fun s ->
+ let len = String.length s in
+ if !col + len + 4 >= 72 then (
+ col := 0;
+ pr "\n "
+ );
+ pr "%S, " s;
+ col := !col + len + 4;
+ ) all_strings;
+ if !col > 0 then pr "\n";
+ pr " NULL\n";
+ pr "};\n";
+ pr "\n"
+
+(* Work the environment of a single rule. Also write out the
+ * corresponding struct to the C file.
+ *)
+and compile_rule_environment filename i rule =
+ (* The name of the C struct. *)
+ let env_struct = sprintf "rule_%d_env" i in
+
+ (* Divide all the variables which appear in the rule into:
+ * - ones which we have to search for [free_vars],
+ * - ones which are going to be returned by a C expression within
+ * the body [assign_vars, list_assign_vars].
+ * We can do this statically.
+ * These sets are non-overlapping, so we just need to check which
+ * variables are returned by C expressions, and do an additional
+ * check that no C expressions are returning the same variable.
+ *)
+ (* Get the complete list of vars ... *)
+ let free_vars = Hashtbl.create 13 in
+ (* ... from the head *)
+ List.iter (
+ function
+ | Variable v ->
+ if Hashtbl.mem free_vars v then (
+ eprintf "%s: variable '%s' appears two or more times in a rule\n"
+ filename v;
+ exit 1
+ );
+ Hashtbl.add free_vars v 1
+ | Constant _ -> ()
+ ) rule.head.term_args;
+ (* ... from the body *)
+ let rec loop = function
+ | And (e1, e2) | Or (e1, e2) -> loop e1; loop e2
+ | Term { term_args = args } | Not { term_args = args } ->
+ List.iter (
+ function
+ | Variable v -> Hashtbl.replace free_vars v 1
+ | Constant _ -> ()
+ ) args
+ | True | False
+ | Code _ | AssignCode _ | ListAssignCode _ -> ()
+ in
+ loop rule.body;
+
+ let assign_vars = Hashtbl.create 13 in
+ let list_assign_vars = Hashtbl.create 13 in
+ let rec loop = function
+ | True | False | Term _ | Not _ | Code _ -> ()
+ | And (e1, e2) | Or (e1, e2) -> loop e1; loop e2
+ | AssignCode (vs, _) ->
+ List.iter (
+ fun v ->
+ Hashtbl.remove free_vars v;
+ if Hashtbl.mem assign_vars v then (
+ eprintf "%s: variable '%s' appears two or more times in a C assignment expression in a rule\n"
+ filename v;
+ exit 1
+ );
+ Hashtbl.add assign_vars v 1
+ ) vs
+ | ListAssignCode (vs, _) ->
+ List.iter (
+ fun v ->
+ Hashtbl.remove free_vars v;
+ if Hashtbl.mem list_assign_vars v || Hashtbl.mem assign_vars v then (
+ eprintf "%s: variable '%s' appears two or more times in a C assignment expression in a rule\n"
+ filename v;
+ exit 1
+ );
+ Hashtbl.add list_assign_vars v 1
+ ) vs
+ in
+ loop rule.body;
+ let free_vars = Hashtbl.fold (fun k _ ks -> k :: ks) free_vars [] in
+ let assign_vars = Hashtbl.fold (fun k _ ks -> k :: ks) assign_vars [] in
+ let list_assign_vars =
+ Hashtbl.fold (fun k _ ks -> k :: ks) list_assign_vars [] in
+
+ (* Write out the C struct. *)
+ pr "/* Environment struct for rule %s */\n" (string_of_term rule.head);
+ pr "struct %s {\n" env_struct;
+ if free_vars <> [] then (
+ pr " /* free variables */\n";
+ List.iter (pr " char *%s;\n") free_vars
+ );
+ if assign_vars <> [] then (
+ pr " /* assigned vars */\n";
+ List.iter (pr " char *%s;\n") assign_vars
+ );
+ if list_assign_vars <> [] then (
+ pr " /* assigned lists */\n";
+ pr " size_t nr_list_assign_vars;\n";
+ List.iter (pr " char **%s;\n") list_assign_vars
+ );
+ pr "};\n";
+ pr "\n";
+
+ (* Return the OCaml env. *)
+ { free_vars = free_vars;
+ assign_vars = assign_vars;
+ list_assign_vars = list_assign_vars;
+ env_struct = env_struct; }
+
+(* Compile a single rule to C code. *)
+and compile_rule filename rule rule_fn env =
+ (* For each free variable we need to find the possible values for that
+ * variable. If they appear within the body in a term like
+ * 'Foo(var)' then we can just look for matching facts and add
+ * them (at runtime). If they don't, then we start with the list
+ * of all strings culled from the source + all strings from all facts.
+ *)
+ let free_vars = List.map (
+ fun v ->
+ let fact_lookups = ref [] in
+ let rec loop = function
+ | True | False | Code _ | AssignCode _ | ListAssignCode _ -> ()
+ | And (e1, e2) | Or (e1, e2) -> loop e1; loop e2
+ | Term { term_name = term_name; term_args = args }
+ | Not { term_name = term_name; term_args = args } ->
+ (* If this term contains this variable at some position,
+ * then save that in the list of 'facts'.
+ *)
+ iteri (
+ fun arg_i ->
+ function
+ | Variable v' when v = v' ->
+ fact_lookups := (term_name, arg_i) :: !fact_lookups
+ | Variable _ | Constant _ -> ()
+ ) args
+ in
+ loop rule.body;
+ let fact_lookups = sort_uniq !fact_lookups in
+
+ v, fact_lookups
+ ) env.free_vars in
+
+ pr "static void\n";
+ pr "%s (void)\n" rule_fn;
+ pr "{\n";
+ pr " struct %s env;\n" env.env_struct;
+ pr " bool added;\n";
+ pr " size_t i;\n";
+ List.iter (
+ fun (v, _) ->
+ pr " gl_oset_t search_%s;\n" v;
+ pr " gl_oset_iterator_t iter_%s;\n" v;
+ ) free_vars;
+ pr "\n";
+
+ if free_vars <> [] then
+ pr " /* Build the sets we will use for searching each free variable. */\n";
+ List.iter (
+ function
+ | v, [] ->
+ (* The variable doesn't appear in any expressions, so
+ * add a note to the source. Maybe emit a compiler warning? XXX
+ *)
+ pr " search_%s = new_string_set ();\n" v;
+ pr " /* Warning: variable '%s' is underspecified, so we will\n" v;
+ pr " * search over all strings from the source and all facts.\n";
+ pr " */\n";
+ pr " add_all_strings (search_%s);\n" v;
+ pr " add_all_fact_strings (search_%s);\n" v;
+ pr "\n"
+ | v, fact_lookups ->
+ pr " search_%s = new_string_set ();\n" v;
+ List.iter (
+ fun (term_name, arg_i) ->
+ pr " add_strings_from_facts (search_%s, %S, %d);\n"
+ v term_name arg_i
+ ) fact_lookups;
+ pr "\n"
+ ) free_vars;
+
+ (* Do a cartesian search over all [free_vars], substituting each set of
+ * variables, and evaluating the body. If it evaluates to true,
+ * then we will add a new true fact! (Or maybe several if we are
+ * dealing with a list assignment []={{...}}). If it evaluates
+ * to false, we add a false fact. It's also possible that we
+ * cannot evaluate the rule at all, because it contains unknown
+ * facts, in which case we end up adding NO new facts.
+ *)
+ if free_vars <> [] then (
+ pr " /* Perform cartesian search over free variables. */\n";
+
+ List.iter (
+ fun (v, _) ->
+ pr " iter_%s = gl_oset_iterator (search_%s);\n" v v;
+ pr " while (gl_oset_iterator_next (&iter_%s,\n" v;
+ pr " (const void **)&env.%s)) {\n" v;
+ ) free_vars;
+
+ ) else (
+ (* If there are no free_vars, then we have to add a dummy loop
+ * around the next code so that the 'continue' statement can be used.
+ *)
+ pr " do {\n";
+ );
+
+ (* Initialize any assign_vars and list_assign_vars in the env struct.
+ * Note that the free_vars are initialized by the iterator loops above.
+ *)
+ List.iter (pr " env.%s = NULL;\n") env.assign_vars;
+ List.iter (pr " env.%s = NULL;\n") env.list_assign_vars;
+ if env.list_assign_vars <> [] then pr " env.nr_list_assign_vars = 0;\n";
+
+ (* We can only do this optimization if assign_vars = list_assign_vars = [],
+ * because we don't know what the C code (returning those vars)
+ * may give us yet. XXX Actually we could be looser with this:
+ * we only need to check that the head term contains no assigned
+ * variables.
+ *)
+ if env.assign_vars = [] && env.list_assign_vars = [] then (
+ pr " {\n";
+ pr " /* If the fact already exists, don't bother doing any work. */\n";
+ pr " CLEANUP_FREE fact *fact = create_fact (%S" rule.head.term_name;
+ List.iter (function
+ | Variable v -> pr ", env.%s" v
+ | Constant s -> pr ", %S" s)
+ rule.head.term_args;
+ pr ", NULL);\n";
+ pr "\n";
+ pr " if (is_fact (true, fact) || is_fact (false, fact))\n";
+ pr " continue;\n";
+ pr " }\n";
+ pr "\n";
+ );
+
+ (* Evaluate the expression on the right hand side. *)
+ let rec eval result = function
+ | True ->
+ pr " %s = 1;\n" result
+ | False ->
+ pr " %s = 0;\n" result
+ | Code code ->
+ let code_fn = function_of_code code in
+ pr " %s = %s (&env);\n" result code_fn
+ | AssignCode _ ->
+ (* XXX *)
+
+ (* The result of AssignCode is always true (else it would
+ * have exited earlier). Hence:
+ *)
+ pr " %s = 1;\n" result
+ | ListAssignCode (vs, code) ->
+ let code_fn = function_of_code code in
+ pr " %s = %s (&env);\n" result code_fn;
+ pr " if (%s == -1)\n" result;
+ pr " error (EXIT_FAILURE, 0, \"code returned error in %%s\",\n";
+ pr " \"%s\");\n" (string_of_term rule.head);
+ (* The result of ListAssignCode is always true (else it would
+ * have exited above). Hence:
+ *)
+ pr " %s = 1;\n" result
+ | And (e1, e2) ->
+ let re1 = sprintf "r_%d" (unique ()) in
+ pr " int %s;\n" re1;
+ eval re1 e1;
+ pr " if (%s != 1)\n" re1;
+ pr " %s = %s;\n" result re1;
+ pr " else {\n";
+ let re2 = sprintf "r_%d" (unique ()) in
+ pr " int %s;\n" re2;
+ eval re2 e2;
+ pr " %s = %s;\n" result re2;
+ pr " }\n";
+ | Or (e1, e2) ->
+ let re1 = sprintf "r_%d" (unique ()) in
+ pr " int %s;\n" re1;
+ eval re1 e1;
+ pr " if (%s == 1)\n" re1;
+ pr " %s = %s;\n" result re1;
+ pr " else {\n";
+ let re2 = sprintf "r_%d" (unique ()) in
+ pr " int %s;\n" re2;
+ eval re2 e2;
+ pr " %s = %s;\n" result re2;
+ pr " }\n";
+ | Term term ->
+ pr " {\n";
+ pr " CLEANUP_FREE fact *fact = create_fact (%S" term.term_name;
+ List.iter (
+ function
+ | Variable v -> pr ", env.%s" v
+ | Constant s -> pr ", %S" s
+ ) term.term_args;
+ pr ", NULL);\n";
+ pr " %s = is_fact (true, fact);\n" result;
+ pr " }\n";
+ | Not term ->
+ pr " {\n";
+ pr " CLEANUP_FREE fact *fact = create_fact (%S" term.term_name;
+ List.iter (
+ function
+ | Variable v -> pr ", env.%s" v
+ | Constant s -> pr ", %S" s
+ ) term.term_args;
+ pr ", NULL);\n";
+ pr " %s = is_fact (false, fact);\n" result;
+ pr " }\n";
+ in
+ pr " /* Evaluate the RHS of the rule with this assignment of variables. */\n";
+ pr " int result;\n";
+ eval "result" rule.body;
+ pr " if (result == -1) /* not determined */ continue;\n";
+ let make_fact ?i ?(indent = 2) () =
+ let indent = spaces indent in
+ pr "%sCLEANUP_FREE fact *fact = create_fact (%S" indent rule.head.term_name;
+ List.iter (
+ function
+ | Variable v ->
+ if not (List.mem v env.list_assign_vars) then
+ pr ", env.%s" v
+ else (
+ let i = match i with Some i -> i | None -> assert false in
+ pr ", env.%s[%s]" v i
+ )
+ | Constant s -> pr ", %S" s
+ ) rule.head.term_args;
+ pr ", NULL);\n";
+ in
+ pr " if (result > 0) /* true */ {\n";
+ if env.list_assign_vars = [] then (
+ make_fact ~indent:4 ();
+ pr " added = add_fact (true, fact);\n";
+ pr " if (added && verbose) {\n";
+ pr " printf (\"added new fact \");\n";
+ pr " print_fact (true, fact, stdout);\n";
+ pr " printf (\"\\n\");\n";
+ pr " }\n";
+ ) else (
+ pr " for (i = 0; i < env.nr_list_assign_vars; ++i) {\n";
+ make_fact ~i:"i" ~indent:6 ();
+ pr " added = add_fact (true, fact);\n";
+ pr " if (added && verbose) {\n";
+ pr " printf (\"added new fact \");\n";
+ pr " print_fact (true, fact, stdout);\n";
+ pr " printf (\"\\n\");\n";
+ pr " }\n";
+ pr " }\n";
+ );
+ pr " }\n";
+ pr " if (result == 0) /* false */ {\n";
+ if env.list_assign_vars = [] then (
+ make_fact ~indent:4 ();
+ pr "\n";
+ pr " added = add_fact (false, fact);\n";
+ pr " if (added && verbose) {\n";
+ pr " printf (\"added new fact \");\n";
+ pr " print_fact (false, fact, stdout);\n";
+ pr " printf (\"\\n\");\n";
+ pr " }\n";
+ ) else (
+ pr " for (i = 0; i < env.nr_list_assign_vars; ++i) {\n";
+ make_fact ~i:"i" ~indent:6 ();
+ pr " added = add_fact (false, fact);\n";
+ pr " if (added && verbose) {\n";
+ pr " printf (\"added new fact \");\n";
+ pr " print_fact (false, fact, stdout);\n";
+ pr " printf (\"\\n\");\n";
+ pr " }\n";
+ pr " }\n";
+ );
+ pr " }\n";
+
+ (* Free any assign_vars and list_assign_vars. The free_vars don't
+ * have to be freed because the iterator loop handles them.
+ *)
+ List.iter (pr " free (env.%s);\n") env.assign_vars;
+ List.iter (
+ fun v ->
+ pr " for (size_t i = 0; i < env.nr_list_assign_vars; ++i)\n";
+ pr " free (env.%s[i]);\n" v;
+ pr " free (env.%s);\n" v
+ ) env.list_assign_vars;
+
+ if free_vars <> [] then (
+ List.iter (
+ fun (v, _) ->
+ pr " }\n";
+ pr " gl_oset_iterator_free (&iter_%s);\n" v
+ ) (List.rev free_vars);
+ ) else (
+ pr " } while (0);\n";
+ );
+ pr "\n";
+
+ List.iter (
+ function
+ | v, _ ->
+ pr " gl_oset_free (search_%s);\n" v
+ ) free_vars;
+
+ pr "}\n";
+ pr "\n"
+
+(* Compile a (boolean) Code snippet from a rule into a function. *)
+and compile_code filename i rule env j code =
+ let code_fn = sprintf "rule_%d_code_%d" i j in
+ Hashtbl.add code_hash code code_fn;
+
+ pr "static int\n";
+ pr "%s (struct %s *env)\n" code_fn env.env_struct;
+ pr "{\n";
+ List.iter (fun v -> pr "#define %s (env->%s)\n" v v) env.free_vars;
+ (* XXX # lineno *)
+ pr "%s\n" code;
+ List.iter (pr "#undef %s\n") env.free_vars;
+ pr "}\n";
+ pr "\n";
+
+(* Compile a list assignment code (ListAssignCode) snippet
+ * into a function.
+ *)
+and compile_list_assign_code filename i rule env j vs code =
+ (* Create a function for setting a row in the result. *)
+ let set_vars_fn = sprintf "rule_%d_code_%d_set_row" i j in
+ let set_vars_alias = sprintf "set_%s" (String.concat "_" vs) in
+ pr "static void\n";
+ pr "%s (struct %s *env, ...)\n" set_vars_fn env.env_struct;
+ pr "{\n";
+ pr " va_list args;\n";
+ pr " size_t i = env->nr_list_assign_vars;\n";
+ pr "\n";
+ pr " va_start (args, env);\n";
+ List.iter (
+ fun v ->
+ pr " env->%s = realloc (env->%s, (i+1) * sizeof (char *));\n" v v;
+ pr " if (env->%s == NULL)\n" v;
+ pr " error (EXIT_FAILURE, errno, \"realloc\");\n";
+ pr " env->%s[i] = strdup (va_arg (args, char *));\n" v;
+ pr " if (env->%s[i] == NULL)\n" v;
+ pr " error (EXIT_FAILURE, errno, \"strdup\");\n";
+ ) vs;
+ pr " va_end (args);\n";
+ pr " env->nr_list_assign_vars++;\n";
+ pr "}\n";
+ pr "\n";
+
+ (* Create the function itself. *)
+ let code_fn = sprintf "rule_%d_code_%d" i j in
+ Hashtbl.add code_hash code code_fn;
+
+ pr "static int\n";
+ pr "%s (struct %s *env)\n" code_fn env.env_struct;
+ pr "{\n";
+ List.iter (fun v -> pr "#define %s (env->%s)\n" v v) env.free_vars;
+ pr "#define %s(v1,...) %s (env, (v1), ##__VA_ARGS__)\n"
+ set_vars_alias set_vars_fn;
+ (* XXX # lineno *)
+ pr "%s\n" code;
+ List.iter (pr "#undef %s\n") env.free_vars;
+ pr "#undef %s\n" set_vars_alias;
+ pr "}\n";
+ pr "\n";
+
+(* Map of code to function names. *)
+and code_hash = Hashtbl.create 13
+and function_of_code code = Hashtbl.find code_hash code
+
+(* Parse the input. *)
+and parse filename =
+ let lexbuf = Lexing.from_channel (open_in filename) in
+ let rules = ref [] in
+ (try
+ while true do
+ let rule = Rules_parser.rule Rules_scanner.token lexbuf in
+ (*printf "%s\n" (string_of_rule rule);*)
+ rules := rule :: !rules
+ done
+ with
+ | End_of_file -> ()
+ | Rules_scanner.Error (msg, _, lineno, charno) ->
+ eprintf "%s: %d: %d: %s\n" filename lineno charno msg;
+ exit 1
+ | Parsing.Parse_error ->
+ let p = Lexing.lexeme_start_p lexbuf in
+ eprintf "%s: %d: %d: syntax error\n"
+ filename
+ p.Lexing.pos_lnum
+ (p.Lexing.pos_cnum - p.Lexing.pos_bol);
+ exit 1
+ );
+ let rules = List.rev !rules in
+ rules
+
+(* Minimal type checking. *)
+and type_checking filename rules =
+ check_term_rhs filename rules;
+ check_term_arity filename rules
+
+(* If a term appears on the right hand side in any expression, then
+ * the term must also appear on the left hand side of a rule.
+ *)
+and check_term_rhs filename rules =
+ let names = List.map (fun { head = { term_name = name } } -> name) rules in
+ let names =
+ List.fold_left (fun set x -> StringSet.add x set) StringSet.empty names in
+
+ let errors = ref 0 in
+ List.iter (
+ fun { body = body } ->
+ visit_terms (
+ fun { term_name = name } ->
+ if not (StringSet.mem name names) then (
+ eprintf "%s: '%s' appears in a rule expression, but does not appear on the left hand side of any rule. Maybe there is a typo?\n"
+ filename name;
+ incr errors
+ )
+ ) body
+ ) rules;
+ if !errors > 0 then exit 1
+
+(* Check the arity of terms is the same wherever they appear. *)
+and check_term_arity filename rules =
+ let hash = Hashtbl.create (List.length rules) in (* name -> arity *)
+
+ let errors = ref 0 in
+
+ let check_arity { term_name = name; term_args = args } =
+ let arity = List.length args in
+ try
+ let expected_arity = Hashtbl.find hash name in
+ if arity <> expected_arity then (
+ eprintf "%s: '%s' has different number of parameters (has %d, expected %d). It must have the same number of parameters throughout the program.\n"
+ filename name arity expected_arity;
+ incr errors
+ )
+ with
+ (* The first time we've seen this term. *)
+ Not_found -> Hashtbl.add hash name arity
+ in
+
+ List.iter (
+ fun { head = head; body = body } ->
+ check_arity head;
+ visit_terms check_arity body
+ ) rules;
+
+ if !errors > 0 then exit 1
+
+and visit_terms f = function
+ | And (e1, e2)
+ | Or (e1, e2) -> visit_terms f e1; visit_terms f e2
+ | Term t
+ | Not t -> f t
+ | True | False | Code _ | AssignCode _ | ListAssignCode _ -> ()
+
+and unique =
+ let i = ref 0 in
+ fun () -> incr i; !i
diff --git a/generator/rules_compiler.mli b/generator/rules_compiler.mli
new file mode 100644
index 0000000..2bc5274
--- /dev/null
+++ b/generator/rules_compiler.mli
@@ -0,0 +1,21 @@
+(* libguestfs
+ * Copyright (C) 2009-2015 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *)
+
+(* This is the compiler that turns inspection rules into C code. *)
+
+val compile : string -> unit -> unit
diff --git a/generator/rules_parser.mly b/generator/rules_parser.mly
new file mode 100644
index 0000000..bdf6159
--- /dev/null
+++ b/generator/rules_parser.mly
@@ -0,0 +1,111 @@
+/* libguestfs -*- text -*-
+ * Copyright (C) 2009-2015 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+%{
+open Types
+%}
+
+%token <string> STRING /* string literal */
+%token <string> UID /* uppercase identifier */
+%token <string> LID /* lowercase identifier */
+
+%token TRUE /* true (keyword) */
+%token FALSE /* false (keyword) */
+
+%token LPAREN RPAREN /* ( ... ) */
+%token LSQUARE RSQUARE /* [ ... ] */
+%token <string> CODE /* {{ .. }} containing C code */
+%token DOT /* . */
+%token IMPLIC /* :- */
+%token COMMA /* , (AND operator) */
+%token SEMI /* , (OR operator) */
+%token NOT /* ! */
+%token EQUALS /* = */
+
+/* These operators are arranged from lowest to highest precedence. */
+%left IMPLIC
+%left SEMI
+%left COMMA
+%nonassoc NOT
+
+%start rule
+%type <Types.rule> rule
+
+%%
+
+rule: head DOT
+ { { head = $1; body = True } }
+ | head IMPLIC body DOT
+ { { head = $1; body = $3 } }
+ ;
+
+head: term
+ { $1 }
+ ;
+
+term: UID
+ { { term_name = $1; term_args = [] } }
+ | UID LPAREN term_args RPAREN
+ { { term_name = $1; term_args = $3 } }
+ ;
+
+term_args:
+ term_arg
+ { [ $1 ] }
+ | term_arg COMMA term_args
+ { $1 :: $3 }
+ ;
+
+term_arg:
+ LID
+ { Variable $1 }
+ | STRING
+ { Constant $1 }
+ ;
+
+body: expr
+ { $1 }
+ ;
+
+expr: TRUE
+ { True }
+ | FALSE
+ { False }
+ | term
+ { Term $1 }
+ | CODE
+ { Code $1 }
+ | LPAREN result_bindings RPAREN EQUALS CODE
+ { AssignCode ($2, $5) }
+ | LSQUARE result_bindings RSQUARE EQUALS CODE
+ { ListAssignCode ($2, $5) }
+ | NOT term
+ { Not $2 }
+ | expr COMMA expr
+ { And ($1, $3) }
+ | expr SEMI expr
+ { Or ($1, $3) }
+ | LPAREN expr RPAREN
+ { $2 }
+ ;
+
+result_bindings:
+ LID
+ { [ $1 ] }
+ | LID COMMA result_bindings
+ { $1 :: $3 }
diff --git a/generator/rules_scanner.mll b/generator/rules_scanner.mll
new file mode 100644
index 0000000..58c959d
--- /dev/null
+++ b/generator/rules_scanner.mll
@@ -0,0 +1,112 @@
+(* libguestfs -*- text -*-
+ * Copyright (C) 2009-2015 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *)
+
+{
+open Rules_parser
+
+let string_of_lexbuf = Lexing.lexeme
+
+(* Errors raised by the lexer. *)
+exception Error of string * string * int * int
+
+let raise_error lexbuf msg =
+ let p = Lexing.lexeme_start_p lexbuf in
+ raise (Error (msg, p.Lexing.pos_fname,
+ p.Lexing.pos_lnum,
+ p.Lexing.pos_cnum - p.Lexing.pos_bol))
+
+(* Store "..." strings. *)
+let string_buf = Buffer.create 256
+let reset_string_buffer () = Buffer.clear string_buf
+let store_string_char c = Buffer.add_char string_buf c
+let get_string_buffer () = Buffer.contents string_buf
+
+let char_for_backslash = function
+ | 'n' -> '\010'
+ | 'r' -> '\013'
+ | 'b' -> '\008'
+ | 't' -> '\009'
+ | c -> c
+
+(* Store {{ CODE }} sections. *)
+let code_buf = Buffer.create 256
+let reset_code_buffer () = Buffer.clear code_buf
+let store_code_char c = Buffer.add_char code_buf c
+let get_code_buffer () = Buffer.contents code_buf
+}
+
+(* Characters that can appear within an identifier (after the first
+ * character which is treated specially below).
+ *)
+let id_char = ['a'-'z' 'A'-'Z' '0'-'9' '_']
+
+(* Whitespace. *)
+let ws = [' ' '\t']
+
+(* Backslash escapes within strings. *)
+let backslash_escapes = ['\\' '\'' '"' 'n' 't' 'b' 'r']
+
+rule token = parse
+ | "/*" { comment lexbuf; token lexbuf }
+ | '(' { LPAREN }
+ | ')' { RPAREN }
+ | '[' { LSQUARE }
+ | ']' { RSQUARE }
+ | '=' { EQUALS }
+ | '.' { DOT }
+ | ":-" { IMPLIC }
+ | ',' { COMMA }
+ | ';' { SEMI }
+ | '!' { NOT }
+ | '"' { reset_string_buffer ();
+ string lexbuf;
+ STRING (get_string_buffer ()) }
+ | "{{" { reset_code_buffer ();
+ code lexbuf;
+ CODE (get_code_buffer ()) }
+ | "true" { TRUE }
+ | "false" { FALSE }
+ | ['A'-'Z'] id_char* { UID (string_of_lexbuf lexbuf) }
+ | ['a'-'z' '_'] id_char* { LID (string_of_lexbuf lexbuf) }
+ | '\n' { Lexing.new_line lexbuf; token lexbuf }
+ | ws { token lexbuf }
+ | eof { raise End_of_file }
+ | _ { raise_error lexbuf "unexpected character in input" }
+
+(* Discard C-style comments. *)
+and comment = parse
+ | "*/" { () }
+ | eof { raise_error lexbuf "unterminated comment" }
+ | '\n' { Lexing.new_line lexbuf; comment lexbuf }
+ | _ { comment lexbuf }
+
+(* Store "..." strings. *)
+and string = parse
+ | '"' { () }
+ | eof { raise_error lexbuf "unterminated string" }
+ | '\n' { raise_error lexbuf "strings cannot contain newline characters" }
+ | '\\' (backslash_escapes as c)
+ { store_string_char (char_for_backslash c); string lexbuf }
+ | _ as c { store_string_char c; string lexbuf }
+
+(* Store {{ ... }} (CODE) sections containing C code. *)
+and code = parse
+ | "}}" { () }
+ | eof { raise_error lexbuf "unterminated code section" }
+ | '\n' as c { Lexing.new_line lexbuf; store_code_char c; code lexbuf }
+ | _ as c { store_code_char c; code lexbuf }
diff --git a/generator/types.ml b/generator/types.ml
index f2d9750..dea94a7 100644
--- a/generator/types.ml
+++ b/generator/types.ml
@@ -18,6 +18,8 @@
(* Please read generator/README first. *)
+open Printf
+
(* Types used to describe the API. *)
type style = ret * args * optargs
@@ -421,3 +423,50 @@ type call_optargt =
| CallOInt64 of string * int64
| CallOString of string * string
| CallOStringList of string * string list
+
+(* Used by the rules compiler. *)
+
+type rule = { head : term; body : expr }
+(* The type of a parsed rule from the source. *)
+
+and term = { term_name : string; term_args : term_arg list }
+
+and term_arg = Variable of string | Constant of string
+
+and expr =
+ | True (* used for facts *)
+ | False (* false (keyword) *)
+ | Term of term
+ | Not of term (* ! term *)
+ | And of expr * expr (* expr, expr *)
+ | Or of expr * expr (* expr; expr *)
+ | Code of string (* {{ ... }} *)
+ | AssignCode of string list * string (* (a,b)={{ ... }} *)
+ | ListAssignCode of string list * string (* [a,b]={{ ... }} *)
+
+let rec string_of_rule { head = head; body = body } =
+ sprintf "%s :-\n\t%s." (string_of_term head) (string_of_expr body)
+
+and string_of_term = function
+ | { term_name = term_name; term_args = [] } ->
+ sprintf "%s" term_name
+ | { term_name = term_name; term_args = args } ->
+ sprintf "%s(%s)" term_name
+ (String.concat ", " (List.map string_of_term_arg args))
+
+and string_of_term_arg = function
+ | Variable s -> s
+ | Constant s -> sprintf "%S" s
+
+and string_of_expr = function
+ | True -> "true"
+ | False -> "true"
+ | Term term -> string_of_term term
+ | Not term -> sprintf "!%s" (string_of_term term)
+ | And (e1, e2) -> sprintf "(%s,%s)" (string_of_expr e1) (string_of_expr e2)
+ | Or (e1, e2) -> sprintf "(%s;%s)" (string_of_expr e1) (string_of_expr e2)
+ | Code _ -> "{{ // code }}"
+ | AssignCode (bindings, _) ->
+ sprintf "(%s)={{ // code }}" (String.concat ", " bindings)
+ | ListAssignCode (bindings, _) ->
+ sprintf "[%s]={{ // code }}" (String.concat ", " bindings)
diff --git a/generator/utils.ml b/generator/utils.ml
index 7d47430..6b4497d 100644
--- a/generator/utils.ml
+++ b/generator/utils.ml
@@ -231,6 +231,22 @@ let mapi f xs =
in
loop 0 xs
+let uniq ?(cmp = Pervasives.compare) xs =
+ let rec loop acc = function
+ | [] -> acc
+ | [x] -> x :: acc
+ | x :: (y :: _ as xs) when cmp x y = 0 ->
+ loop acc xs
+ | x :: (y :: _ as xs) ->
+ loop (x :: acc) xs
+ in
+ List.rev (loop [] xs)
+
+let sort_uniq ?(cmp = Pervasives.compare) xs =
+ let xs = List.sort cmp xs in
+ let xs = uniq ~cmp xs in
+ xs
+
let count_chars c str =
let count = ref 0 in
for i = 0 to String.length str - 1 do
diff --git a/generator/utils.mli b/generator/utils.mli
index e0f30c3..392e9d6 100644
--- a/generator/utils.mli
+++ b/generator/utils.mli
@@ -84,6 +84,12 @@ val iteri : (int -> 'a -> unit) -> 'a list -> unit
val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
+val uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list
+ (** Uniquify a list (the list must be sorted first). *)
+
+val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list
+ (** Sort and uniquify a list. *)
+
val count_chars : char -> string -> int
(** Count number of times the character occurs in string. *)
diff --git a/m4/guestfs_ocaml.m4 b/m4/guestfs_ocaml.m4
index b3e9387..e213f80 100644
--- a/m4/guestfs_ocaml.m4
+++ b/m4/guestfs_ocaml.m4
@@ -29,6 +29,8 @@ AS_IF([test "x$enable_ocaml" != "xno"],[
OCAMLFIND=
AC_PROG_OCAML
AC_PROG_FINDLIB
+ AC_PROG_OCAMLLEX
+ AC_PROG_OCAMLYACC
dnl OCaml >= 3.11 is required.
AC_MSG_CHECKING([if OCaml version >= 3.11])
--
2.5.0
More information about the Libguestfs
mailing list