From 20389532ef5314973945910159204d1029c11481 Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Fri, 22 Apr 2022 10:43:46 +0200
Subject: [PATCH 01/12] Proto: separate encoding tags for internal operations.

And remove the unused values from interfaces.
---
 src/proto_alpha/lib_protocol/alpha_context.mli  |  6 ------
 src/proto_alpha/lib_protocol/apply_results.ml   | 13 ++++++++++---
 src/proto_alpha/lib_protocol/operation_repr.ml  | 13 ++++---------
 src/proto_alpha/lib_protocol/operation_repr.mli |  7 +------
 4 files changed, 15 insertions(+), 24 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli
index 07627ae7e429..3e4a57cb14e7 100644
--- a/src/proto_alpha/lib_protocol/alpha_context.mli
+++ b/src/proto_alpha/lib_protocol/alpha_context.mli
@@ -3328,16 +3328,10 @@ module Operation : sig
 
       val reveal_case : Kind.reveal case
 
-      val transaction_tag : int
-
       val transaction_case : Kind.transaction case
 
-      val origination_tag : int
-
       val origination_case : Kind.origination case
 
-      val delegation_tag : int
-
       val delegation_case : Kind.delegation case
 
       val register_global_constant_case : Kind.register_global_constant case
diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index 3743c02991f4..2cdcba9c7bd3 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -2,6 +2,7 @@
 (*                                                                           *)
 (* Open Source License                                                       *)
 (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
+(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com>                *)
 (*                                                                           *)
 (* Permission is hereby granted, free of charge, to any person obtaining a   *)
 (* copy of this software and associated documentation files (the "Software"),*)
@@ -1037,7 +1038,9 @@ module Internal_result = struct
   let[@coq_axiom_with_reason "gadt"] transaction_case =
     MCase
       {
-        tag = Operation.Encoding.Manager_operations.transaction_tag;
+        (* This value should be changed with care: maybe receipts are read by
+           external tools such as indexers. *)
+        tag = 1;
         name = "transaction";
         encoding =
           obj3
@@ -1080,7 +1083,9 @@ module Internal_result = struct
   let[@coq_axiom_with_reason "gadt"] origination_case =
     MCase
       {
-        tag = Operation.Encoding.Manager_operations.origination_tag;
+        (* This value should be changed with care: maybe receipts are read by
+           external tools such as indexers. *)
+        tag = 2;
         name = "origination";
         encoding =
           obj3
@@ -1106,7 +1111,9 @@ module Internal_result = struct
   let[@coq_axiom_with_reason "gadt"] delegation_case =
     MCase
       {
-        tag = Operation.Encoding.Manager_operations.delegation_tag;
+        (* This value should be changed with care: maybe receipts are read by
+           external tools such as indexers. *)
+        tag = 3;
         name = "delegation";
         encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding);
         iselect : Kind.delegation iselect =
diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml
index 405c5d8b9e97..ea3cde9b4c1f 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.ml
+++ b/src/proto_alpha/lib_protocol/operation_repr.ml
@@ -2,6 +2,7 @@
 (*                                                                           *)
 (* Open Source License                                                       *)
 (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
+(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com>                *)
 (*                                                                           *)
 (* Permission is hereby granted, free of charge, to any person obtaining a   *)
 (* copy of this software and associated documentation files (the "Software"),*)
@@ -540,12 +541,10 @@ module Encoding = struct
           inj = (fun pkh -> Reveal pkh);
         }
 
-    let transaction_tag = 1
-
     let[@coq_axiom_with_reason "gadt"] transaction_case =
       MCase
         {
-          tag = transaction_tag;
+          tag = 1;
           name = "transaction";
           encoding =
             obj3
@@ -579,12 +578,10 @@ module Encoding = struct
               Transaction {amount; destination; parameters; entrypoint});
         }
 
-    let origination_tag = 2
-
     let[@coq_axiom_with_reason "gadt"] origination_case =
       MCase
         {
-          tag = origination_tag;
+          tag = 2;
           name = "origination";
           encoding =
             obj3
@@ -602,12 +599,10 @@ module Encoding = struct
               Origination {credit; delegate; script});
         }
 
-    let delegation_tag = 3
-
     let[@coq_axiom_with_reason "gadt"] delegation_case =
       MCase
         {
-          tag = delegation_tag;
+          tag = 3;
           name = "delegation";
           encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding);
           select =
diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli
index e170f93e3cc1..ac7dd3202b2d 100644
--- a/src/proto_alpha/lib_protocol/operation_repr.mli
+++ b/src/proto_alpha/lib_protocol/operation_repr.mli
@@ -2,6 +2,7 @@
 (*                                                                           *)
 (* Open Source License                                                       *)
 (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
+(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com>                *)
 (*                                                                           *)
 (* Permission is hereby granted, free of charge, to any person obtaining a   *)
 (* copy of this software and associated documentation files (the "Software"),*)
@@ -618,16 +619,10 @@ module Encoding : sig
 
     val reveal_case : Kind.reveal case
 
-    val transaction_tag : int
-
     val transaction_case : Kind.transaction case
 
-    val origination_tag : int
-
     val origination_case : Kind.origination case
 
-    val delegation_tag : int
-
     val delegation_case : Kind.delegation case
 
     val register_global_constant_case : Kind.register_global_constant case
-- 
GitLab


From f2ca02a369399d7084eb08480a777c3a9c735de8 Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Wed, 18 May 2022 18:05:49 +0200
Subject: [PATCH 02/12] Proto/Client: extract successful origination result
 fields.

To share them between internal and external origination results.
---
 .../lib_client/operation_result.ml            | 26 +++++++++----------
 src/proto_alpha/lib_protocol/apply_results.ml | 19 ++++++++------
 .../lib_protocol/apply_results.mli            | 23 +++++++++-------
 3 files changed, 38 insertions(+), 30 deletions(-)

diff --git a/src/proto_alpha/lib_client/operation_result.ml b/src/proto_alpha/lib_client/operation_result.ml
index 0af57d8b6f85..e1bddab339d5 100644
--- a/src/proto_alpha/lib_client/operation_result.ml
+++ b/src/proto_alpha/lib_client/operation_result.ml
@@ -2,6 +2,7 @@
 (*                                                                           *)
 (* Open Source License                                                       *)
 (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
+(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com>                *)
 (*                                                                           *)
 (* Permission is hereby granted, free of charge, to any person obtaining a   *)
 (* copy of this software and associated documentation files (the "Software"),*)
@@ -511,15 +512,14 @@ let pp_manager_operation_contents_and_result ppf
   in
 
   let pp_origination_result
-      (Origination_result
-        {
-          lazy_storage_diff;
-          balance_updates;
-          consumed_gas;
-          originated_contracts;
-          storage_size;
-          paid_storage_size_diff;
-        }) =
+      {
+        lazy_storage_diff;
+        balance_updates;
+        consumed_gas;
+        originated_contracts;
+        storage_size;
+        paid_storage_size_diff;
+      } =
     (match originated_contracts with
     | [] -> ()
     | contracts ->
@@ -744,15 +744,15 @@ let pp_manager_operation_contents_and_result ppf
           "@[<v 0>This transaction was BACKTRACKED, its expected effects (as \
            follow) were NOT applied.@]" ;
         pp_transaction_result tx
-    | Applied (Origination_result _ as op) ->
+    | Applied (Origination_result op_res) ->
         Format.fprintf ppf "This origination was successfully applied" ;
-        pp_origination_result op
-    | Backtracked ((Origination_result _ as op), _errs) ->
+        pp_origination_result op_res
+    | Backtracked (Origination_result op_res, _errs) ->
         Format.fprintf
           ppf
           "@[<v 0>This origination was BACKTRACKED, its expected effects (as \
            follow) were NOT applied.@]" ;
-        pp_origination_result op
+        pp_origination_result op_res
     | Applied (Register_global_constant_result _ as op) ->
         Format.fprintf
           ppf
diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index 2cdcba9c7bd3..a9b8c7c3184a 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -127,6 +127,15 @@ type successful_transaction_result =
       paid_storage_size_diff : Z.t;
     }
 
+type successful_origination_result = {
+  lazy_storage_diff : Lazy_storage.diffs option;
+  balance_updates : Receipt.balance_updates;
+  originated_contracts : Contract_hash.t list;
+  consumed_gas : Gas.Arith.fp;
+  storage_size : Z.t;
+  paid_storage_size_diff : Z.t;
+}
+
 type _ successful_manager_operation_result =
   | Reveal_result : {
       consumed_gas : Gas.Arith.fp;
@@ -135,14 +144,8 @@ type _ successful_manager_operation_result =
   | Transaction_result :
       successful_transaction_result
       -> Kind.transaction successful_manager_operation_result
-  | Origination_result : {
-      lazy_storage_diff : Lazy_storage.diffs option;
-      balance_updates : Receipt.balance_updates;
-      originated_contracts : Contract_hash.t list;
-      consumed_gas : Gas.Arith.fp;
-      storage_size : Z.t;
-      paid_storage_size_diff : Z.t;
-    }
+  | Origination_result :
+      successful_origination_result
       -> Kind.origination successful_manager_operation_result
   | Delegation_result : {
       consumed_gas : Gas.Arith.fp;
diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli
index 980e8cda1f62..941b22741d51 100644
--- a/src/proto_alpha/lib_protocol/apply_results.mli
+++ b/src/proto_alpha/lib_protocol/apply_results.mli
@@ -2,6 +2,7 @@
 (*                                                                           *)
 (* Open Source License                                                       *)
 (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
+(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com>                *)
 (*                                                                           *)
 (* Permission is hereby granted, free of charge, to any person obtaining a   *)
 (* copy of this software and associated documentation files (the "Software"),*)
@@ -135,7 +136,7 @@ and 'kind manager_operation_result =
   | Skipped : 'kind Kind.manager -> 'kind manager_operation_result
 [@@coq_force_gadt]
 
-(** Result of applying a transaction, either internal or external *)
+(** Result of applying a transaction, either internal or external. *)
 and successful_transaction_result =
   | Transaction_to_contract_result of {
       storage : Script.expr option;
@@ -154,6 +155,16 @@ and successful_transaction_result =
       paid_storage_size_diff : Z.t;
     }
 
+(** Result of applying an origination, either internal or external. *)
+and successful_origination_result = {
+  lazy_storage_diff : Lazy_storage.diffs option;
+  balance_updates : Receipt.balance_updates;
+  originated_contracts : Contract_hash.t list;
+  consumed_gas : Gas.Arith.fp;
+  storage_size : Z.t;
+  paid_storage_size_diff : Z.t;
+}
+
 (** Result of applying a {!manager_operation_content}, either internal
     or external. *)
 and _ successful_manager_operation_result =
@@ -164,14 +175,8 @@ and _ successful_manager_operation_result =
   | Transaction_result :
       successful_transaction_result
       -> Kind.transaction successful_manager_operation_result
-  | Origination_result : {
-      lazy_storage_diff : Lazy_storage.diffs option;
-      balance_updates : Receipt.balance_updates;
-      originated_contracts : Contract_hash.t list;
-      consumed_gas : Gas.Arith.fp;
-      storage_size : Z.t;
-      paid_storage_size_diff : Z.t;
-    }
+  | Origination_result :
+      successful_origination_result
       -> Kind.origination successful_manager_operation_result
   | Delegation_result : {
       consumed_gas : Gas.Arith.fp;
-- 
GitLab


From 6c4ff5fbf9537fd25374c938ddc74af6cc770a87 Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Wed, 18 May 2022 23:20:38 +0200
Subject: [PATCH 03/12] Proto: differentiate the apply_transaction functions
 with internal and external versions.

Because they will return different types later.
---
 src/proto_alpha/lib_protocol/apply.ml | 117 +++++++++++++++++++-------
 1 file changed, 85 insertions(+), 32 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index b818245830e0..1cfd0729ff45 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -835,21 +835,44 @@ let apply_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~parameter
         else error (Script_interpreter.Bad_contract_parameter contract) )
     >|? fun ctxt ->
       let result =
-        Transaction_result
-          (Transaction_to_contract_result
-             {
-               storage = None;
-               lazy_storage_diff = None;
-               balance_updates;
-               originated_contracts = [];
-               consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
-               storage_size = Z.zero;
-               paid_storage_size_diff = Z.zero;
-               allocated_destination_contract = not already_allocated;
-             })
+        Transaction_to_contract_result
+          {
+            storage = None;
+            lazy_storage_diff = None;
+            balance_updates;
+            originated_contracts = [];
+            consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
+            storage_size = Z.zero;
+            paid_storage_size_diff = Z.zero;
+            allocated_destination_contract = not already_allocated;
+          }
       in
       (ctxt, result, []) )
 
+let apply_internal_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~parameter
+    ~entrypoint ~before_operation =
+  apply_transaction_to_implicit
+    ~ctxt
+    ~source
+    ~amount
+    ~pkh
+    ~parameter
+    ~entrypoint
+    ~before_operation
+  >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops)
+
+let apply_manager_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~parameter
+    ~entrypoint ~before_operation =
+  apply_transaction_to_implicit
+    ~ctxt
+    ~source
+    ~amount
+    ~pkh
+    ~parameter
+    ~entrypoint
+    ~before_operation
+  >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops)
+
 let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount
     ~entrypoint ~before_operation ~payer ~chain_id ~mode ~internal ~parameter =
   let contract = Contract.Originated contract_hash in
@@ -938,25 +961,55 @@ let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount
             updated_size
         >|? fun ctxt ->
           let result =
-            Transaction_result
-              (Transaction_to_contract_result
-                 {
-                   storage = Some storage;
-                   lazy_storage_diff;
-                   balance_updates;
-                   originated_contracts;
-                   consumed_gas =
-                     Gas.consumed ~since:before_operation ~until:ctxt;
-                   storage_size = new_size;
-                   paid_storage_size_diff =
-                     Z.add
-                       contract_paid_storage_size_diff
-                       ticket_paid_storage_diff;
-                   allocated_destination_contract = false;
-                 })
+            Transaction_to_contract_result
+              {
+                storage = Some storage;
+                lazy_storage_diff;
+                balance_updates;
+                originated_contracts;
+                consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
+                storage_size = new_size;
+                paid_storage_size_diff =
+                  Z.add contract_paid_storage_size_diff ticket_paid_storage_diff;
+                allocated_destination_contract = false;
+              }
           in
           (ctxt, result, operations) )
 
+let apply_internal_transaction_to_smart_contract ~ctxt ~source ~contract_hash
+    ~amount ~entrypoint ~before_operation ~payer ~chain_id ~mode ~internal
+    ~parameter =
+  apply_transaction_to_smart_contract
+    ~ctxt
+    ~source
+    ~contract_hash
+    ~amount
+    ~entrypoint
+    ~before_operation
+    ~payer
+    ~chain_id
+    ~mode
+    ~internal
+    ~parameter
+  >>=? fun (ctxt, res, ops) -> return (ctxt, Transaction_result res, ops)
+
+let apply_manager_transaction_to_smart_contract ~ctxt ~source ~contract_hash
+    ~amount ~entrypoint ~before_operation ~payer ~chain_id ~mode ~internal
+    ~parameter =
+  apply_transaction_to_smart_contract
+    ~ctxt
+    ~source
+    ~contract_hash
+    ~amount
+    ~entrypoint
+    ~before_operation
+    ~payer
+    ~chain_id
+    ~mode
+    ~internal
+    ~parameter
+  >>=? fun (ctxt, res, ops) -> return (ctxt, Transaction_result res, ops)
+
 let ex_ticket_size :
     context -> Ticket_scanner.ex_ticket -> (context * int) tzresult Lwt.t =
  fun ctxt (Ex_ticket (ty, ticket)) ->
@@ -1150,7 +1203,7 @@ let apply_internal_manager_operation_content :
         parameters_ty;
         parameters = typed_parameters;
       } ->
-      (apply_transaction_to_implicit
+      (apply_internal_transaction_to_implicit
          ~ctxt
          ~parameter:(Typed_arg (location, parameters_ty, typed_parameters))
          ~source
@@ -1169,7 +1222,7 @@ let apply_internal_manager_operation_content :
         parameters = typed_parameters;
         unparsed_parameters = _;
       } ->
-      apply_transaction_to_smart_contract
+      apply_internal_transaction_to_smart_contract
         ~ctxt
         ~source
         ~contract_hash
@@ -1250,7 +1303,7 @@ let apply_external_manager_operation_content :
         ctxt
         parameters
       >>?= fun (parameters, ctxt) ->
-      apply_transaction_to_implicit
+      apply_manager_transaction_to_implicit
         ~ctxt
         ~source:source_contract
         ~amount
@@ -1266,7 +1319,7 @@ let apply_external_manager_operation_content :
         ctxt
         parameters
       >>?= fun (parameters, ctxt) ->
-      apply_transaction_to_smart_contract
+      apply_manager_transaction_to_smart_contract
         ~ctxt
         ~source:source_contract
         ~contract_hash
-- 
GitLab


From c82103e8737ee0b220bc54bf7e7d92ada443ce4a Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Wed, 18 May 2022 23:25:14 +0200
Subject: [PATCH 04/12] Proto: differentiate apply_origination with internal
 and external versions.

Because they will return different types later.
---
 src/proto_alpha/lib_protocol/apply.ml | 51 +++++++++++++++++++++------
 1 file changed, 40 insertions(+), 11 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index 1cfd0729ff45..6fc00b7ab6a7 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -1131,18 +1131,47 @@ let apply_origination ~ctxt ~storage_type ~storage ~unparsed_code
   Fees.record_paid_storage_space ctxt contract
   >|=? fun (ctxt, size, paid_storage_size_diff) ->
   let result =
-    Origination_result
-      {
-        lazy_storage_diff;
-        balance_updates;
-        originated_contracts = [contract_hash];
-        consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
-        storage_size = size;
-        paid_storage_size_diff;
-      }
+    {
+      lazy_storage_diff;
+      balance_updates;
+      originated_contracts = [contract_hash];
+      consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
+      storage_size = size;
+      paid_storage_size_diff;
+    }
   in
   (ctxt, result, [])
 
+let apply_internal_origination ~ctxt ~storage_type ~storage ~unparsed_code
+    ~contract ~delegate ~source ~credit ~before_operation =
+  apply_origination
+    ~ctxt
+    ~storage_type
+    ~storage
+    ~unparsed_code
+    ~contract
+    ~delegate
+    ~source
+    ~credit
+    ~before_operation
+  >|=? fun (ctxt, origination_result, ops) ->
+  (ctxt, Origination_result origination_result, ops)
+
+let apply_manager_origination ~ctxt ~storage_type ~storage ~unparsed_code
+    ~contract ~delegate ~source ~credit ~before_operation =
+  apply_origination
+    ~ctxt
+    ~storage_type
+    ~storage
+    ~unparsed_code
+    ~contract
+    ~delegate
+    ~source
+    ~credit
+    ~before_operation
+  >|=? fun (ctxt, origination_result, ops) ->
+  (ctxt, Origination_result origination_result, ops)
+
 (**
 
    Retrieving the source code of a contract from its address is costly
@@ -1255,7 +1284,7 @@ let apply_internal_manager_operation_content :
         ctxt
         script.Script.code
       >>?= fun (unparsed_code, ctxt) ->
-      apply_origination
+      apply_internal_origination
         ~ctxt
         ~storage_type
         ~storage
@@ -1489,7 +1518,7 @@ let apply_external_manager_operation_content :
         (Script_tc_errors.Ill_typed_contract (unparsed_code, []))
         views_result
       >>=? fun (_typed_views, ctxt) ->
-      apply_origination
+      apply_manager_origination
         ~ctxt
         ~storage_type
         ~storage
-- 
GitLab


From ac68c4ca88d2e779d84fdfaedf10a2dc5ad246be Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Wed, 18 May 2022 23:27:43 +0200
Subject: [PATCH 05/12] Proto: differentiate apply_delegation with internal and
 external versions.

Because they will return different types later.
---
 src/proto_alpha/lib_protocol/apply.ml | 23 +++++++++++++++++------
 1 file changed, 17 insertions(+), 6 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index 6fc00b7ab6a7..051981faa4e7 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -795,10 +795,17 @@ let update_script_storage_and_ticket_balances ctxt ~self storage
 
 let apply_delegation ~ctxt ~source ~delegate ~before_operation =
   Delegate.set ctxt source delegate >|=? fun ctxt ->
-  ( ctxt,
-    Delegation_result
-      {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt},
-    [] )
+  (ctxt, Gas.consumed ~since:before_operation ~until:ctxt, [])
+
+let apply_internal_delegation ~ctxt ~source ~delegate ~before_operation =
+  apply_delegation ~ctxt ~source ~delegate ~before_operation
+  >|=? fun (ctxt, consumed_gas, ops) ->
+  (ctxt, Delegation_result {consumed_gas}, ops)
+
+let apply_manager_delegation ~ctxt ~source ~delegate ~before_operation =
+  apply_delegation ~ctxt ~source ~delegate ~before_operation
+  >|=? fun (ctxt, consumed_gas, ops) ->
+  (ctxt, Delegation_result {consumed_gas}, ops)
 
 type execution_arg =
   | Typed_arg :
@@ -1295,7 +1302,7 @@ let apply_internal_manager_operation_content :
         ~credit
         ~before_operation
   | Delegation delegate ->
-      apply_delegation ~ctxt ~source ~delegate ~before_operation
+      apply_internal_delegation ~ctxt ~source ~delegate ~before_operation
 
 let apply_external_manager_operation_content :
     type kind.
@@ -1529,7 +1536,11 @@ let apply_external_manager_operation_content :
         ~credit
         ~before_operation
   | Delegation delegate ->
-      apply_delegation ~ctxt ~source:source_contract ~delegate ~before_operation
+      apply_manager_delegation
+        ~ctxt
+        ~source:source_contract
+        ~delegate
+        ~before_operation
   | Register_global_constant {value} ->
       (* Decode the value and consume gas appropriately *)
       Script.force_decode_in_context ~consume_deserialization_gas ctxt value
-- 
GitLab


From 2252beb2ff8800394a4d8de683b61215ead0f0d5 Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Thu, 19 May 2022 13:55:14 +0200
Subject: [PATCH 06/12] Proto: extract burn_storage_fees for transactions.

To share it between internal and external burn later.
---
 src/proto_alpha/lib_protocol/apply.ml | 73 +++++++++++++++------------
 1 file changed, 41 insertions(+), 32 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index 051981faa4e7..bdedebfa1df7 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -2088,22 +2088,9 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents)
   let consumed_gas = Gas.consumed ~since:ctxt_before ~until:ctxt in
   (ctxt, {balance_updates; consumed_gas})
 
-(** [burn_storage_fees ctxt smopr storage_limit payer] burns the storage fees
-    associated to an operation result [smopr].
-    Returns an updated context, an updated storage limit with the space consumed
-    by the operation subtracted, and [smopr] with the relevant balance updates
-    included. *)
-let burn_storage_fees :
-    type kind.
-    context ->
-    kind successful_manager_operation_result ->
-    storage_limit:Z.t ->
-    payer:public_key_hash ->
-    (context * Z.t * kind successful_manager_operation_result) tzresult Lwt.t =
- fun ctxt smopr ~storage_limit ~payer ->
-  let payer = `Contract (Contract.Implicit payer) in
-  match smopr with
-  | Transaction_result (Transaction_to_contract_result payload) ->
+let burn_transaction_storage_fees ctxt trr ~storage_limit ~payer =
+  match trr with
+  | Transaction_to_contract_result payload ->
       let consumed = payload.paid_storage_size_diff in
       Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
       >>=? fun (ctxt, storage_limit, storage_bus) ->
@@ -2117,20 +2104,19 @@ let burn_storage_fees :
       return
         ( ctxt,
           storage_limit,
-          Transaction_result
-            (Transaction_to_contract_result
-               {
-                 storage = payload.storage;
-                 lazy_storage_diff = payload.lazy_storage_diff;
-                 balance_updates;
-                 originated_contracts = payload.originated_contracts;
-                 consumed_gas = payload.consumed_gas;
-                 storage_size = payload.storage_size;
-                 paid_storage_size_diff = payload.paid_storage_size_diff;
-                 allocated_destination_contract =
-                   payload.allocated_destination_contract;
-               }) )
-  | Transaction_result (Transaction_to_tx_rollup_result payload) ->
+          Transaction_to_contract_result
+            {
+              storage = payload.storage;
+              lazy_storage_diff = payload.lazy_storage_diff;
+              balance_updates;
+              originated_contracts = payload.originated_contracts;
+              consumed_gas = payload.consumed_gas;
+              storage_size = payload.storage_size;
+              paid_storage_size_diff = payload.paid_storage_size_diff;
+              allocated_destination_contract =
+                payload.allocated_destination_contract;
+            } )
+  | Transaction_to_tx_rollup_result payload ->
       let consumed = payload.paid_storage_size_diff in
       Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
       >>=? fun (ctxt, storage_limit, storage_bus) ->
@@ -2138,8 +2124,31 @@ let burn_storage_fees :
       return
         ( ctxt,
           storage_limit,
-          Transaction_result
-            (Transaction_to_tx_rollup_result {payload with balance_updates}) )
+          Transaction_to_tx_rollup_result {payload with balance_updates} )
+
+(** [burn_storage_fees ctxt smopr storage_limit payer] burns the storage fees
+    associated to an operation result [smopr].
+    Returns an updated context, an updated storage limit with the space consumed
+    by the operation subtracted, and [smopr] with the relevant balance updates
+    included. *)
+let burn_storage_fees :
+    type kind.
+    context ->
+    kind successful_manager_operation_result ->
+    storage_limit:Z.t ->
+    payer:public_key_hash ->
+    (context * Z.t * kind successful_manager_operation_result) tzresult Lwt.t =
+ fun ctxt smopr ~storage_limit ~payer ->
+  let payer = `Contract (Contract.Implicit payer) in
+  match smopr with
+  | Transaction_result transaction_result ->
+      burn_transaction_storage_fees
+        ctxt
+        transaction_result
+        ~storage_limit
+        ~payer
+      >|=? fun (ctxt, storage_limit, transaction_result) ->
+      (ctxt, storage_limit, Transaction_result transaction_result)
   | Origination_result payload ->
       let consumed = payload.paid_storage_size_diff in
       Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
-- 
GitLab


From b7e519c670c90ab2fadec636b8bc83cf6f2d28fa Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Thu, 19 May 2022 14:03:03 +0200
Subject: [PATCH 07/12] Proto: extract burn_storage_fees for originations.

To share it between internal and external burn later.
---
 src/proto_alpha/lib_protocol/apply.ml | 56 +++++++++++++++++----------
 1 file changed, 35 insertions(+), 21 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index bdedebfa1df7..caf03a908789 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -2126,6 +2126,33 @@ let burn_transaction_storage_fees ctxt trr ~storage_limit ~payer =
           storage_limit,
           Transaction_to_tx_rollup_result {payload with balance_updates} )
 
+let burn_origination_storage_fees ctxt
+    {
+      lazy_storage_diff;
+      balance_updates;
+      originated_contracts;
+      consumed_gas;
+      storage_size;
+      paid_storage_size_diff;
+    } ~storage_limit ~payer =
+  let consumed = paid_storage_size_diff in
+  Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
+  >>=? fun (ctxt, storage_limit, storage_bus) ->
+  Fees.burn_origination_fees ctxt ~storage_limit ~payer
+  >>=? fun (ctxt, storage_limit, origination_bus) ->
+  let balance_updates = storage_bus @ origination_bus @ balance_updates in
+  return
+    ( ctxt,
+      storage_limit,
+      {
+        lazy_storage_diff;
+        balance_updates;
+        originated_contracts;
+        consumed_gas;
+        storage_size;
+        paid_storage_size_diff;
+      } )
+
 (** [burn_storage_fees ctxt smopr storage_limit payer] burns the storage fees
     associated to an operation result [smopr].
     Returns an updated context, an updated storage limit with the space consumed
@@ -2149,27 +2176,14 @@ let burn_storage_fees :
         ~payer
       >|=? fun (ctxt, storage_limit, transaction_result) ->
       (ctxt, storage_limit, Transaction_result transaction_result)
-  | Origination_result payload ->
-      let consumed = payload.paid_storage_size_diff in
-      Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
-      >>=? fun (ctxt, storage_limit, storage_bus) ->
-      Fees.burn_origination_fees ctxt ~storage_limit ~payer
-      >>=? fun (ctxt, storage_limit, origination_bus) ->
-      let balance_updates =
-        storage_bus @ origination_bus @ payload.balance_updates
-      in
-      return
-        ( ctxt,
-          storage_limit,
-          Origination_result
-            {
-              lazy_storage_diff = payload.lazy_storage_diff;
-              balance_updates;
-              originated_contracts = payload.originated_contracts;
-              consumed_gas = payload.consumed_gas;
-              storage_size = payload.storage_size;
-              paid_storage_size_diff = payload.paid_storage_size_diff;
-            } )
+  | Origination_result origination_result ->
+      burn_origination_storage_fees
+        ctxt
+        origination_result
+        ~storage_limit
+        ~payer
+      >|=? fun (ctxt, storage_limit, origination_result) ->
+      (ctxt, storage_limit, Origination_result origination_result)
   | Reveal_result _ | Delegation_result _ -> return (ctxt, storage_limit, smopr)
   | Register_global_constant_result payload ->
       let consumed = payload.size_of_constant in
-- 
GitLab


From 0cac4d5e6c9b13ae8da7e4bfd9cee588b2ca5ae9 Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Thu, 19 May 2022 14:24:20 +0200
Subject: [PATCH 08/12] Proto: separate burn_storage_fees with internal and
 external versions.

The internal version will be specialized to handle internal operations only later.
---
 src/proto_alpha/lib_protocol/apply.ml | 120 ++++++++++++++++++++++++--
 1 file changed, 115 insertions(+), 5 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index caf03a908789..c150c8456799 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -2153,12 +2153,114 @@ let burn_origination_storage_fees ctxt
         paid_storage_size_diff;
       } )
 
