From aaee388ad0a3510fa828318a22d1141296fb995c Mon Sep 17 00:00:00 2001
From: Diane Gallois-Wong <diane.gallois-wong@nomadic-labs.com>
Date: Tue, 6 Feb 2024 14:53:30 +0100
Subject: [PATCH 1/4] Proto/AI: rename Slashed_deposits to Already_denounced
 because this is

updated as soon as the denunciation operation is seen, and is used
to reject duplicate denunciations, regardless of whether the slashing
itself (as in the subtracting of tez) has been done yet
---
 .../lib_protocol/alpha_context.mli            |  4 +-
 .../lib_protocol/delegate_cycles.ml           |  2 +-
 .../delegate_slashed_deposits_storage.ml      | 47 ++++++++++---------
 .../delegate_slashed_deposits_storage.mli     | 15 +++---
 src/proto_alpha/lib_protocol/storage.ml       | 14 +++---
 src/proto_alpha/lib_protocol/storage.mli      | 12 +++--
 src/proto_alpha/lib_protocol/validate.ml      |  4 +-
 7 files changed, 52 insertions(+), 46 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli
index 261fd96a8928..9ee05cf86d19 100644
--- a/src/proto_alpha/lib_protocol/alpha_context.mli
+++ b/src/proto_alpha/lib_protocol/alpha_context.mli
@@ -2233,10 +2233,10 @@ module Delegate : sig
     Cycle.t ->
     (context * Receipt.balance_updates * public_key_hash list) tzresult Lwt.t
 
-  val already_slashed_for_double_attesting :
+  val already_denounced_for_double_attesting :
     context -> public_key_hash -> Level.t -> bool tzresult Lwt.t
 
-  val already_slashed_for_double_baking :
+  val already_denounced_for_double_baking :
     context -> public_key_hash -> Level.t -> bool tzresult Lwt.t
 
   type reward_and_burn = {reward : Tez.t; amount_to_burn : Tez.t}
diff --git a/src/proto_alpha/lib_protocol/delegate_cycles.ml b/src/proto_alpha/lib_protocol/delegate_cycles.ml
index a7075bb9f265..9547c9fe549e 100644
--- a/src/proto_alpha/lib_protocol/delegate_cycles.ml
+++ b/src/proto_alpha/lib_protocol/delegate_cycles.ml
@@ -199,7 +199,7 @@ let cycle_end ctxt last_cycle =
   in
   let*! ctxt = Delegate_consensus_key.activate ctxt ~new_cycle in
   let*! ctxt =
-    Delegate_slashed_deposits_storage.clear_outdated_slashed_deposits
+    Delegate_slashed_deposits_storage.clear_outdated_already_denounced
       ctxt
       ~new_cycle
   in
diff --git a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml
index 25463b37ef52..788b25949499 100644
--- a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml
+++ b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml
@@ -25,23 +25,24 @@
 (*                                                                           *)
 (*****************************************************************************)
 
-let already_slashed_for_double_attesting ctxt delegate (level : Level_repr.t) =
+let already_denounced_for_double_attesting ctxt delegate (level : Level_repr.t)
+    =
   let open Lwt_result_syntax in
-  let* slashed_opt =
-    Storage.Slashed_deposits.find (ctxt, level.cycle) (level.level, delegate)
+  let* denounced_opt =
+    Storage.Already_denounced.find (ctxt, level.cycle) (level.level, delegate)
   in
-  match slashed_opt with
+  match denounced_opt with
   | None -> return_false
-  | Some slashed -> return slashed.for_double_attesting
+  | Some denounced -> return denounced.for_double_attesting
 
-let already_slashed_for_double_baking ctxt delegate (level : Level_repr.t) =
+let already_denounced_for_double_baking ctxt delegate (level : Level_repr.t) =
   let open Lwt_result_syntax in
-  let* slashed_opt =
-    Storage.Slashed_deposits.find (ctxt, level.cycle) (level.level, delegate)
+  let* denounced_opt =
+    Storage.Already_denounced.find (ctxt, level.cycle) (level.level, delegate)
   in
-  match slashed_opt with
+  match denounced_opt with
   | None -> return_false
