-IFDEF HTMLTRACE
- THEN
-DEFINE IFTRACE(e) = (e)
- ELSE
-DEFINE IFTRACE(e) = ()
-END
-
- let html tree node i config msg =
- let config = config.NodeStatus.node in
- Html.trace ~msg:msg
- (T.preorder tree node) i
- config.todo
- config.sat
-
-
-
- let debug msg tree node i config =
- let config = config.NodeStatus.node in
- eprintf
- "DEBUG:%s node: %i\nsat: %a\ntodo: %a\nround: %i\n"
- msg
- (T.preorder tree node)
- StateSet.print config.sat
- StateSet.print config.todo
- i
-
- let get_form cache2 auto tag q =
- let phi =
- incr cache2_access;
- Cache.N2.find cache2 (tag.QName.id :> int) (q :> int)
- in
- if phi == dummy_form then
- let phi = Ata.get_form auto tag q in
- let () =
- Cache.N2.add
- cache2
- (tag.QName.id :> int)
- (q :> int) phi
- in phi
- else begin
- incr cache2_hit;
- phi
- end
-
- type trivalent = False | True | Unknown
- let of_bool = function false -> False | true -> True
- let or_ t1 t2 =
- match t1 with
- False -> t2
- | True -> True
- | Unknown -> if t2 == True then True else Unknown
-
- let and_ t1 t2 =
- match t1 with
- False -> False
- | True -> t2
- | Unknown -> if t2 == False then False else Unknown
-
- (* Define as macros to get lazyness *)
-DEFINE OR_(t1,t2) =
- match t1 with
- False -> (t2)
- | True -> True
- | Unknown -> if (t2) == True then True else Unknown
-
-DEFINE AND_(t1,t2) =
- match t1 with
- False -> False
- | True -> (t2)
- | Unknown -> if (t2) == False then False else Unknown
-
-
- let eval_form phi fcs nss ps ss summary =
- let open Ata in
- let rec loop phi =
- begin match Formula.expr phi with
- | Boolean.False -> False
- | Boolean.True -> True
- | Boolean.Atom (a, b) ->
- begin
- let open NodeSummary in
- match a.Atom.node with
- | Move (m, q) ->
- let down, ({ NodeStatus.node = n_sum; _ } as sum) =
- match m with
- `First_child -> true, fcs
- | `Next_sibling -> true, nss
- | `Parent | `Previous_sibling -> false, ps
- | `Stay -> false, ss
- in
- if sum == dummy_status
- || (down && n_sum.rank < ss.NodeStatus.node.rank)
- || StateSet.mem q n_sum.todo then
- Unknown
- else
- of_bool (b == StateSet.mem q n_sum.sat)
- | Is_first_child -> of_bool (b == is_left summary)
- | Is_next_sibling -> of_bool (b == is_right summary)
- | Is k -> of_bool (b == (k == kind summary))
- | Has_first_child -> of_bool (b == has_left summary)
- | Has_next_sibling -> of_bool (b == has_right summary)
- end
- | Boolean.And(phi1, phi2) -> AND_ (loop phi1, loop phi2)
- | Boolean.Or (phi1, phi2) -> OR_ (loop phi1, loop phi2)
- end
- in
- loop phi
-
-
- let eval_trans_aux auto cache2 tag fcs nss ps old_status =
- let { sat = old_sat;
- todo = old_todo;
- summary = old_summary } as os_node = old_status.NodeStatus.node
- in
- let sat, todo =
- StateSet.fold (fun q ((a_sat, a_todo) as acc) ->
- let phi =
- get_form cache2 auto tag q
- in
-
- let v = eval_form phi fcs nss ps old_status old_summary in
- match v with
- True -> StateSet.add q a_sat, a_todo
- | False -> acc
- | Unknown -> a_sat, StateSet.add q a_todo
- ) old_todo (old_sat, StateSet.empty)
- in
- if old_sat != sat || old_todo != todo then
- NodeStatus.make { os_node with sat; todo }
- else old_status
-
-
- let eval_trans auto cache2 cache5 tag fcs nss ps ss =
- let rec loop old_status =
- let new_status =
- eval_trans_aux auto cache2 tag fcs nss ps old_status
- in
- if new_status == old_status then old_status else loop new_status
- in
- let fcsid = (fcs.NodeStatus.id :> int) in
- let nssid = (nss.NodeStatus.id :> int) in
- let psid = (ps.NodeStatus.id :> int) in
- let ssid = (ss.NodeStatus.id :> int) in
- let tagid = (tag.QName.id :> int) in
- let res = Cache.N5.find cache5 tagid ssid fcsid nssid psid in
- incr cache5_access;
- if res != dummy_status then begin incr cache5_hit; res end
- else let new_status = loop ss in
- Cache.N5.add cache5 tagid ssid fcsid nssid psid new_status;
- new_status
-
-
-
- let top_down run =
+type 'a run = {
+ tree : 'a ;
+ (* The argument of the run *)
+ auto : Ata.t;
+ (* The automaton to be run *)
+ mutable sat: sat_array;
+ (* A mapping from node preorders to states satisfied at that node *)
+ mutable pass : int;
+ (* Number of run we have performed *)
+ mutable fetch_trans_cache : Ata.Formula.t Cache.N2.t;
+ (* A cache from states * label to list of transitions *)
+ mutable td_cache : StateSet.t Cache.N6.t;
+ mutable bu_cache : StateSet.t Cache.N6.t;
+ (* Two 6-way caches used during the top-down and bottom-up phase
+ label * self-set * fc-set * ns-set * parent-set * node-shape -> self-set
+ *)
+ node_summaries: (int, int16_unsigned_elt, c_layout) Array1.t;
+ stats : stats;
+}
+
+let dummy_form = Ata.Formula.stay State.dummy
+
+let get_form run tag q =
+ let auto = run.auto in
+ let fetch_trans_cache = run.fetch_trans_cache in
+ let stats = run.stats in
+ let phi =
+ stats.fetch_trans_cache_access <- stats.fetch_trans_cache_access + 1;
+ Cache.N2.find fetch_trans_cache (tag.QName.id :> int) (q :> int)
+ in
+ if phi == dummy_form then
+ let phi = Ata.get_form auto tag q in
+ let () =
+ Cache.N2.add
+ fetch_trans_cache
+ (tag.QName.id :> int)
+ (q :> int) phi
+ in phi
+ else begin
+ stats.fetch_trans_cache_hit <- stats.fetch_trans_cache_hit + 1;
+ phi
+ end
+
+
+let eval_form phi fcs nss ps ss summary =
+ let open Ata in
+ let rec loop phi =
+ begin match Formula.expr phi with
+ | Boolean.False -> false
+ | Boolean.True -> true
+ | Boolean.Atom (a, b) ->
+ begin
+ let open NodeSummary in
+ match a.Atom.node with
+ | Move (m, q) ->
+ b && StateSet.mem q (
+ match m with
+ `First_child -> fcs
+ | `Next_sibling -> nss
+ | `Parent | `Previous_sibling -> ps
+ | `Stay -> ss
+ )
+ | Is_first_child -> b == is_left summary
+ | Is_next_sibling -> b == is_right summary
+ | Is k -> b == (k == kind summary)
+ | Has_first_child -> b == has_left summary
+ | Has_next_sibling -> b == has_right summary
+ end
+ | Boolean.And(phi1, phi2) -> loop phi1 && loop phi2
+ | Boolean.Or (phi1, phi2) -> loop phi1 || loop phi2
+ end
+ in
+ loop phi
+
+
+let eval_trans_aux run tag summary fcs nss ps sat todo =
+ StateSet.fold (fun q (a_sat) ->
+ let phi =
+ get_form run tag q
+ in
+ if eval_form phi fcs nss ps a_sat summary then
+ StateSet.add q a_sat
+ else a_sat
+ ) todo sat
+
+
+let rec eval_trans_fix run tag summary fcs nss ps sat todo =
+ let new_sat =
+ eval_trans_aux run tag summary fcs nss ps sat todo
+ in
+ if new_sat == sat then sat else
+ eval_trans_fix run tag summary fcs nss ps new_sat todo
+
+
+let eval_trans run trans_cache tag summary fcs nss ps ss todo =
+ let stats = run.stats in
+ let fcsid = (fcs.StateSet.id :> int) in
+ let nssid = (nss.StateSet.id :> int) in
+ let psid = (ps.StateSet.id :> int) in
+ let ssid = (ss.StateSet.id :> int) in
+ let tagid = (tag.QName.id :> int) in
+
+ let res = Cache.N6.find trans_cache tagid summary ssid fcsid nssid psid in
+ stats.eval_trans_cache_access <- 1 + stats.eval_trans_cache_access;
+ if res != dummy_set then begin
+ stats.eval_trans_cache_hit <- 1 + stats.eval_trans_cache_hit;
+ res
+ end else let new_sat =
+ eval_trans_fix run tag summary fcs nss ps ss todo
+ in
+ Cache.N6.add trans_cache tagid summary ssid fcsid nssid psid new_sat;
+ new_sat
+
+
+module Make (T : Tree.S) (L : Node_list.S with type node = T.node) =
+struct
+
+ let make auto tree =
+ let len = T.size tree in
+ let ba = Array1.create int16_unsigned c_layout len in
+ Array1.fill ba 0;
+ {
+ tree = tree;
+ auto = auto;
+ sat = (let a = Array.create len StateSet.empty in
+ IFHTML([a], a));
+ pass = 0;
+ fetch_trans_cache = Cache.N2.create dummy_form;
+ td_cache = Cache.N6.create dummy_set;
+ bu_cache = Cache.N6.create dummy_set;
+ node_summaries = ba;
+ stats = {
+ pass = 0;
+ tree_size = len;
+ fetch_trans_cache_access = 0;
+ fetch_trans_cache_hit = 0;
+ eval_trans_cache_access = 0;
+ eval_trans_cache_hit = 0;
+ nodes_per_run = [];
+ }
+ }
+
+
+ let top_down run update_res =
+ let num_visited = ref 0 in