-(** [burn_storage_fees ctxt smopr storage_limit payer] burns the storage fees
-    associated to an operation result [smopr].
+(** [burn_manager_storage_fees ctxt smopr storage_limit payer] burns the
+    storage fees associated to an external operation result [smopr].
     Returns an updated context, an updated storage limit with the space consumed
     by the operation subtracted, and [smopr] with the relevant balance updates
     included. *)
-let burn_storage_fees :
+let burn_manager_storage_fees :
+    type kind.
+    context ->
+    kind successful_manager_operation_result ->
+    storage_limit:Z.t ->
+    payer:public_key_hash ->
+    (context * Z.t * kind successful_manager_operation_result) tzresult Lwt.t =
+ fun ctxt smopr ~storage_limit ~payer ->
+  let payer = `Contract (Contract.Implicit payer) in
+  match smopr with
+  | Transaction_result transaction_result ->
+      burn_transaction_storage_fees
+        ctxt
+        transaction_result
+        ~storage_limit
+        ~payer
+      >>=? fun (ctxt, storage_limit, transaction_result) ->
+      return (ctxt, storage_limit, Transaction_result transaction_result)
+  | Origination_result origination_result ->
+      burn_origination_storage_fees
+        ctxt
+        origination_result
+        ~storage_limit
+        ~payer
+      >>=? fun (ctxt, storage_limit, origination_result) ->
+      return (ctxt, storage_limit, Origination_result origination_result)
+  | Reveal_result _ | Delegation_result _ -> return (ctxt, storage_limit, smopr)
+  | Register_global_constant_result payload ->
+      let consumed = payload.size_of_constant in
+      Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
+      >>=? fun (ctxt, storage_limit, storage_bus) ->
+      let balance_updates = storage_bus @ payload.balance_updates in
+      return
+        ( ctxt,
+          storage_limit,
+          Register_global_constant_result
+            {
+              balance_updates;
+              consumed_gas = payload.consumed_gas;
+              size_of_constant = payload.size_of_constant;
+              global_address = payload.global_address;
+            } )
+  | Set_deposits_limit_result _ -> return (ctxt, storage_limit, smopr)
+  | Tx_rollup_origination_result payload ->
+      Fees.burn_tx_rollup_origination_fees ctxt ~storage_limit ~payer
+      >>=? fun (ctxt, storage_limit, origination_bus) ->
+      let balance_updates = origination_bus @ payload.balance_updates in
+      return
+        ( ctxt,
+          storage_limit,
+          Tx_rollup_origination_result {payload with balance_updates} )
+  | Tx_rollup_return_bond_result _ | Tx_rollup_remove_commitment_result _
+  | Tx_rollup_rejection_result _ | Tx_rollup_finalize_commitment_result _
+  | Tx_rollup_commit_result _ ->
+      return (ctxt, storage_limit, smopr)
+  | Transfer_ticket_result payload ->
+      let consumed = payload.paid_storage_size_diff in
+      Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
+      >>=? fun (ctxt, storage_limit, storage_bus) ->
+      let balance_updates = payload.balance_updates @ storage_bus in
+      return
+        ( ctxt,
+          storage_limit,
+          Transfer_ticket_result {payload with balance_updates} )
+  | Tx_rollup_submit_batch_result payload ->
+      let consumed = payload.paid_storage_size_diff in
+      Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
+      >>=? fun (ctxt, storage_limit, storage_bus) ->
+      let balance_updates = storage_bus @ payload.balance_updates in
+      return
+        ( ctxt,
+          storage_limit,
+          Tx_rollup_submit_batch_result {payload with balance_updates} )
+  | Tx_rollup_dispatch_tickets_result payload ->
+      let consumed = payload.paid_storage_size_diff in
+      Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
+      >>=? fun (ctxt, storage_limit, storage_bus) ->
+      let balance_updates = storage_bus @ payload.balance_updates in
+      return
+        ( ctxt,
+          storage_limit,
+          Tx_rollup_dispatch_tickets_result {payload with balance_updates} )
+  | Sc_rollup_originate_result payload ->
+      Fees.burn_sc_rollup_origination_fees
+        ctxt
+        ~storage_limit
+        ~payer
+        payload.size
+      >>=? fun (ctxt, storage_limit, balance_updates) ->
+      let result = Sc_rollup_originate_result {payload with balance_updates} in
+      return (ctxt, storage_limit, result)
+  | Sc_rollup_add_messages_result _ -> return (ctxt, storage_limit, smopr)
+  | Sc_rollup_cement_result _ -> return (ctxt, storage_limit, smopr)
+  | Sc_rollup_publish_result _ -> return (ctxt, storage_limit, smopr)
+  | Sc_rollup_refute_result _ -> return (ctxt, storage_limit, smopr)
+  | Sc_rollup_timeout_result _ -> return (ctxt, storage_limit, smopr)
+
+(** [burn_internal_storage_fees ctxt smopr storage_limit payer] burns the
+    storage fees associated to an internal operation result [smopr].
+    Returns an updated context, an updated storage limit with the space consumed
+    by the operation subtracted, and [smopr] with the relevant balance updates
+    included. *)
+let burn_internal_storage_fees :
     type kind.
     context ->
     kind successful_manager_operation_result ->
@@ -2291,7 +2393,11 @@ let apply_manager_contents (type kind) ctxt mode chain_id
         internal_operations
       >>= function
       | Success ctxt, internal_operations_results -> (
-          burn_storage_fees ctxt operation_results ~storage_limit ~payer:source
+          burn_manager_storage_fees
+            ctxt
+            operation_results
+            ~storage_limit
+            ~payer:source
           >>= function
           | Ok (ctxt, storage_limit, operation_results) -> (
               List.fold_left_es
@@ -2299,7 +2405,11 @@ let apply_manager_contents (type kind) ctxt mode chain_id
                   let (Internal_manager_operation_result (op, mopr)) = imopr in
                   match mopr with
                   | Applied smopr ->
-                      burn_storage_fees ctxt smopr ~storage_limit ~payer:source
+                      burn_internal_storage_fees
+                        ctxt
+                        smopr
+                        ~storage_limit
+                        ~payer:source
                       >>=? fun (ctxt, storage_limit, smopr) ->
                       let imopr =
                         Internal_manager_operation_result (op, Applied smopr)
-- 
GitLab


From 94bd0a53655efa396468d07079759f6b14b3e728 Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Wed, 18 May 2022 13:32:24 +0200
Subject: [PATCH 09/12] Proto: separate internal and external manager result
 encodings.

The Internal_manager_result module is obtained by copy/pasting Manager_result, removing the non-internal operation cases, and using Internal_result instead of Operation.Encoding.Manager_operations.
---
 src/proto_alpha/lib_protocol/apply_results.ml | 180 +++++++++++++++++-
 1 file changed, 173 insertions(+), 7 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml
index a9b8c7c3184a..129465b789d1 100644
--- a/src/proto_alpha/lib_protocol/apply_results.ml
+++ b/src/proto_alpha/lib_protocol/apply_results.ml
@@ -517,6 +517,11 @@ module Manager_result = struct
               storage_size;
               paid_storage_size_diff;
             } ->
+            (* There used to be a [legacy_lazy_storage_diff] returned as the
+               first component of the tuple below, and the non-legacy one
+               returned as the last component. The legacy one has been removed,
+               but it was chosen to keep the non-legacy one at its position,
+               hence the order difference with regards to the record above. *)
             ( balance_updates,
               originated_contracts,
               Gas.Arith.ceil consumed_gas,
@@ -1164,14 +1169,169 @@ let internal_contents_encoding : packed_internal_contents Data_encoding.t =
           (obj2 (req "source" Contract.encoding) (req "nonce" uint16))
           Internal_result.encoding)
 
+module Internal_manager_result = struct
+  type 'kind case =
+    | MCase : {
+        op_case : 'kind Internal_result.case;
+        encoding : 'a Data_encoding.t;
+        kind : 'kind Kind.manager;
+        select :
+          packed_successful_manager_operation_result ->
+          'kind successful_manager_operation_result option;
+        proj : 'kind successful_manager_operation_result -> 'a;
+        inj : 'a -> 'kind successful_manager_operation_result;
+        t : 'kind manager_operation_result Data_encoding.t;
+      }
+        -> 'kind case
+
+  let make ~op_case ~encoding ~kind ~select ~proj ~inj =
+    let (Internal_result.MCase {name; _}) = op_case in
+    let t =
+      def (Format.asprintf "operation.alpha.operation_result.%s" name)
+      @@ union
+           ~tag_size:`Uint8
+           [
+             case
+               (Tag 0)
+               ~title:"Applied"
+               (merge_objs (obj1 (req "status" (constant "applied"))) encoding)
+               (fun o ->
+                 match o with
+                 | Skipped _ | Failed _ | Backtracked _ -> None
+                 | Applied o -> (
+                     match select (Successful_manager_result o) with
+                     | None -> None
+                     | Some o -> Some ((), proj o)))
+               (fun ((), x) -> Applied (inj x));
+             case
+               (Tag 1)
+               ~title:"Failed"
+               (obj2
+                  (req "status" (constant "failed"))
+                  (req "errors" trace_encoding))
+               (function Failed (_, errs) -> Some ((), errs) | _ -> None)
+               (fun ((), errs) -> Failed (kind, errs));
+             case
+               (Tag 2)
+               ~title:"Skipped"
+               (obj1 (req "status" (constant "skipped")))
+               (function Skipped _ -> Some () | _ -> None)
+               (fun () -> Skipped kind);
+             case
+               (Tag 3)
+               ~title:"Backtracked"
+               (merge_objs
+                  (obj2
+                     (req "status" (constant "backtracked"))
+                     (opt "errors" trace_encoding))
+                  encoding)
+               (fun o ->
+                 match o with
+                 | Skipped _ | Failed _ | Applied _ -> None
+                 | Backtracked (o, errs) -> (
+                     match select (Successful_manager_result o) with
+                     | None -> None
+                     | Some o -> Some (((), errs), proj o)))
+               (fun (((), errs), x) -> Backtracked (inj x, errs));
+           ]
+    in
+    MCase {op_case; encoding; kind; select; proj; inj; t}
+
+  let[@coq_axiom_with_reason "gadt"] transaction_case =
+    make
+      ~op_case:Internal_result.transaction_case
+      ~encoding:Manager_result.transaction_contract_variant_cases
+      ~select:(function
+        | Successful_manager_result (Transaction_result _ as op) -> Some op
+        | _ -> None)
+      ~kind:Kind.Transaction_manager_kind
+      ~proj:(function Transaction_result x -> x)
+      ~inj:(fun x -> Transaction_result x)
+
+  let[@coq_axiom_with_reason "gadt"] origination_case =
+    make
+      ~op_case:Internal_result.origination_case
+      ~encoding:
+        (obj7
+           (dft "balance_updates" Receipt.balance_updates_encoding [])
+           (dft "originated_contracts" (list Contract.originated_encoding) [])
+           (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero)
+           (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero)
+           (dft "storage_size" z Z.zero)
+           (dft "paid_storage_size_diff" z Z.zero)
+           (opt "lazy_storage_diff" Lazy_storage.encoding))
+      ~select:(function
+        | Successful_manager_result (Origination_result _ as op) -> Some op
+        | _ -> None)
+      ~proj:(function
+        | Origination_result
+            {
+              lazy_storage_diff;
+              balance_updates;
+              originated_contracts;
+              consumed_gas;
+              storage_size;
+              paid_storage_size_diff;
+            } ->
+            (* There used to be a [legacy_lazy_storage_diff] returned as the
+               first component of the tuple below, and the non-legacy one
+               returned as the last component. The legacy one has been removed,
+               but it was chosen to keep the non-legacy one at its position,
+               hence the order difference with regards to the record above. *)
+            ( balance_updates,
+              originated_contracts,
+              Gas.Arith.ceil consumed_gas,
+              consumed_gas,
+              storage_size,
+              paid_storage_size_diff,
+              lazy_storage_diff ))
+      ~kind:Kind.Origination_manager_kind
+      ~inj:
+        (fun ( balance_updates,
+               originated_contracts,
+               consumed_gas,
+               consumed_milligas,
+               storage_size,
+               paid_storage_size_diff,
+               lazy_storage_diff ) ->
+        assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ;
+        Origination_result
+          {
+            lazy_storage_diff;
+            balance_updates;
+            originated_contracts;
+            consumed_gas = consumed_milligas;
+            storage_size;
+            paid_storage_size_diff;
+          })
+
+  let delegation_case =
+    make
+      ~op_case:Internal_result.delegation_case
+      ~encoding:
+        Data_encoding.(
+          obj2
+            (dft "consumed_gas" Gas.Arith.n_integral_encoding Gas.Arith.zero)
+            (dft "consumed_milligas" Gas.Arith.n_fp_encoding Gas.Arith.zero))
+      ~select:(function
+        | Successful_manager_result (Delegation_result _ as op) -> Some op
+        | _ -> None)
+      ~kind:Kind.Delegation_manager_kind
+      ~proj:(function[@coq_match_with_default]
+        | Delegation_result {consumed_gas} ->
+            (Gas.Arith.ceil consumed_gas, consumed_gas))
+      ~inj:(fun (consumed_gas, consumed_milligas) ->
+        assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ;
+        Delegation_result {consumed_gas = consumed_milligas})
+end
+
 let internal_manager_operation_result_encoding :
     packed_internal_manager_operation_result Data_encoding.t =
   let make (type kind)
-      (Manager_result.MCase res_case : kind Manager_result.case)
+      (Internal_manager_result.MCase res_case :
+        kind Internal_manager_result.case)
       (Internal_result.MCase ires_case : kind Internal_result.case) =
-    let (Operation.Encoding.Manager_operations.MCase op_case) =
-      res_case.op_case
-    in
+    let (Internal_result.MCase op_case) = res_case.op_case in
     case
       (Tag op_case.tag)
       ~title:op_case.name
@@ -1193,9 +1353,15 @@ let internal_manager_operation_result_encoding :
   def "apply_results.alpha.operation_result"
   @@ union
        [
-         make Manager_result.transaction_case Internal_result.transaction_case;
-         make Manager_result.origination_case Internal_result.origination_case;
-         make Manager_result.delegation_case Internal_result.delegation_case;
+         make
+           Internal_manager_result.transaction_case
+           Internal_result.transaction_case;
+         make
+           Internal_manager_result.origination_case
+           Internal_result.origination_case;
+         make
+           Internal_manager_result.delegation_case
+           Internal_result.delegation_case;
        ]
 
 let successful_manager_operation_result_encoding :
-- 
GitLab


From b4566642818b40760ca0a23da5c74a714dd41408 Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Wed, 25 May 2022 11:48:33 +0200
Subject: [PATCH 10/12] Proto: pattern match on payload fields in Apply.

---
 src/proto_alpha/lib_protocol/apply.ml | 48 +++++++++++----------------
 1 file changed, 19 insertions(+), 29 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index c150c8456799..45932b517643 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -2287,26 +2287,20 @@ let burn_internal_storage_fees :
       >|=? fun (ctxt, storage_limit, origination_result) ->
       (ctxt, storage_limit, Origination_result origination_result)
   | Reveal_result _ | Delegation_result _ -> return (ctxt, storage_limit, smopr)
-  | Register_global_constant_result payload ->
+  | Register_global_constant_result ({balance_updates; _} as payload) ->
       let consumed = payload.size_of_constant in
       Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
       >>=? fun (ctxt, storage_limit, storage_bus) ->
-      let balance_updates = storage_bus @ payload.balance_updates in
+      let balance_updates = storage_bus @ balance_updates in
       return
         ( ctxt,
           storage_limit,
-          Register_global_constant_result
-            {
-              balance_updates;
-              consumed_gas = payload.consumed_gas;
-              size_of_constant = payload.size_of_constant;
-              global_address = payload.global_address;
-            } )
+          Register_global_constant_result {payload with balance_updates} )
   | Set_deposits_limit_result _ -> return (ctxt, storage_limit, smopr)