-  | Some slashed -> return slashed.for_double_baking
+  | Some denounced -> return denounced.for_double_baking
 
 type reward_and_burn = {reward : Tez_repr.t; amount_to_burn : Tez_repr.t}
 
@@ -54,36 +55,36 @@ let punish_double_signing ctxt ~operation_hash
     (misbehaviour : Misbehaviour_repr.t) delegate (level : Level_repr.t)
     ~rewarded =
   let open Lwt_result_syntax in
-  let* slashed_opt =
-    Storage.Slashed_deposits.find (ctxt, level.cycle) (level.level, delegate)
+  let* denounced_opt =
+    Storage.Already_denounced.find (ctxt, level.cycle) (level.level, delegate)
   in
-  let slashed =
-    Option.value slashed_opt ~default:Storage.default_slashed_level
+  let denounced =
+    Option.value denounced_opt ~default:Storage.default_denounced
   in
-  let already_slashed, updated_slashed, slashing_percentage =
-    let Storage.{for_double_baking; for_double_attesting} = slashed in
+  let already_denounced, updated_denounced, slashing_percentage =
+    let Storage.{for_double_baking; for_double_attesting} = denounced in
     match misbehaviour.kind with
     | Double_baking ->
         ( for_double_baking,
-          {slashed with for_double_baking = true},
+          {denounced with for_double_baking = true},
           Constants_storage
           .percentage_of_frozen_deposits_slashed_per_double_baking
             ctxt )
     | Double_attesting ->
         ( for_double_attesting,
-          {slashed with for_double_attesting = true},
+          {denounced with for_double_attesting = true},
           Constants_storage
           .percentage_of_frozen_deposits_slashed_per_double_attestation
             ctxt )
   in
-  assert (Compare.Bool.(already_slashed = false)) ;
+  assert (Compare.Bool.(already_denounced = false)) ;
   let delegate_contract = Contract_repr.Implicit delegate in
   let current_cycle = (Raw_context.current_level ctxt).cycle in
   let*! ctxt =
-    Storage.Slashed_deposits.add
+    Storage.Already_denounced.add
       (ctxt, level.cycle)
       (level.level, delegate)
-      updated_slashed
+      updated_denounced
   in
   let* slash_history_opt =
     Storage.Contract.Slashed_deposits.find ctxt delegate_contract
@@ -124,11 +125,11 @@ let punish_double_signing ctxt ~operation_hash
   in
   return ctxt
 
-let clear_outdated_slashed_deposits ctxt ~new_cycle =
+let clear_outdated_already_denounced ctxt ~new_cycle =
   let max_slashable_period = Constants_repr.max_slashing_period in
   match Cycle_repr.(sub new_cycle max_slashable_period) with
   | None -> Lwt.return ctxt
-  | Some outdated_cycle -> Storage.Slashed_deposits.clear (ctxt, outdated_cycle)
+  | Some outdated_cycle -> Storage.Already_denounced.clear (ctxt, outdated_cycle)
 
 let apply_and_clear_denunciations ctxt =
   let open Lwt_result_syntax in
diff --git a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli
index 93bd3cedb4af..7c9f22c5af0e 100644
--- a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli
+++ b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli
@@ -27,21 +27,21 @@
 
 (** This module maintains the storage related to slashing of delegates for
    double signing. In particular, it is responsible for maintaining the
-   {!Storage.Slashed_deposits}, {!Storage.Contract.Slashed_deposits}, and
+   {!Storage.Already_denounced}, {!Storage.Contract.Slashed_deposits}, and
    {!Storage.Pending_denunciations} tables.
 *)
 
