- mutable cache4 : NodeStatus.t Cache.N4.t;
- }
-
- let pass r = r.pass
- let stable r = not r.redo
- let auto r = r.auto
- let tree r = r.tree
-
-
- let dummy_trl =
- Ata.(TransList.cons
- (Transition.make
- (State.dummy,QNameSet.empty, Formula.false_))
- TransList.nil)
-
- let make auto tree =
- let len = T.size tree in
- {
- tree = tree;
- auto = auto;
- status = Array.create len dummy_status;
- unstable = Bitvector.create ~init:true len;
- redo = true;
- pass = 0;
- cache2 = Cache.N2.create dummy_trl;
- cache4 = Cache.N4.create dummy_status;
- }
-
- let get_status a i =
- if i < 0 then dummy_status else Array.get a i
-
- let unsafe_get_status a i =
- if i < 0 then dummy_status else Array.unsafe_get a i
-
-IFDEF HTMLTRACE
- THEN
-DEFINE TRACE(e) = (e)
- ELSE
-DEFINE TRACE(e) = ()
-END
-
- let html tree node i config msg =
- let config = config.NodeStatus.node in
- Html.trace (T.preorder tree node) i
- "node: %i<br/>%s<br/>sat: %a<br/>unsat: %a<br/>todo: %around: %i<br/>"
- (T.preorder tree node)
- msg
- StateSet.print config.sat
- StateSet.print config.unsat
- (Ata.TransList.print ~sep:"<br/>") config.todo i
-
-
- let debug msg tree node i config =
- let config = config.NodeStatus.node in
- eprintf
- "DEBUG:%s node: %i\nsat: %a\nunsat: %a\ntodo: %around: %i\n"
- msg
- (T.preorder tree node)
- StateSet.print config.sat
- StateSet.print config.unsat
- (Ata.TransList.print ~sep:"\n") config.todo i
-
-
- let get_trans cache2 auto tag states =
- let trs =
- Cache.N2.find cache2
- (tag.QName.id :> int) (states.StateSet.id :> int)
- in
- if trs == dummy_trl then
- let trs = Ata.get_trans auto tag states in
- (Cache.N2.add
- cache2
- (tag.QName.id :> int)
- (states.StateSet.id :> int) trs; trs)
- else trs
-
-
-
- let simplify_atom atom pos q { NodeStatus.node = status; _ } =
- if (pos && StateSet.mem q status.sat)
- || ((not pos) && StateSet.mem q status.unsat) then Ata.Formula.true_
- else if (pos && StateSet.mem q status.unsat)
- || ((not pos) && StateSet.mem q status.sat) then Ata.Formula.false_
- else atom
-
-
- let eval_form phi fcs nss ps ss summary =
- let open Ata in
- let rec loop phi =
- begin match Formula.expr phi with
- Boolean.True | Boolean.False -> phi
- | Boolean.Atom (a, b) ->
- begin
- let open NodeSummary in
- match a.Atom.node with
- | Move (m, q) ->
- let states = match m with
- `First_child -> fcs
- | `Next_sibling -> nss
- | `Parent | `Previous_sibling -> ps
- | `Stay -> ss
- in simplify_atom phi b q states
- | Is_first_child -> Formula.of_bool (b == is_left summary)
- | Is_next_sibling -> Formula.of_bool (b == is_right summary)
- | Is k -> Formula.of_bool (b == (k == kind summary))
- | Has_first_child -> Formula.of_bool (b == has_left summary)
- | Has_next_sibling -> Formula.of_bool (b == has_right summary)
- end
- | Boolean.And(phi1, phi2) -> Formula.and_ (loop phi1) (loop phi2)
- | Boolean.Or (phi1, phi2) -> Formula.or_ (loop phi1) (loop phi2)
- end
- in
- loop phi
-
-
- let eval_trans_aux cache4 fcs nss ps ss old_config =
- let { sat = old_sat;
- unsat = old_unsat;
- todo = old_todo;
- summary = old_summary } = old_config.NodeStatus.node
- in
- let sat, unsat, removed, kept, todo =
- Ata.TransList.fold
- (fun trs acc ->
- let q, lab, phi = Ata.Transition.node trs in
- let a_sat, a_unsat, a_rem, a_kept, a_todo = acc in
- if StateSet.mem q a_sat || StateSet.mem q a_unsat then acc else
- let new_phi =
- eval_form phi fcs nss ps old_config old_summary
- in
- if Ata.Formula.is_true new_phi then
- StateSet.add q a_sat, a_unsat, StateSet.add q a_rem, a_kept, a_todo
- else if Ata.Formula.is_false new_phi then
- a_sat, StateSet.add q a_unsat, StateSet.add q a_rem, a_kept, a_todo
- else
- let new_tr = Ata.Transition.make (q, lab, new_phi) in
- (a_sat, a_unsat, a_rem, StateSet.add q a_kept, (Ata.TransList.cons new_tr a_todo))
- ) old_todo (old_sat, old_unsat, StateSet.empty, StateSet.empty, Ata.TransList.nil)
- in
- (* States that have been removed from the todo list and not kept are now
- unsatisfiable *)
- let unsat = StateSet.union unsat (StateSet.diff removed kept) in
- (* States that were found once to be satisfiable remain so *)
- let unsat = StateSet.diff unsat sat in
- let new_config = NodeStatus.make { old_config.NodeStatus.node with sat; unsat; todo; } in
- new_config
-
-
- let eval_trans cache4 fcs nss ps ss =
- let fcsid = (fcs.NodeStatus.id :> int) in
- let nssid = (nss.NodeStatus.id :> int) in
- let psid = (ps.NodeStatus.id :> int) in
- let rec loop old_config =
- let oid = (old_config.NodeStatus.id :> int) in
- let res =
- let res = Cache.N4.find cache4 oid fcsid nssid psid in
- if res != dummy_status then res
- else
- let new_config =
- eval_trans_aux cache4 fcs nss ps ss old_config
- in
- Cache.N4.add cache4 oid fcsid nssid psid new_config;
- new_config
- in
- if res == old_config then res else loop res
- in
- loop ss
+ 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
+