-  | Tx_rollup_origination_result payload ->
+  | Tx_rollup_origination_result ({balance_updates; _} as payload) ->
       Fees.burn_tx_rollup_origination_fees ctxt ~storage_limit ~payer
       >>=? fun (ctxt, storage_limit, origination_bus) ->
-      let balance_updates = origination_bus @ payload.balance_updates in
+      let balance_updates = origination_bus @ balance_updates in
       return
         ( ctxt,
           storage_limit,
@@ -2315,39 +2309,35 @@ let burn_internal_storage_fees :
   | Tx_rollup_rejection_result _ | Tx_rollup_finalize_commitment_result _
   | Tx_rollup_commit_result _ ->
       return (ctxt, storage_limit, smopr)
-  | Transfer_ticket_result payload ->
-      let consumed = payload.paid_storage_size_diff in
-      Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
+  | Transfer_ticket_result
+      ({balance_updates; paid_storage_size_diff; _} as payload) ->
+      Fees.burn_storage_fees ctxt ~storage_limit ~payer paid_storage_size_diff
       >>=? fun (ctxt, storage_limit, storage_bus) ->
-      let balance_updates = payload.balance_updates @ storage_bus in
+      let balance_updates = balance_updates @ storage_bus in
       return
         ( ctxt,
           storage_limit,
           Transfer_ticket_result {payload with balance_updates} )
-  | Tx_rollup_submit_batch_result payload ->
-      let consumed = payload.paid_storage_size_diff in
-      Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
+  | Tx_rollup_submit_batch_result
+      ({balance_updates; paid_storage_size_diff; _} as payload) ->
+      Fees.burn_storage_fees ctxt ~storage_limit ~payer paid_storage_size_diff
       >>=? fun (ctxt, storage_limit, storage_bus) ->
-      let balance_updates = storage_bus @ payload.balance_updates in
+      let balance_updates = storage_bus @ balance_updates in
       return
         ( ctxt,
           storage_limit,
           Tx_rollup_submit_batch_result {payload with balance_updates} )
-  | Tx_rollup_dispatch_tickets_result payload ->
-      let consumed = payload.paid_storage_size_diff in
-      Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
+  | Tx_rollup_dispatch_tickets_result
+      ({balance_updates; paid_storage_size_diff; _} as payload) ->
+      Fees.burn_storage_fees ctxt ~storage_limit ~payer paid_storage_size_diff
       >>=? fun (ctxt, storage_limit, storage_bus) ->
-      let balance_updates = storage_bus @ payload.balance_updates in
+      let balance_updates = storage_bus @ balance_updates in
       return
         ( ctxt,
           storage_limit,
           Tx_rollup_dispatch_tickets_result {payload with balance_updates} )
-  | Sc_rollup_originate_result payload ->
-      Fees.burn_sc_rollup_origination_fees
-        ctxt
-        ~storage_limit
-        ~payer
-        payload.size
+  | Sc_rollup_originate_result ({size; _} as payload) ->
+      Fees.burn_sc_rollup_origination_fees ctxt ~storage_limit ~payer size
       >>=? fun (ctxt, storage_limit, balance_updates) ->
       let result = Sc_rollup_originate_result {payload with balance_updates} in
       return (ctxt, storage_limit, result)
-- 
GitLab


From 9abb08472d8a87fcccec19a13e47cf78aa7c9c73 Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Wed, 25 May 2022 11:55:06 +0200
Subject: [PATCH 11/12] Proto: switch between monad operators.

---
 src/proto_alpha/lib_protocol/apply.ml | 61 ++++++++++++---------------
 1 file changed, 28 insertions(+), 33 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index 45932b517643..418634db4984 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -2188,27 +2188,25 @@ let burn_manager_storage_fees :
   | Register_global_constant_result payload ->
       let consumed = payload.size_of_constant in
       Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
-      >>=? fun (ctxt, storage_limit, storage_bus) ->
+      >|=? fun (ctxt, storage_limit, storage_bus) ->
       let balance_updates = storage_bus @ payload.balance_updates in
-      return
-        ( ctxt,
-          storage_limit,
-          Register_global_constant_result
-            {
-              balance_updates;
-              consumed_gas = payload.consumed_gas;
-              size_of_constant = payload.size_of_constant;
-              global_address = payload.global_address;
-            } )
+      ( ctxt,
+        storage_limit,
+        Register_global_constant_result
+          {
+            balance_updates;
+            consumed_gas = payload.consumed_gas;
+            size_of_constant = payload.size_of_constant;
+            global_address = payload.global_address;
+          } )
   | Set_deposits_limit_result _ -> return (ctxt, storage_limit, smopr)
   | Tx_rollup_origination_result payload ->
       Fees.burn_tx_rollup_origination_fees ctxt ~storage_limit ~payer
-      >>=? fun (ctxt, storage_limit, origination_bus) ->
+      >|=? fun (ctxt, storage_limit, origination_bus) ->
       let balance_updates = origination_bus @ payload.balance_updates in
-      return
-        ( ctxt,
-          storage_limit,
-          Tx_rollup_origination_result {payload with balance_updates} )
+      ( ctxt,
+        storage_limit,
+        Tx_rollup_origination_result {payload with balance_updates} )
   | Tx_rollup_return_bond_result _ | Tx_rollup_remove_commitment_result _
   | Tx_rollup_rejection_result _ | Tx_rollup_finalize_commitment_result _
   | Tx_rollup_commit_result _ ->
@@ -2216,39 +2214,36 @@ let burn_manager_storage_fees :
   | Transfer_ticket_result payload ->
       let consumed = payload.paid_storage_size_diff in
       Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
-      >>=? fun (ctxt, storage_limit, storage_bus) ->
+      >|=? fun (ctxt, storage_limit, storage_bus) ->
       let balance_updates = payload.balance_updates @ storage_bus in
-      return
-        ( ctxt,
-          storage_limit,
-          Transfer_ticket_result {payload with balance_updates} )
+      ( ctxt,
+        storage_limit,
+        Transfer_ticket_result {payload with balance_updates} )
   | Tx_rollup_submit_batch_result payload ->
       let consumed = payload.paid_storage_size_diff in
       Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
-      >>=? fun (ctxt, storage_limit, storage_bus) ->
+      >|=? fun (ctxt, storage_limit, storage_bus) ->
       let balance_updates = storage_bus @ payload.balance_updates in
-      return
-        ( ctxt,
-          storage_limit,
-          Tx_rollup_submit_batch_result {payload with balance_updates} )
+      ( ctxt,
+        storage_limit,
+        Tx_rollup_submit_batch_result {payload with balance_updates} )
   | Tx_rollup_dispatch_tickets_result payload ->
       let consumed = payload.paid_storage_size_diff in
       Fees.burn_storage_fees ctxt ~storage_limit ~payer consumed
-      >>=? fun (ctxt, storage_limit, storage_bus) ->
+      >|=? fun (ctxt, storage_limit, storage_bus) ->
       let balance_updates = storage_bus @ payload.balance_updates in
-      return
-        ( ctxt,
-          storage_limit,
-          Tx_rollup_dispatch_tickets_result {payload with balance_updates} )
+      ( ctxt,
+        storage_limit,
+        Tx_rollup_dispatch_tickets_result {payload with balance_updates} )
   | Sc_rollup_originate_result payload ->
       Fees.burn_sc_rollup_origination_fees
         ctxt
         ~storage_limit
         ~payer
         payload.size
-      >>=? fun (ctxt, storage_limit, balance_updates) ->
+      >|=? fun (ctxt, storage_limit, balance_updates) ->
       let result = Sc_rollup_originate_result {payload with balance_updates} in
-      return (ctxt, storage_limit, result)
+      (ctxt, storage_limit, result)
   | Sc_rollup_add_messages_result _ -> return (ctxt, storage_limit, smopr)
   | Sc_rollup_cement_result _ -> return (ctxt, storage_limit, smopr)
   | Sc_rollup_publish_result _ -> return (ctxt, storage_limit, smopr)
-- 
GitLab


From 226281ca1c5783b94820a2ab535fa39dc9cf1733 Mon Sep 17 00:00:00 2001
From: Nicolas Ayache <nicolas.ayache@nomadic-labs.com>
Date: Wed, 25 May 2022 13:33:49 +0200
Subject: [PATCH 12/12] Proto: inline some functions used once.

---
 src/proto_alpha/lib_protocol/apply.ml | 148 ++++++--------------------
 1 file changed, 30 insertions(+), 118 deletions(-)

diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml
index 418634db4984..822db50fca38 100644
--- a/src/proto_alpha/lib_protocol/apply.ml
+++ b/src/proto_alpha/lib_protocol/apply.ml
@@ -797,16 +797,6 @@ let apply_delegation ~ctxt ~source ~delegate ~before_operation =
   Delegate.set ctxt source delegate >|=? fun ctxt ->
   (ctxt, Gas.consumed ~since:before_operation ~until:ctxt, [])
 
-let apply_internal_delegation ~ctxt ~source ~delegate ~before_operation =
-  apply_delegation ~ctxt ~source ~delegate ~before_operation
-  >|=? fun (ctxt, consumed_gas, ops) ->
-  (ctxt, Delegation_result {consumed_gas}, ops)
-
-let apply_manager_delegation ~ctxt ~source ~delegate ~before_operation =
-  apply_delegation ~ctxt ~source ~delegate ~before_operation
-  >|=? fun (ctxt, consumed_gas, ops) ->
-  (ctxt, Delegation_result {consumed_gas}, ops)
-
 type execution_arg =
   | Typed_arg :
       Script.location * ('a, _) Script_typed_ir.ty * 'a
@@ -856,30 +846,6 @@ let apply_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~parameter
       in
       (ctxt, result, []) )
 
-let apply_internal_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~parameter
-    ~entrypoint ~before_operation =
-  apply_transaction_to_implicit
-    ~ctxt
-    ~source
-    ~amount
-    ~pkh
-    ~parameter
-    ~entrypoint
-    ~before_operation
-  >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops)
-
-let apply_manager_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~parameter
-    ~entrypoint ~before_operation =
-  apply_transaction_to_implicit
-    ~ctxt
-    ~source
-    ~amount
-    ~pkh
-    ~parameter
-    ~entrypoint
-    ~before_operation
-  >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops)
-
 let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount
     ~entrypoint ~before_operation ~payer ~chain_id ~mode ~internal ~parameter =
   let contract = Contract.Originated contract_hash in
