simon/sidekick
1
0
Fork 0
mirror of https://github.com/c-cube/sidekick.git synced 2025-12-06 03:05:31 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

feat(cc): remove callbacks, return list of actions

Browse source
This commit is contained in:
Simon Cruanes 2022-07-21 23:21:07 -04:00
parent 6694ce856b
commit dc68a60151
No known key found for this signature in database
GPG key ID: EBFFF6F283F3A2B4
2 changed files with 351 additions and 276 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

556
src/cc/Sidekick_cc.ml
View file

File diff suppressed because it is too large Load diff

71
src/cc/plugin/sidekick_cc_plugin.ml
View file

@ -3,11 +3,11 @@ open Sidekick_sigs_cc
module type EXTENDED_PLUGIN_BUILDER = sig
include MONOID_PLUGIN_BUILDER
val mem : t -> M.CC.Class.t -> bool
(** Does the CC Class.t have a monoid value? *)
val mem : t -> M.CC.E_node.t -> bool
(** Does the CC E_node.t have a monoid value? *)
val get : t -> M.CC.Class.t -> M.t option
(** Get monoid value for this CC Class.t, if any *)
val get : t -> M.CC.E_node.t -> M.t option
(** Get monoid value for this CC E_node.t, if any *)
val iter_all : t -> (M.CC.repr * M.t) Iter.t
@ -19,8 +19,8 @@ module Make (M : MONOID_PLUGIN_ARG) :
EXTENDED_PLUGIN_BUILDER with module M = M = struct
module M = M
module CC = M.CC
module Class = CC.Class
module Cls_tbl = Backtrackable_tbl.Make (Class)
module E_node = CC.E_node
module Cls_tbl = Backtrackable_tbl.Make (E_node)
module Expl = CC.Expl
type term = CC.term
@ -41,7 +41,7 @@ module Make (M : MONOID_PLUGIN_ARG) :
let values : M.t Cls_tbl.t = Cls_tbl.create ?size ()
(* bit in CC to filter out quickly classes without value *)
let field_has_value : CC.Class.bitfield =
let field_has_value : CC.E_node.bitfield =
CC.allocate_bitfield ~descr:("monoid." ^ M.name ^ ".has-value") cc
let push_level () = Cls_tbl.push_level values
@ -69,8 +69,8 @@ module Make (M : MONOID_PLUGIN_ARG) :
(match maybe_m with
| Some v ->
Log.debugf 20 (fun k ->
k "(@[monoid[%s].on-new-term@ :n %a@ :value %a@])" M.name Class.pp n
M.pp v);
k "(@[monoid[%s].on-new-term@ :n %a@ :value %a@])" M.name E_node.pp
n M.pp v);
CC.set_bitfield cc field_has_value true n;
Cls_tbl.add values n v
| None -> ());
@ -78,25 +78,25 @@ module Make (M : MONOID_PLUGIN_ARG) :
(fun (n_u, m_u) ->
Log.debugf 20 (fun k ->
k "(@[monoid[%s].on-new-term.sub@ :n %a@ :sub-t %a@ :value %a@])"
M.name Class.pp n Class.pp n_u M.pp m_u);
M.name E_node.pp n E_node.pp n_u M.pp m_u);
let n_u = CC.find cc n_u in
if CC.get_bitfield cc field_has_value n_u then (
let m_u' =
try Cls_tbl.find values n_u
with Not_found ->
Error.errorf "node %a has bitfield but no value" Class.pp n_u
Error.errorf "node %a has bitfield but no value" E_node.pp n_u
in
match M.merge cc n_u m_u n_u m_u' (Expl.mk_list []) with
| Error expl ->
Error.errorf
"when merging@ @[for node %a@],@ values %a and %a:@ conflict %a"
Class.pp n_u M.pp m_u M.pp m_u' CC.Expl.pp expl
E_node.pp n_u M.pp m_u M.pp m_u' CC.Expl.pp expl
| Ok m_u_merged ->
Log.debugf 20 (fun k ->
k
"(@[monoid[%s].on-new-term.sub.merged@ :n %a@ :sub-t %a@ \
:value %a@])"
M.name Class.pp n Class.pp n_u M.pp m_u_merged);
M.name E_node.pp n E_node.pp n_u M.pp m_u_merged);
Cls_tbl.add values n_u m_u_merged
) else (
(* just add to [n_u] *)
@ -108,30 +108,33 @@ module Make (M : MONOID_PLUGIN_ARG) :
let iter_all : _ Iter.t = Cls_tbl.to_iter values
let on_pre_merge cc acts n1 n2 e_n1_n2 : unit =
match get n1, get n2 with
| Some v1, Some v2 ->
Log.debugf 5 (fun k ->
k
"(@[monoid[%s].on_pre_merge@ (@[:n1 %a@ :val1 %a@])@ (@[:n2 %a@ \
:val2 %a@])@])"
M.name Class.pp n1 M.pp v1 Class.pp n2 M.pp v2);
(match M.merge cc n1 v1 n2 v2 e_n1_n2 with
| Ok v' ->
Cls_tbl.remove values n2;
(* only keep repr *)
Cls_tbl.add values n1 v'
| Error expl -> CC.raise_conflict_from_expl cc acts expl)
| None, Some cr ->
CC.set_bitfield cc field_has_value true n1;
Cls_tbl.add values n1 cr;
Cls_tbl.remove values n2 (* only keep reprs *)
| Some _, None -> () (* already there on the left *)
| None, None -> ()
let on_pre_merge cc n1 n2 e_n1_n2 : CC.actions =
let exception E of M.CC.conflict in
try
match get n1, get n2 with
| Some v1, Some v2 ->
Log.debugf 5 (fun k ->
k
"(@[monoid[%s].on_pre_merge@ (@[:n1 %a@ :val1 %a@])@ (@[:n2 \
%a@ :val2 %a@])@])"
M.name E_node.pp n1 M.pp v1 E_node.pp n2 M.pp v2);
(match M.merge cc n1 v1 n2 v2 e_n1_n2 with
| Ok v' ->
Cls_tbl.remove values n2;
(* only keep repr *)
Cls_tbl.add values n1 v'
| Error expl -> raise (E (CC.Conflict_expl expl)))
| None, Some cr ->
CC.set_bitfield cc field_has_value true n1;
Cls_tbl.add values n1 cr;
Cls_tbl.remove values n2 (* only keep reprs *)
| Some _, None -> () (* already there on the left *)
| None, None -> ()
with E c -> Error c
let pp out () : unit =
let pp_e out (t, v) =
Fmt.fprintf out "(@[%a@ :has %a@])" Class.pp t M.pp v
Fmt.fprintf out "(@[%a@ :has %a@])" E_node.pp t M.pp v
in
Fmt.fprintf out "(@[%a@])" (Fmt.iter pp_e) iter_all