-(** Returns true if the given delegate has already been slashed
+(** Returns true if the given delegate has already been denounced
     for double baking for the given level. *)
-val already_slashed_for_double_baking :
+val already_denounced_for_double_baking :
   Raw_context.t ->
   Signature.Public_key_hash.t ->
   Level_repr.t ->
   bool tzresult Lwt.t
 
-(** Returns true if the given delegate has already been slashed
+(** Returns true if the given delegate has already been denounced
     for double preattesting or double attesting for the given level. *)
-val already_slashed_for_double_attesting :
+val already_denounced_for_double_attesting :
   Raw_context.t ->
   Signature.Public_key_hash.t ->
   Level_repr.t ->
@@ -80,7 +80,10 @@ val punish_double_signing :
   rewarded:Signature.public_key_hash ->
   Raw_context.t tzresult Lwt.t
 
-val clear_outdated_slashed_deposits :
+(** Clear the part of {!Storage.Already_denounced} about the cycle
+    [new_cycle - max_slashable_period]. Indeed, denunciations on
+    events which happened during this cycle are no longer allowed. *)
+val clear_outdated_already_denounced :
   Raw_context.t -> new_cycle:Cycle_repr.t -> Raw_context.t Lwt.t
 
 val apply_and_clear_denunciations :
diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml
index 5db19a08d24e..832b1e08d1f7 100644
--- a/src/proto_alpha/lib_protocol/storage.ml
+++ b/src/proto_alpha/lib_protocol/storage.ml
@@ -1090,13 +1090,13 @@ module Pending_denunciations =
 
 (** Per cycle storage *)
 
-type slashed_level = {for_double_attesting : bool; for_double_baking : bool}
+type denounced = {for_double_attesting : bool; for_double_baking : bool}
 
-let default_slashed_level =
+let default_denounced =
   {for_double_attesting = false; for_double_baking = false}
 
-module Slashed_level = struct
-  type t = slashed_level
+module Denounced = struct
+  type t = denounced
 
   let encoding =
     let open Data_encoding in
@@ -1117,14 +1117,14 @@ module Cycle = struct
          end))
          (Make_index (Cycle_repr.Index))
 
-  module Slashed_deposits =
+  module Already_denounced =
     Make_indexed_data_storage
       (Make_subcontext (Registered) (Indexed_context.Raw_context)
          (struct
            let name = ["slashed_deposits"]
          end))
          (Pair (Make_index (Raw_level_repr.Index)) (Public_key_hash_index))
-      (Slashed_level)
+      (Denounced)
 
   module Selected_stake_distribution =
     Indexed_context.Make_map
@@ -1266,7 +1266,7 @@ module Cycle = struct
       (Staking_parameters_repr)
 end
 
-module Slashed_deposits = Cycle.Slashed_deposits
+module Already_denounced = Cycle.Already_denounced
 module Pending_consensus_keys = Cycle.Pending_consensus_keys
 module Pending_staking_parameters = Cycle.Pending_staking_parameters
 
diff --git a/src/proto_alpha/lib_protocol/storage.mli b/src/proto_alpha/lib_protocol/storage.mli
index 4f2565e55148..bbb40a5953af 100644
--- a/src/proto_alpha/lib_protocol/storage.mli
+++ b/src/proto_alpha/lib_protocol/storage.mli
@@ -474,17 +474,19 @@ module Pending_denunciations :
      and type key = Signature.public_key_hash
      and type value = Denunciations_repr.t
 
-type slashed_level = {for_double_attesting : bool; for_double_baking : bool}
+(** This type is used to track which denunciations have already been
+    recorded, to avoid slashing multiple times the same event. *)
+type denounced = {for_double_attesting : bool; for_double_baking : bool}
 
-(** [slashed_level] with all fields being [false]. *)
-val default_slashed_level : slashed_level
+(** {!denounced} with all fields set to [false]. *)
+val default_denounced : denounced
 
 (** Set used to avoid slashing multiple times the same event *)
-module Slashed_deposits :
+module Already_denounced :
   Indexed_data_storage
     with type t := Raw_context.t * Cycle_repr.t
      and type key = Raw_level_repr.t * Signature.Public_key_hash.t
-     and type value = slashed_level
+     and type value = denounced
 
 module Pending_staking_parameters :
   Indexed_data_storage
diff --git a/src/proto_alpha/lib_protocol/validate.ml b/src/proto_alpha/lib_protocol/validate.ml
index 96a1fcc2bda5..91ab9d522b7f 100644
--- a/src/proto_alpha/lib_protocol/validate.ml
+++ b/src/proto_alpha/lib_protocol/validate.ml
@@ -1464,7 +1464,7 @@ module Anonymous = struct
         in
         let delegate_pk, delegate = (consensus_key1.consensus_pk, delegate1) in
         let* already_slashed =