@@ -983,40 +949,6 @@ let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount
           in
           (ctxt, result, operations) )
 
-let apply_internal_transaction_to_smart_contract ~ctxt ~source ~contract_hash
-    ~amount ~entrypoint ~before_operation ~payer ~chain_id ~mode ~internal
-    ~parameter =
-  apply_transaction_to_smart_contract
-    ~ctxt
-    ~source
-    ~contract_hash
-    ~amount
-    ~entrypoint
-    ~before_operation
-    ~payer
-    ~chain_id
-    ~mode
-    ~internal
-    ~parameter
-  >>=? fun (ctxt, res, ops) -> return (ctxt, Transaction_result res, ops)
-
-let apply_manager_transaction_to_smart_contract ~ctxt ~source ~contract_hash
-    ~amount ~entrypoint ~before_operation ~payer ~chain_id ~mode ~internal
-    ~parameter =
-  apply_transaction_to_smart_contract
-    ~ctxt
-    ~source
-    ~contract_hash
-    ~amount
-    ~entrypoint
-    ~before_operation
-    ~payer
-    ~chain_id
-    ~mode
-    ~internal
-    ~parameter
-  >>=? fun (ctxt, res, ops) -> return (ctxt, Transaction_result res, ops)
-
 let ex_ticket_size :
     context -> Ticket_scanner.ex_ticket -> (context * int) tzresult Lwt.t =
  fun ctxt (Ex_ticket (ty, ticket)) ->
