let merge_current ~degenerate =
Value_parameters.debug "merge phase 1";
let treat_instr k record =
let current_state = Db.Value.noassert_get_state k in
let is_top_already =
Relations_type.Model.equal Relations_type.Model.empty current_state
in
if not is_top_already
then begin
let sum = State_set.join_dropping_relations record.superposition in
Value_parameters.debug "merge: join done" ;
Db.Value.update_table k sum
end
in
InstrHashtbl.iter treat_instr current_table;
Value_parameters.debug "merge phase 2";
if not degenerate &&
((not (Db.Value.Record_Value_Callbacks.is_empty ())) ||
(not (Db.Value.Record_Value_Superposition_Callbacks.is_empty ())))
then begin
let stack_for_callbacks = for_callbacks_stack () in
if not (Db.Value.Record_Value_Superposition_Callbacks.is_empty ())
then begin
let current_superpositions =
InstrHashtbl.create (InstrHashtbl.length current_table)
in
InstrHashtbl.iter
(fun k record ->
InstrHashtbl.add current_superpositions k record.superposition)
current_table;
Value_parameters.feedback "now calling Record_Value_Superposition callbacks";
Db.Value.Record_Value_Superposition_Callbacks.apply
(stack_for_callbacks, current_superpositions);
end ;
if not (Db.Value.Record_Value_Callbacks.is_empty ())
then begin
Value_parameters.feedback "now calling Record_Value callbacks";
let current_states =
InstrHashtbl.create (InstrHashtbl.length current_table)
in
InstrHashtbl.iter
(fun k record ->
InstrHashtbl.add current_states k
(State_set.join_dropping_relations record.superposition))
current_table;
Db.Value.Record_Value_Callbacks.apply
(stack_for_callbacks, current_states);
end
end;
Value_parameters.debug "merge phase 3";
InstrHashtbl.clear current_table;
Value_parameters.debug "merge phase 4"