-          Delegate.already_slashed_for_double_attesting ctxt delegate level
+          Delegate.already_denounced_for_double_attesting ctxt delegate level
         in
         let*? () =
           error_unless
@@ -1630,7 +1630,7 @@ module Anonymous = struct
     in
     let delegate_pk, delegate = (consensus_key1.consensus_pk, delegate1) in
     let* already_slashed =
-      Delegate.already_slashed_for_double_baking ctxt delegate level
+      Delegate.already_denounced_for_double_baking ctxt delegate level
     in
     let*? () =
       error_unless
-- 
GitLab


From 961023edb9f98d469cb16fb73f2e863ec1fa63c7 Mon Sep 17 00:00:00 2001
From: Diane Gallois-Wong <diane.gallois-wong@nomadic-labs.com>
Date: Tue, 6 Feb 2024 15:31:30 +0100
Subject: [PATCH 2/4] Proto/AI: ensure backward compatibility of
 Storage.Already_denounced

---
 src/proto_alpha/lib_protocol/init_storage.ml | 27 ++++++++++++++++++++
 src/proto_alpha/lib_protocol/storage.ml      | 10 ++++++++
 src/proto_alpha/lib_protocol/storage.mli     |  7 +++++
 3 files changed, 44 insertions(+)

diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml
index aa7c14e0dfe0..5174f56b0806 100644
--- a/src/proto_alpha/lib_protocol/init_storage.ml
+++ b/src/proto_alpha/lib_protocol/init_storage.ml
@@ -109,6 +109,31 @@ let patch_script ctxt (address, hash, patched_code) =
         address ;
       return ctxt
 