@@ -1149,36 +1081,6 @@ let apply_origination ~ctxt ~storage_type ~storage ~unparsed_code
   in
   (ctxt, result, [])
 
-let apply_internal_origination ~ctxt ~storage_type ~storage ~unparsed_code
-    ~contract ~delegate ~source ~credit ~before_operation =
-  apply_origination
-    ~ctxt
-    ~storage_type
-    ~storage
-    ~unparsed_code
-    ~contract
-    ~delegate
-    ~source
-    ~credit
-    ~before_operation
-  >|=? fun (ctxt, origination_result, ops) ->
-  (ctxt, Origination_result origination_result, ops)
-
-let apply_manager_origination ~ctxt ~storage_type ~storage ~unparsed_code
-    ~contract ~delegate ~source ~credit ~before_operation =
-  apply_origination
-    ~ctxt
-    ~storage_type
-    ~storage
-    ~unparsed_code
-    ~contract
-    ~delegate
-    ~source
-    ~credit
-    ~before_operation
-  >|=? fun (ctxt, origination_result, ops) ->
-  (ctxt, Origination_result origination_result, ops)
-
 (**
 
    Retrieving the source code of a contract from its address is costly
@@ -1239,15 +1141,18 @@ let apply_internal_manager_operation_content :
         parameters_ty;
         parameters = typed_parameters;
       } ->
-      (apply_internal_transaction_to_implicit
-         ~ctxt
-         ~parameter:(Typed_arg (location, parameters_ty, typed_parameters))
-         ~source
-         ~pkh
-         ~amount
-         ~entrypoint
-         ~before_operation
-        : (_ * kind successful_manager_operation_result * _) tzresult Lwt.t)
+      apply_transaction_to_implicit
+        ~ctxt
+        ~source
+        ~amount
+        ~pkh
+        ~parameter:(Typed_arg (location, parameters_ty, typed_parameters))
+        ~entrypoint
+        ~before_operation
+      >|=? fun (ctxt, res, ops) ->
+      ( ctxt,
+        (Transaction_result res : kind successful_manager_operation_result),
+        ops )
   | Transaction_to_contract
       {
         amount;
@@ -1258,7 +1163,7 @@ let apply_internal_manager_operation_content :
         parameters = typed_parameters;
         unparsed_parameters = _;
       } ->
-      apply_internal_transaction_to_smart_contract
+      apply_transaction_to_smart_contract
         ~ctxt
         ~source
         ~contract_hash
@@ -1270,6 +1175,7 @@ let apply_internal_manager_operation_content :
         ~mode
         ~internal:true
         ~parameter:(Typed_arg (location, parameters_ty, typed_parameters))