+let migrate_already_denounced_from_Oxford ctxt =
+  let open Lwt_syntax in
+  let migrate_cycle ctxt cycle =
+    let* ctxt =
+      Storage.Already_denounced__Oxford.fold
+        (ctxt, cycle)
+        ~order:`Undefined
+        ~init:ctxt
+        ~f:(fun (level, delegate) denounced ctxt ->
+          Storage.Already_denounced.add
+            (ctxt, cycle)
+            (level, delegate)
+            denounced)
+    in
+    Storage.Already_denounced__Oxford.clear (ctxt, cycle)
+  in
+  (* Since the max_slashing_period is 2, denunciations are only
+     relevant if the misbehaviour happened in either the current cycle
+     or the previous cycle. *)
+  let current_cycle = (Level_storage.current ctxt).cycle in
+  let* ctxt = migrate_cycle ctxt current_cycle in
+  match Cycle_repr.pred current_cycle with
+  | None -> return ctxt
+  | Some previous_cycle -> migrate_cycle ctxt previous_cycle
+
 let prepare_first_block chain_id ctxt ~typecheck_smart_contract
     ~typecheck_smart_rollup ~level ~timestamp ~predecessor =
   let open Lwt_result_syntax in
@@ -200,12 +225,14 @@ let prepare_first_block chain_id ctxt ~typecheck_smart_contract
         let* ctxt =
           Sc_rollup_refutation_storage.migrate_clean_refutation_games ctxt
         in
+        (* Adaptive Issuance-related migrations from Oxford to P. *)
         (* We usually clear the table at the end of the cycle but the migration
            can happen in the middle of the cycle, so we clear it here.
            Possible consequence: the slashing history could be inconsistent with
            the pending denunciations, i.e., there could be unstaked_frozen_deposits
            that are not slashed whereas unstake_requests are slashed. *)
         let*! ctxt = Storage.Pending_denunciations.clear ctxt in
+        let*! ctxt = migrate_already_denounced_from_Oxford ctxt in
         return (ctxt, [])
   in
   let* ctxt =
diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml
index 832b1e08d1f7..be288485cd67 100644
--- a/src/proto_alpha/lib_protocol/storage.ml
+++ b/src/proto_alpha/lib_protocol/storage.ml
@@ -1120,6 +1120,15 @@ module Cycle = struct
   module Already_denounced =
     Make_indexed_data_storage
       (Make_subcontext (Registered) (Indexed_context.Raw_context)
+         (struct
+           let name = ["already_denounced"]
+         end))
+         (Pair (Make_index (Raw_level_repr.Index)) (Public_key_hash_index))
+      (Denounced)
+
+  module Already_denounced__Oxford =
+    Make_indexed_data_storage
+      (Make_subcontext (Ghost) (Indexed_context.Raw_context)
          (struct
            let name = ["slashed_deposits"]
          end))
@@ -1267,6 +1276,7 @@ module Cycle = struct
 end
 
 module Already_denounced = Cycle.Already_denounced
+module Already_denounced__Oxford = Cycle.Already_denounced__Oxford
 module Pending_consensus_keys = Cycle.Pending_consensus_keys
 module Pending_staking_parameters = Cycle.Pending_staking_parameters
 
diff --git a/src/proto_alpha/lib_protocol/storage.mli b/src/proto_alpha/lib_protocol/storage.mli
index bbb40a5953af..04078683433d 100644
--- a/src/proto_alpha/lib_protocol/storage.mli
+++ b/src/proto_alpha/lib_protocol/storage.mli
@@ -488,6 +488,13 @@ module Already_denounced :
      and type key = Raw_level_repr.t * Signature.Public_key_hash.t
      and type value = denounced
 
+(** Needed for the stitching from Oxford to P. Remove this in Q. *)
+module Already_denounced__Oxford :
+  Indexed_data_storage
+    with type t := Raw_context.t * Cycle_repr.t
+     and type key = Raw_level_repr.t * Signature.Public_key_hash.t
+     and type value = denounced
+
 module Pending_staking_parameters :
   Indexed_data_storage
     with type t := Raw_context.t * Cycle_repr.t
-- 
GitLab


From 0997c8a3896b9c9e79b7b356c0c8550815987f9f Mon Sep 17 00:00:00 2001
From: Diane Gallois-Wong <diane.gallois-wong@nomadic-labs.com>
Date: Mon, 5 Feb 2024 11:36:44 +0100
Subject: [PATCH 3/4] Proto/AI: allow similar denunciations but with different
 rounds

---
 .../lib_protocol/alpha_context.mli            |  4 +--
 .../delegate_slashed_deposits_storage.ml      | 19 +++++++++-----
 .../delegate_slashed_deposits_storage.mli     |  2 ++
 src/proto_alpha/lib_protocol/init_storage.ml  |  2 +-
 src/proto_alpha/lib_protocol/round_repr.ml    | 26 +++++++++++++++++++
 src/proto_alpha/lib_protocol/round_repr.mli   |  2 ++
 src/proto_alpha/lib_protocol/storage.ml       |  7 ++++-
 src/proto_alpha/lib_protocol/storage.mli      |  3 ++-
 src/proto_alpha/lib_protocol/validate.ml      |  8 ++++--
 9 files changed, 60 insertions(+), 13 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli
index 9ee05cf86d19..f25a8dd2fe90 100644
--- a/src/proto_alpha/lib_protocol/alpha_context.mli
+++ b/src/proto_alpha/lib_protocol/alpha_context.mli
@@ -2234,10 +2234,10 @@ module Delegate : sig
     (context * Receipt.balance_updates * public_key_hash list) tzresult Lwt.t
 
   val already_denounced_for_double_attesting :
-    context -> public_key_hash -> Level.t -> bool tzresult Lwt.t
+    context -> public_key_hash -> Level.t -> Round.t -> bool tzresult Lwt.t
 
   val already_denounced_for_double_baking :
-    context -> public_key_hash -> Level.t -> bool tzresult Lwt.t
+    context -> public_key_hash -> Level.t -> Round.t -> bool tzresult Lwt.t
 
   type reward_and_burn = {reward : Tez.t; amount_to_burn : Tez.t}
 
diff --git a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml
index 788b25949499..fcac690b50b0 100644
--- a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml
+++ b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.ml
@@ -26,19 +26,24 @@
 (*****************************************************************************)
 
 let already_denounced_for_double_attesting ctxt delegate (level : Level_repr.t)
-    =
+    round =
   let open Lwt_result_syntax in
   let* denounced_opt =
-    Storage.Already_denounced.find (ctxt, level.cycle) (level.level, delegate)
+    Storage.Already_denounced.find
+      (ctxt, level.cycle)
+      ((level.level, round), delegate)
   in
   match denounced_opt with
   | None -> return_false
   | Some denounced -> return denounced.for_double_attesting
 
-let already_denounced_for_double_baking ctxt delegate (level : Level_repr.t) =
+let already_denounced_for_double_baking ctxt delegate (level : Level_repr.t)
+    round =
   let open Lwt_result_syntax in
   let* denounced_opt =
-    Storage.Already_denounced.find (ctxt, level.cycle) (level.level, delegate)
+    Storage.Already_denounced.find
+      (ctxt, level.cycle)
+      ((level.level, round), delegate)
   in
   match denounced_opt with
   | None -> return_false
@@ -56,7 +61,9 @@ let punish_double_signing ctxt ~operation_hash
     ~rewarded =
   let open Lwt_result_syntax in
   let* denounced_opt =
-    Storage.Already_denounced.find (ctxt, level.cycle) (level.level, delegate)
+    Storage.Already_denounced.find
+      (ctxt, level.cycle)
+      ((level.level, misbehaviour.round), delegate)
   in
   let denounced =
     Option.value denounced_opt ~default:Storage.default_denounced
@@ -83,7 +90,7 @@ let punish_double_signing ctxt ~operation_hash
   let*! ctxt =
     Storage.Already_denounced.add
       (ctxt, level.cycle)
-      (level.level, delegate)
+      ((level.level, misbehaviour.round), delegate)
       updated_denounced
   in
   let* slash_history_opt =
diff --git a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli
index 7c9f22c5af0e..9d45a438aaa7 100644
--- a/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli
+++ b/src/proto_alpha/lib_protocol/delegate_slashed_deposits_storage.mli
@@ -37,6 +37,7 @@ val already_denounced_for_double_baking :
   Raw_context.t ->
   Signature.Public_key_hash.t ->
   Level_repr.t ->
+  Round_repr.t ->
   bool tzresult Lwt.t
 
 (** Returns true if the given delegate has already been denounced
@@ -45,6 +46,7 @@ val already_denounced_for_double_attesting :
   Raw_context.t ->
   Signature.Public_key_hash.t ->
   Level_repr.t ->
+  Round_repr.t ->
   bool tzresult Lwt.t
 
 (** The [reward_and_burn] type embeds amounts involved when slashing a
diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml
index 5174f56b0806..a63583e0c230 100644
--- a/src/proto_alpha/lib_protocol/init_storage.ml
+++ b/src/proto_alpha/lib_protocol/init_storage.ml
@@ -120,7 +120,7 @@ let migrate_already_denounced_from_Oxford ctxt =
         ~f:(fun (level, delegate) denounced ctxt ->
           Storage.Already_denounced.add
             (ctxt, cycle)
-            (level, delegate)
+            ((level, Round_repr.zero), delegate)
             denounced)
     in
     Storage.Already_denounced__Oxford.clear (ctxt, cycle)
diff --git a/src/proto_alpha/lib_protocol/round_repr.ml b/src/proto_alpha/lib_protocol/round_repr.ml
index bc31691ef0ba..124c8e535654 100644
--- a/src/proto_alpha/lib_protocol/round_repr.ml
+++ b/src/proto_alpha/lib_protocol/round_repr.ml
@@ -495,6 +495,32 @@ let level_offset_of_round round_durations ~round =
   let* offset = raw_level_offset_of_round round_durations ~round in
   return (Period_repr.of_seconds_exn offset)
 
+module Index = struct
+  type t = round
+
+  let path_length = 1
+
+  let to_path round l = Int32.to_string round :: l
+
+  let of_path = function [s] -> Int32.of_string_opt s | _ -> None
+
+  let rpc_arg =
+    let construct round = Int32.to_string round in
+    let destruct str =
+      Int32.of_string_opt str |> Option.to_result ~none:"Cannot parse round"
+    in
+    RPC_arg.make
+      ~descr:"A round integer"
+      ~name:"block_round"
+      ~construct
+      ~destruct
+      ()
+
+  let encoding = encoding
+
+  let compare = compare
+end
+
 module Internals_for_test = struct
   type round_and_offset_raw = {round : round; offset : Period_repr.t}
 
diff --git a/src/proto_alpha/lib_protocol/round_repr.mli b/src/proto_alpha/lib_protocol/round_repr.mli
index 31ea658617fd..9fc6e54ac2c1 100644
--- a/src/proto_alpha/lib_protocol/round_repr.mli
+++ b/src/proto_alpha/lib_protocol/round_repr.mli
@@ -221,6 +221,8 @@ val round_of_timestamp :
   timestamp:Time_repr.t ->
   t tzresult
 
+module Index : Storage_description.INDEX with type t = round
+
 module Internals_for_test : sig
   type round_and_offset_raw = {round : round; offset : Period_repr.t}
 
diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml
index be288485cd67..301ea5b28444 100644
--- a/src/proto_alpha/lib_protocol/storage.ml
+++ b/src/proto_alpha/lib_protocol/storage.ml
@@ -1123,7 +1123,12 @@ module Cycle = struct
          (struct
            let name = ["already_denounced"]
          end))
-         (Pair (Make_index (Raw_level_repr.Index)) (Public_key_hash_index))
+         (Pair
+            (Pair
+               (Make_index
+                  (Raw_level_repr.Index))
+                  (Make_index (Round_repr.Index)))
+               (Public_key_hash_index))
       (Denounced)
 
   module Already_denounced__Oxford =
diff --git a/src/proto_alpha/lib_protocol/storage.mli b/src/proto_alpha/lib_protocol/storage.mli
index 04078683433d..624308c5e63b 100644
--- a/src/proto_alpha/lib_protocol/storage.mli
+++ b/src/proto_alpha/lib_protocol/storage.mli
@@ -485,7 +485,8 @@ val default_denounced : denounced
 module Already_denounced :
   Indexed_data_storage
     with type t := Raw_context.t * Cycle_repr.t
-     and type key = Raw_level_repr.t * Signature.Public_key_hash.t
+     and type key =
+      (Raw_level_repr.t * Round_repr.t) * Signature.Public_key_hash.t
      and type value = denounced
 
 (** Needed for the stitching from Oxford to P. Remove this in Q. *)
diff --git a/src/proto_alpha/lib_protocol/validate.ml b/src/proto_alpha/lib_protocol/validate.ml
index 91ab9d522b7f..d0231f2afc09 100644
--- a/src/proto_alpha/lib_protocol/validate.ml
+++ b/src/proto_alpha/lib_protocol/validate.ml
@@ -1464,7 +1464,11 @@ module Anonymous = struct
         in
         let delegate_pk, delegate = (consensus_key1.consensus_pk, delegate1) in
         let* already_slashed =
-          Delegate.already_denounced_for_double_attesting ctxt delegate level
+          Delegate.already_denounced_for_double_attesting
+            ctxt
+            delegate
+            level
+            e1.round
         in
         let*? () =
           error_unless
@@ -1630,7 +1634,7 @@ module Anonymous = struct
     in
     let delegate_pk, delegate = (consensus_key1.consensus_pk, delegate1) in
     let* already_slashed =
-      Delegate.already_denounced_for_double_baking ctxt delegate level
+      Delegate.already_denounced_for_double_baking ctxt delegate level round1
     in
     let*? () =
       error_unless
-- 
GitLab


From 4de2b30f7449cc712f518aa2f29794f84aca0f65 Mon Sep 17 00:00:00 2001
From: Diane Gallois-Wong <diane.gallois-wong@nomadic-labs.com>
Date: Tue, 6 Feb 2024 16:49:54 +0100
Subject: [PATCH 4/4] Changelog: slashing per round

---
 docs/protocols/alpha.rst | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/docs/protocols/alpha.rst b/docs/protocols/alpha.rst
index 7542826e5168..dbaba70fbae2 100644
--- a/docs/protocols/alpha.rst
+++ b/docs/protocols/alpha.rst
@@ -151,5 +151,9 @@ Minor Changes
   consistent by adding errors in some cases (BLS12-381 values, Sapling
   transactions, and timelocks). (MR :gl:`!10227`)
 
+- A delegate may now be slashed once per double baking event and once
+  per double (pre)attesting event at every level and round
+  (previously, only at every level, no matter the round). (MR :gl:`!11826`)
+
 Internal
 --------
-- 
GitLab