+      >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops)
   | Transaction_to_tx_rollup
       {destination; unparsed_parameters = _; parameters_ty; parameters} ->
       apply_transaction_to_tx_rollup
@@ -1291,7 +1197,7 @@ let apply_internal_manager_operation_content :
         ctxt
         script.Script.code
       >>?= fun (unparsed_code, ctxt) ->
-      apply_internal_origination
+      apply_origination
         ~ctxt
         ~storage_type
         ~storage
@@ -1301,8 +1207,12 @@ let apply_internal_manager_operation_content :
         ~source
         ~credit
         ~before_operation
+      >|=? fun (ctxt, origination_result, ops) ->
+      (ctxt, Origination_result origination_result, ops)
   | Delegation delegate ->
-      apply_internal_delegation ~ctxt ~source ~delegate ~before_operation
+      apply_delegation ~ctxt ~source ~delegate ~before_operation
+      >|=? fun (ctxt, consumed_gas, ops) ->
+      (ctxt, Delegation_result {consumed_gas}, ops)
 
 let apply_external_manager_operation_content :
     type kind.
@@ -1339,7 +1249,7 @@ let apply_external_manager_operation_content :
         ctxt
         parameters
       >>?= fun (parameters, ctxt) ->
-      apply_manager_transaction_to_implicit
+      apply_transaction_to_implicit
         ~ctxt
         ~source:source_contract
         ~amount
@@ -1347,6 +1257,7 @@ let apply_external_manager_operation_content :
         ~parameter:(Untyped_arg parameters)
         ~entrypoint
         ~before_operation
+      >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops)
   | Transaction
       {amount; parameters; destination = Originated contract_hash; entrypoint}
     ->
@@ -1355,7 +1266,7 @@ let apply_external_manager_operation_content :
         ctxt
         parameters
       >>?= fun (parameters, ctxt) ->
-      apply_manager_transaction_to_smart_contract
+      apply_transaction_to_smart_contract
         ~ctxt
         ~source:source_contract
         ~contract_hash
@@ -1367,6 +1278,7 @@ let apply_external_manager_operation_content :
         ~mode
         ~internal:false
         ~parameter:(Untyped_arg parameters)
+      >|=? fun (ctxt, res, ops) -> (ctxt, Transaction_result res, ops)
   | Tx_rollup_dispatch_tickets
       {
         tx_rollup;
@@ -1525,7 +1437,7 @@ let apply_external_manager_operation_content :
         (Script_tc_errors.Ill_typed_contract (unparsed_code, []))
         views_result
       >>=? fun (_typed_views, ctxt) ->
-      apply_manager_origination
+      apply_origination
         ~ctxt
         ~storage_type
         ~storage
@@ -1535,12 +1447,12 @@ let apply_external_manager_operation_content :
         ~source:source_contract
         ~credit
         ~before_operation
+      >|=? fun (ctxt, origination_result, ops) ->
+      (ctxt, Origination_result origination_result, ops)
   | Delegation delegate ->
-      apply_manager_delegation
-        ~ctxt
-        ~source:source_contract
-        ~delegate
-        ~before_operation
+      apply_delegation ~ctxt ~source:source_contract ~delegate ~before_operation
+      >|=? fun (ctxt, consumed_gas, ops) ->
+      (ctxt, Delegation_result {consumed_gas}, ops)
   | Register_global_constant {value} ->
       (* Decode the value and consume gas appropriately *)
       Script.force_decode_in_context ~consume_deserialization_gas ctxt value
-- 
GitLab