From 82b3bde8f83cf13d82cec52c62bf198e5d884bf6 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 28 Jul 2021 17:02:53 +0200 Subject: [PATCH 001/105] Proto: compile compare_comparable to Coq --- .../lib_protocol/script_comparable.ml | 82 +++++++++++-------- 1 file changed, 49 insertions(+), 33 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_comparable.ml b/src/proto_alpha/lib_protocol/script_comparable.ml index 394285268528a..3b2b09b80504a 100644 --- a/src/proto_alpha/lib_protocol/script_comparable.ml +++ b/src/proto_alpha/lib_protocol/script_comparable.ml @@ -42,48 +42,63 @@ type compare_comparable_cont = -> compare_comparable_cont | Compare_comparable_return : compare_comparable_cont -let compare_comparable : type a. a comparable_ty -> a -> a -> int = - let rec compare_comparable : +module Compare_comparable = struct + let[@coq_struct "kind_value"] rec compare_comparable : type a. a comparable_ty -> compare_comparable_cont -> a -> a -> int = fun kind k x y -> - match (kind, x, y) with - | (Unit_t, (), ()) -> (apply [@tailcall]) 0 k + match[@coq_match_gadt] [@coq_match_with_default] (kind, x, y) with + | (Unit_t, _, _) -> (apply [@tailcall]) 0 k | (Never_t, _, _) -> . - | (Signature_t, x, y) -> + | (Signature_t, (x : signature), (y : signature)) -> (apply [@tailcall]) (Script_signature.compare x y) k - | (String_t, x, y) -> (apply [@tailcall]) (Script_string.compare x y) k - | (Bool_t, x, y) -> (apply [@tailcall]) (Compare.Bool.compare x y) k - | (Mutez_t, x, y) -> (apply [@tailcall]) (Tez.compare x y) k - | (Key_hash_t, x, y) -> + | (String_t, (x : Script_string.t), (y : Script_string.t)) -> + (apply [@tailcall]) (Script_string.compare x y) k + | (Bool_t, (x : bool), (y : bool)) -> + (apply [@tailcall]) (Compare.Bool.compare x y) k + | (Mutez_t, (x : Tez.t), (y : Tez.t)) -> + (apply [@tailcall]) (Tez.compare x y) k + | (Key_hash_t, (x : public_key_hash), (y : public_key_hash)) -> (apply [@tailcall]) (Signature.Public_key_hash.compare x y) k - | (Key_t, x, y) -> (apply [@tailcall]) (Signature.Public_key.compare x y) k - | (Int_t, x, y) -> (apply [@tailcall]) (Script_int.compare x y) k - | (Nat_t, x, y) -> (apply [@tailcall]) (Script_int.compare x y) k - | (Timestamp_t, x, y) -> + | (Key_t, (x : public_key), (y : public_key)) -> + (apply [@tailcall]) (Signature.Public_key.compare x y) k + | (Int_t, (x : _ Script_int.num), (y : _ Script_int.num)) -> + (apply [@tailcall]) (Script_int.compare x y) k + | (Nat_t, (x : _ Script_int.num), (y : _ Script_int.num)) -> + (apply [@tailcall]) (Script_int.compare x y) k + | (Timestamp_t, (x : Script_timestamp.t), (y : Script_timestamp.t)) -> (apply [@tailcall]) (Script_timestamp.compare x y) k - | (Address_t, x, y) -> (apply [@tailcall]) (compare_address x y) k - | (Tx_rollup_l2_address_t, x, y) -> + | (Address_t, (x : address), (y : address)) -> + (apply [@tailcall]) (compare_address x y) k + | ( Tx_rollup_l2_address_t, + (x : tx_rollup_l2_address), + (y : tx_rollup_l2_address) ) -> (apply [@tailcall]) (compare_tx_rollup_l2_address x y) k - | (Bytes_t, x, y) -> (apply [@tailcall]) (Compare.Bytes.compare x y) k - | (Chain_id_t, x, y) -> (apply [@tailcall]) (Script_chain_id.compare x y) k - | (Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry)) -> + | (Bytes_t, (x : bytes), (y : bytes)) -> + (apply [@tailcall]) (Compare.Bytes.compare x y) k + | (Chain_id_t, (x : Script_chain_id.t), (y : Script_chain_id.t)) -> + (apply [@tailcall]) (Script_chain_id.compare x y) k + | (Pair_t (tl, tr, _, YesYes), (x : _ * _), (y : _ * _)) -> + let (lx, rx) = x in + let (ly, ry) = y in (compare_comparable [@tailcall]) tl (Compare_comparable (tr, rx, ry, k)) lx ly - | (Union_t (tl, _, _, YesYes), L x, L y) -> - (compare_comparable [@tailcall]) tl k x y - | (Union_t _, L _, R _) -> -1 - | (Union_t _, R _, L _) -> 1 - | (Union_t (_, tr, _, YesYes), R x, R y) -> - (compare_comparable [@tailcall]) tr k x y - | (Option_t _, None, None) -> (apply [@tailcall]) 0 k - | (Option_t _, None, Some _) -> -1 - | (Option_t _, Some _, None) -> 1 - | (Option_t (t, _, Yes), Some x, Some y) -> - (compare_comparable [@tailcall]) t k x y - and apply ret k = + | (Union_t (tl, tr, _, YesYes), (x : (_, _) union), (y : (_, _) union)) -> ( + match (x, y) with + | (L x, L y) -> (compare_comparable [@tailcall]) tl k x y + | (L _, R _) -> -1 + | (R _, L _) -> 1 + | (R x, R y) -> (compare_comparable [@tailcall]) tr k x y) + | (Option_t (t, _, _), (x : _ option), (y : _ option)) -> ( + match (x, y) with + | (None, None) -> (apply [@tailcall]) 0 k + | (None, Some _) -> -1 + | (Some _, None) -> 1 + | (Some x, Some y) -> (compare_comparable [@tailcall]) t k x y) + + and[@coq_mutual_as_notation] apply ret k = match (ret, k) with | (0, Compare_comparable (ty, x, y, k)) -> (compare_comparable [@tailcall]) ty k x y @@ -91,6 +106,7 @@ let compare_comparable : type a. a comparable_ty -> a -> a -> int = | (ret, _) -> (* ret <> 0, we perform an early exit *) if Compare.Int.(ret > 0) then 1 else -1 - in - fun t -> compare_comparable t Compare_comparable_return - [@@coq_axiom_with_reason "non top-level mutually recursive function"] +end + +let compare_comparable : type a. a comparable_ty -> a -> a -> int = + fun t -> Compare_comparable.compare_comparable t Compare_comparable_return -- GitLab From a48e3cea99556b68f10de8ab3bcbe68cf66b6a8d Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 11 Aug 2021 17:05:49 +0200 Subject: [PATCH 002/105] Proto: add annotations for recursive functions in coq-of-ocaml --- src/proto_alpha/lib_protocol/global_constants_storage.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/global_constants_storage.ml b/src/proto_alpha/lib_protocol/global_constants_storage.ml index 429b454d44f18..89c6cca985cd3 100644 --- a/src/proto_alpha/lib_protocol/global_constants_storage.ml +++ b/src/proto_alpha/lib_protocol/global_constants_storage.ml @@ -225,7 +225,7 @@ let expand context expr = with [Expression_too_deep] if greater than [max_allowed_global_constant_depth].*) let check_depth node = - let rec advance node depth k = + let[@coq_struct "node"] rec advance node depth k = if Compare.Int.(depth > Constants_repr.max_allowed_global_constant_depth) then error Expression_too_deep else -- GitLab From a97a31c6cc0e6107bcb3c915740d180b28e51886 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 11 Aug 2021 17:44:06 +0200 Subject: [PATCH 003/105] Proto: make micheline_fold_aux less polymorphic to simplify proofs --- src/proto_alpha/lib_protocol/global_constants_storage.ml | 2 +- src/proto_alpha/lib_protocol/script_repr.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/global_constants_storage.ml b/src/proto_alpha/lib_protocol/global_constants_storage.ml index 89c6cca985cd3..19eac66ef2586 100644 --- a/src/proto_alpha/lib_protocol/global_constants_storage.ml +++ b/src/proto_alpha/lib_protocol/global_constants_storage.ml @@ -225,7 +225,7 @@ let expand context expr = with [Expression_too_deep] if greater than [max_allowed_global_constant_depth].*) let check_depth node = - let[@coq_struct "node"] rec advance node depth k = + let[@coq_struct "node_value"] rec advance node depth k = if Compare.Int.(depth > Constants_repr.max_allowed_global_constant_depth) then error Expression_too_deep else diff --git a/src/proto_alpha/lib_protocol/script_repr.ml b/src/proto_alpha/lib_protocol/script_repr.ml index 681d6d7c627a5..aed2abd3de133 100644 --- a/src/proto_alpha/lib_protocol/script_repr.ml +++ b/src/proto_alpha/lib_protocol/script_repr.ml @@ -312,7 +312,7 @@ let is_unit_parameter = ~fun_bytes:(fun b -> Compare.Bytes.equal b unit_bytes) ~fun_combine:(fun res _ -> res) -let[@coq_struct "node"] rec strip_annotations node = +let[@coq_struct "node_value"] rec strip_annotations node = let open Micheline in match node with | (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf -> leaf @@ -320,7 +320,7 @@ let[@coq_struct "node"] rec strip_annotations node = Prim (loc, name, List.map strip_annotations args, []) | Seq (loc, args) -> Seq (loc, List.map strip_annotations args) -let rec micheline_fold_aux node f acc k = +let rec micheline_fold_aux (node : _ michelson_node) f acc k = match node with | Micheline.Int (_, _) -> k (f acc node) | Micheline.String (_, _) -> k (f acc node) -- GitLab From 1cac1fbd16da495d012809930e6ffa3848b2f967 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Mon, 30 Aug 2021 14:38:04 +0200 Subject: [PATCH 004/105] Proto: add a phantom type annotation for coq-of-ocaml --- src/proto_alpha/lib_protocol/script_typed_ir.ml | 2 +- src/proto_alpha/lib_protocol/script_typed_ir.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index cb9b0ab5f7c13..1683aedf4754a 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -241,7 +241,7 @@ module type TYPE_SIZE = sig submodule), the type is abstract but we have access to unsafe constructors that can break the invariant. *) - type 'a t + type 'a t [@@coq_phantom] val check_eq : error_details:'error_trace Script_tc_errors.error_details -> diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 7d69f8ada1e66..1651e995e13d8 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -174,7 +174,7 @@ type empty_cell = EmptyCell type end_of_stack = empty_cell * empty_cell module Type_size : sig - type 'a t + type 'a t [@@coq_phantom] val check_eq : error_details:'error_trace Script_tc_errors.error_details -> -- GitLab From 3645e4482ece8ec5372c756bacbe3577b744d0be Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 15 Sep 2021 16:24:09 +0200 Subject: [PATCH 005/105] Proto: add module type annotation to help coq-of-ocaml --- src/proto_alpha/lib_protocol/script_map.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/script_map.ml b/src/proto_alpha/lib_protocol/script_map.ml index 5a96396a518b5..e3fa0e966c7bc 100644 --- a/src/proto_alpha/lib_protocol/script_map.ml +++ b/src/proto_alpha/lib_protocol/script_map.ml @@ -49,7 +49,7 @@ let empty_from : type a b c. (a, b) map -> (a, c) map = let empty : type a b. a comparable_ty -> (a, b) map = fun ty -> - let module OPS = struct + let module OPS : Boxed_map_OPS with type key = a = struct let key_size = Gas_comparable_input_size.size_of_comparable_value ty include Map.Make (struct -- GitLab From 2b3ef2716ab8567e747f2e2f7797179808176398 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 15 Sep 2021 16:24:57 +0200 Subject: [PATCH 006/105] Proto: add Coq annotation for incomplete match --- src/proto_alpha/lib_protocol/script_typed_ir.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 1683aedf4754a..63bd851755661 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -2440,5 +2440,6 @@ let value_traverse (type t tc) (ty : ((t, tc) ty, t comparable_ty) union) | R cty -> aux' init cty x (fun accu -> accu) [@@coq_axiom_with_reason "local mutually recursive definition not handled"] -let stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c = function +let stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c = + function[@coq_match_with_default] | Item_t (ty, _) -> Ty_ex_c ty -- GitLab From c57495ae40fd28a1b64c2b0a7c1db40ae8b70991 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 15 Sep 2021 21:41:43 +0200 Subject: [PATCH 007/105] Proto: split function couples for Coq --- .../lib_protocol/script_typed_ir.ml | 20 ++++++++---- .../lib_protocol/script_typed_ir_size.ml | 32 ++++++++++--------- 2 files changed, 30 insertions(+), 22 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 63bd851755661..7dc9ec48bb08e 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -2233,7 +2233,7 @@ type 'a ty_traverse = { apply_comparable : 't. 'a -> 't comparable_ty -> 'a; } -let (ty_traverse, comparable_ty_traverse) = +module Ty_traverse = struct let rec aux : type t ret accu. accu ty_traverse -> accu -> t comparable_ty -> (accu -> ret) -> ret = @@ -2257,7 +2257,8 @@ let (ty_traverse, comparable_ty_traverse) = | Pair_t (ty1, ty2, _, YesYes) -> (next2 [@ocaml.tailcall]) ty1 ty2 | Union_t (ty1, ty2, _, YesYes) -> (next2 [@ocaml.tailcall]) ty1 ty2 | Option_t (ty, _, Yes) -> (next [@ocaml.tailcall]) ty - and aux' : + + let rec aux' : type ret t tc accu. accu ty_traverse -> accu -> (t, tc) ty -> (accu -> ret) -> ret = fun f accu ty continue -> @@ -2287,7 +2288,8 @@ let (ty_traverse, comparable_ty_traverse) = (aux [@ocaml.tailcall]) f accu cty @@ fun accu -> (next' [@ocaml.tailcall]) f accu ty1 continue | Contract_t (ty1, _) -> (next' [@ocaml.tailcall]) f accu ty1 continue - and next2' : + + and[@coq_mutual_as_notation] next2' : type a ac b bc ret accu. accu ty_traverse -> accu -> @@ -2299,15 +2301,19 @@ let (ty_traverse, comparable_ty_traverse) = (aux' [@ocaml.tailcall]) f accu ty1 @@ fun accu -> (aux' [@ocaml.tailcall]) f accu ty2 @@ fun accu -> (continue [@ocaml.tailcall]) accu - and next' : + + and[@coq_mutual_as_notation] next' : type a ac ret accu. accu ty_traverse -> accu -> (a, ac) ty -> (accu -> ret) -> ret = fun f accu ty1 continue -> (aux' [@ocaml.tailcall]) f accu ty1 @@ fun accu -> (continue [@ocaml.tailcall]) accu - in - ( (fun ty init f -> aux' f init ty (fun accu -> accu)), - fun cty init f -> aux f init cty (fun accu -> accu) ) +end + +let comparable_ty_traverse cty init f = + Ty_traverse.aux f init cty (fun accu -> accu) + +let ty_traverse ty init f = Ty_traverse.aux' f init ty (fun accu -> accu) type 'accu stack_ty_traverse = { apply : 'ty 's. 'accu -> ('ty, 's) stack_ty -> 'accu; diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 7cf303d552bf3..296631a49692e 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -32,15 +32,16 @@ let script_string_size s = Script_string.to_string s |> string_size (* Memo-sizes are 16-bit integers *) let sapling_memo_size_size = !!0 -let ty_traverse_f = - let base_basic = - !!0 - (* Basic types count for 0 because they are all static values, hence shared - and not counted by `reachable_words`. - On the other hand compound types are functions, hence not shared. *) - in - let base_compound_no_meta = header_size in - let base_compound _meta = h1w in +module Ty_size = struct + let base_basic = !!0 + (* Basic types count for 0 because they are all static values, hence shared + and not counted by `reachable_words`. + On the other hand compound types are functions, hence not shared. *) + + let base_compound_no_meta = header_size + + let base_compound _meta = h1w + let apply_comparable : type a. nodes_and_size -> a comparable_ty -> nodes_and_size = fun accu cty -> @@ -66,7 +67,8 @@ let ty_traverse_f = ret_succ_adding accu @@ (base_compound a +! (word_size *? 3)) | Option_t (_ty, a, Yes) -> ret_succ_adding accu @@ (base_compound a +! (word_size *? 2)) - and apply : type a ac. nodes_and_size -> (a, ac) ty -> nodes_and_size = + + let apply : type a ac. nodes_and_size -> (a, ac) ty -> nodes_and_size = fun accu ty -> match ty with | Unit_t -> ret_succ_adding accu base_basic @@ -117,14 +119,14 @@ let ty_traverse_f = @@ (base_compound_no_meta +! sapling_memo_size_size +! word_size) | Ticket_t (_cty, a) -> ret_succ_adding accu @@ (base_compound a +! word_size) - in - ({apply; apply_comparable} : nodes_and_size ty_traverse) -let comparable_ty_size : type a. a comparable_ty -> nodes_and_size = - fun cty -> comparable_ty_traverse cty zero ty_traverse_f + let f = ({apply; apply_comparable} : nodes_and_size ty_traverse) +end + +let comparable_ty_size cty = comparable_ty_traverse cty zero Ty_size.f let ty_size : type a ac. (a, ac) ty -> nodes_and_size = - fun ty -> ty_traverse ty zero ty_traverse_f + fun ty -> ty_traverse ty zero Ty_size.f let stack_ty_size s = let apply : type a s. nodes_and_size -> (a, s) stack_ty -> nodes_and_size = -- GitLab From f8eda194ebeaf6961f953db1a016f04d9a6a991e Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 27 Oct 2021 16:33:56 +0200 Subject: [PATCH 008/105] TEMP: add match existential annotations --- src/proto_alpha/lib_protocol/apply_results.ml | 111 ++++++++++-------- .../lib_protocol/operation_repr.ml | 17 +-- 2 files changed, 70 insertions(+), 58 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 065e5d6c4f0c0..5d604f772b886 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -1086,26 +1086,26 @@ let internal_manager_operation_result_encoding : let make (type kind) (Manager_result.MCase res_case : kind 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 - case - (Tag op_case.tag) - ~title:op_case.name - (merge_objs - (obj3 - (req "kind" (constant op_case.name)) - (req "source" Contract.encoding) - (req "nonce" uint16)) - (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) - (fun op -> - match ires_case.iselect op with - | Some (op, res) -> - Some (((), op.source, op.nonce), (ires_case.proj op.operation, res)) - | None -> None) - (fun (((), source, nonce), (op, res)) -> - let op = {source; operation = ires_case.inj op; nonce} in - Internal_manager_operation_result (op, res)) + match[@coq_grab_existentials] res_case.op_case with + | Operation.Encoding.Manager_operations.MCase op_case -> + case + (Tag op_case.tag) + ~title:op_case.name + (merge_objs + (obj3 + (req "kind" (constant op_case.name)) + (req "source" Contract.encoding) + (req "nonce" uint16)) + (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) + (fun op -> + match ires_case.iselect op with + | Some (op, res) -> + Some + (((), op.source, op.nonce), (ires_case.proj op.operation, res)) + | None -> None) + (fun (((), source, nonce), (op, res)) -> + let op = {source; operation = ires_case.inj op; nonce} in + Internal_manager_operation_result (op, res)) in def "apply_results.alpha.operation_result" @@ union @@ -1117,20 +1117,23 @@ let internal_manager_operation_result_encoding : let successful_manager_operation_result_encoding : packed_successful_manager_operation_result Data_encoding.t = - let make (type kind) - (Manager_result.MCase res_case : kind Manager_result.case) = - let (Operation.Encoding.Manager_operations.MCase op_case) = - res_case.op_case - in - case - (Tag op_case.tag) - ~title:op_case.name - (merge_objs (obj1 (req "kind" (constant op_case.name))) res_case.encoding) - (fun res -> - match res_case.select res with - | Some res -> Some ((), res_case.proj res) - | None -> None) - (fun ((), res) -> Successful_manager_result (res_case.inj res)) + let make (type kind) (mcase : kind Manager_result.case) = + match[@coq_grab_existentials] mcase with + | Manager_result.MCase res_case -> + let (Operation.Encoding.Manager_operations.MCase op_case) = + res_case.op_case + in + case + (Tag op_case.tag) + ~title:op_case.name + (merge_objs + (obj1 (req "kind" (constant op_case.name))) + res_case.encoding) + (fun res -> + match res_case.select res with + | Some res -> Some ((), res_case.proj res) + | None -> None) + (fun ((), res) -> Successful_manager_result (res_case.inj res)) in def "operation.alpha.successful_manager_operation_result" @@ union @@ -1759,8 +1762,9 @@ end let contents_result_encoding = let open Encoding in - let make - (Case + let make case_description = + match[@coq_grab_existentials] case_description with + | Case { op_case = Operation.Encoding.Case {tag; name; _}; encoding; @@ -1768,10 +1772,12 @@ let contents_result_encoding = select; proj; inj; - }) = - let proj x = match select x with None -> None | Some x -> Some (proj x) in - let inj x = Contents_result (inj x) in - tagged_case (Tag tag) name encoding proj inj + } -> + let proj x = + match select x with None -> None | Some x -> Some (proj x) + in + let inj x = Contents_result (inj x) in + tagged_case (Tag tag) name encoding proj inj in def "operation.alpha.contents_result" @@ union @@ -1808,8 +1814,9 @@ let contents_result_encoding = let contents_and_result_encoding = let open Encoding in - let make - (Case + let make case_description = + match[@coq_grab_existentials] case_description with + | Case { op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _}; mselect; @@ -1817,15 +1824,17 @@ let contents_and_result_encoding = proj = meta_proj; inj = meta_inj; _; - }) = - let proj c = - match mselect c with - | Some (op, res) -> Some (proj op, meta_proj res) - | _ -> None - in - let inj (op, res) = Contents_and_result (inj op, meta_inj res) in - let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in - tagged_case (Tag tag) name encoding proj inj + } -> + let proj c = + match mselect c with + | Some (op, res) -> Some (proj op, meta_proj res) + | _ -> None + in + let inj (op, res) = Contents_and_result (inj op, meta_inj res) in + let encoding = + merge_objs encoding (obj1 (req "metadata" meta_encoding)) + in + tagged_case (Tag tag) name encoding proj inj in def "operation.alpha.operation_contents_and_result" @@ union diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index dec9abba76d0d..2493273bde08e 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -1322,13 +1322,16 @@ module Encoding = struct Manager_operations.sc_rollup_publish_case let contents_encoding = - let make (Case {tag; name; encoding; select; proj; inj}) = - case - (Tag tag) - name - encoding - (fun o -> match select o with None -> None | Some o -> Some (proj o)) - (fun x -> Contents (inj x)) + let make case_description = + match[@coq_grab_existentials] case_description with + | Case {tag; name; encoding; select; proj; inj} -> + case + (Tag tag) + name + encoding + (fun o -> + match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Contents (inj x)) in def "operation.alpha.contents" @@ union -- GitLab From f00d5ef1b1c5a99210040a64014bd49d89a57a25 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 5 Nov 2021 16:58:43 +0100 Subject: [PATCH 009/105] Proto: use algebraic types for tokens for Coq --- Makefile | 6 +- src/proto_alpha/lib_plugin/plugin.ml | 4 +- .../lib_protocol/alpha_context.mli | 64 +-- src/proto_alpha/lib_protocol/apply.ml | 74 ++- .../lib_protocol/bootstrap_storage.ml | 11 +- .../lib_protocol/delegate_storage.ml | 46 +- src/proto_alpha/lib_protocol/fees_storage.ml | 4 +- src/proto_alpha/lib_protocol/init_storage.ml | 4 +- .../liquidity_baking_migration.ml | 8 +- .../test/integration/test_frozen_bonds.ml | 85 +++- .../test/integration/test_token.ml | 435 +++++++++++------- src/proto_alpha/lib_protocol/token.ml | 147 +++--- src/proto_alpha/lib_protocol/token.mli | 58 +-- 13 files changed, 578 insertions(+), 368 deletions(-) diff --git a/Makefile b/Makefile index 8cee1b5c8ef4a..ae9ff86d1d6b4 100644 --- a/Makefile +++ b/Makefile @@ -69,9 +69,9 @@ $(TEZOS_BIN): generate_dune cp -f _build/install/default/bin/$@ ./ build: generate_dune -ifneq (${current_ocaml_version},${ocaml_version}) - $(error Unexpected ocaml version (found: ${current_ocaml_version}, expected: ${ocaml_version})) -endif +# ifneq (${current_ocaml_version},${ocaml_version}) +# $(error Unexpected ocaml version (found: ${current_ocaml_version}, expected: ${ocaml_version})) +# endif @dune build --profile=$(PROFILE) $(COVERAGE_OPTIONS) \ $(foreach b, $(TEZOS_BIN), _build/install/default/bin/${b}) \ @copy-parameters diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 941647e72476c..68d0f3388bf20 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -2204,8 +2204,8 @@ module RPC = struct Token.transfer ~origin:Simulation ctxt - `Minted - (`Contract dummy_contract) + (Source_infinite Minted) + (Sink_container (Contract dummy_contract)) balance >>=? fun (ctxt, _) -> return (ctxt, dummy_contract) in diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 6e8cacf9dcddf..b0553d384df45 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -3461,34 +3461,38 @@ end (** See 'token.mli' for more explanation. *) module Token : sig type container = - [ `Contract of Contract.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract.t * Bond_id.t ] + | Contract of Contract.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract.t * Bond_id.t + + type infinite_source = + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards type source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards - | container ] - - type sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Burned - | `Tx_rollup_rejection_punishments - | container ] + | Source_infinite of infinite_source + | Source_container of container + + type infinite_sink = + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Burned + | Tx_rollup_rejection_punishments + + type sink = Sink_infinite of infinite_sink | Sink_container of container val allocated : context -> container -> (context * bool) tzresult Lwt.t @@ -3497,15 +3501,15 @@ module Token : sig val transfer_n : ?origin:Receipt.update_origin -> context -> - ([< source] * Tez.t) list -> - [< sink] -> + (source * Tez.t) list -> + sink -> (context * Receipt.balance_updates) tzresult Lwt.t val transfer : ?origin:Receipt.update_origin -> context -> - [< source] -> - [< sink] -> + source -> + sink -> Tez.t -> (context * Receipt.balance_updates) tzresult Lwt.t end diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index f3ff86ed51f91..8d11a4875e303 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -948,7 +948,11 @@ let apply_transaction ~ctxt ~parameter ~source ~contract ~amount ~entrypoint the next transfer of tokens will allocate it. *) Contract.allocated ctxt contract >|=? not) >>=? fun allocated_destination_contract -> - Token.transfer ctxt (`Contract source) (`Contract contract) amount + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, balance_updates) -> Script_cache.find ctxt contract >>=? fun (ctxt, cache_key, script) -> match script with @@ -1044,8 +1048,8 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~amount Tx_rollup_state.burn_cost ~limit:None state message_size >>?= fun cost -> Token.transfer ctxt - (`Contract (Contract.implicit_contract payer)) - `Burned + (Source_container (Contract (Contract.implicit_contract payer))) + (Sink_infinite Burned) cost >>=? fun (ctxt, balance_updates) -> Tx_rollup_inbox.append_message ctxt dst_rollup state deposit @@ -1101,7 +1105,11 @@ let apply_origination ~ctxt ~storage_type ~storage ~unparsed_code ~contract | None -> return ctxt | Some delegate -> Delegate.init ctxt contract delegate) >>=? fun ctxt -> - Token.transfer ctxt (`Contract source) (`Contract contract) credit + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + credit >>=? fun (ctxt, balance_updates) -> Fees.record_paid_storage_space ctxt contract >|=? fun (ctxt, size, paid_storage_size_diff) -> @@ -1528,7 +1536,11 @@ let apply_external_manager_operation_content : >>=? fun (ctxt, state, paid_storage_size_diff) -> Tx_rollup_state.burn_cost ~limit:burn_limit state message_size >>?= fun cost -> - Token.transfer ctxt (`Contract source_contract) `Burned cost + Token.transfer + ctxt + (Source_container (Contract source_contract)) + (Sink_infinite Burned) + cost >>=? fun (ctxt, balance_updates) -> Tx_rollup_state.update ctxt tx_rollup state >>=? fun ctxt -> let result = @@ -1548,8 +1560,8 @@ let apply_external_manager_operation_content : let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in Token.transfer ctxt - (`Contract source_contract) - (`Frozen_bonds (source_contract, bond_id)) + (Source_container (Contract source_contract)) + (Sink_container (Frozen_bonds (source_contract, bond_id))) (Constants.tx_rollup_commitment_bond ctxt) else return (ctxt, []) ) >>=? fun (ctxt, balance_updates) -> @@ -1584,12 +1596,12 @@ let apply_external_manager_operation_content : | Tx_rollup_return_bond {tx_rollup} -> Tx_rollup_commitment.remove_bond ctxt tx_rollup source >>=? fun ctxt -> let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (source_contract, bond_id)) + Token.balance ctxt (Frozen_bonds (source_contract, bond_id)) >>=? fun (ctxt, bond) -> Token.transfer ctxt - (`Frozen_bonds (source_contract, bond_id)) - (`Contract source_contract) + (Source_container (Frozen_bonds (source_contract, bond_id))) + (Sink_container (Contract source_contract)) bond >>=? fun (ctxt, balance_updates) -> let result = @@ -1705,19 +1717,19 @@ let apply_external_manager_operation_content : (if slashed then let committer = Contract.implicit_contract commitment.committer in let bid = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (committer, bid)) + Token.balance ctxt (Frozen_bonds (committer, bid)) >>=? fun (ctxt, burn) -> Tez.(burn /? 2L) >>?= fun reward -> Token.transfer ctxt - (`Frozen_bonds (committer, bid)) - `Tx_rollup_rejection_punishments + (Source_container (Frozen_bonds (committer, bid))) + (Sink_infinite Tx_rollup_rejection_punishments) burn >>=? fun (ctxt, burn_update) -> Token.transfer ctxt - `Tx_rollup_rejection_rewards - (`Contract source_contract) + (Source_infinite Tx_rollup_rejection_rewards) + (Sink_container (Contract source_contract)) reward >>=? fun (ctxt, reward_update) -> return (ctxt, burn_update @ reward_update) @@ -1969,7 +1981,11 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) assert_sc_rollup_feature_enabled ctxt >|=? fun () -> ctxt) >>=? fun ctxt -> Contract.increment_counter ctxt source >>=? fun ctxt -> - Token.transfer ctxt (`Contract source_contract) `Block_fees fee + Token.transfer + ctxt + (Source_container (Contract source_contract)) + (Sink_container Block_fees) + fee >|=? fun (ctxt, balance_updates) -> let consumed_gas = Gas.consumed ~since:ctxt_before ~until:ctxt in (ctxt, {balance_updates; consumed_gas}) @@ -1987,7 +2003,9 @@ let burn_storage_fees : 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_contract payer) in + let payer = + Token.Source_container (Contract (Contract.implicit_contract payer)) + in match smopr with | Transaction_result (Transaction_to_contract_result payload) -> let consumed = payload.paid_storage_size_diff in @@ -2734,8 +2752,8 @@ let punish_delegate ctxt delegate level mistake mk_result ~payload_producer = | Ok reward -> Token.transfer ctxt - `Double_signing_evidence_rewards - (`Contract (Contract.implicit_contract payload_producer)) + (Source_infinite Double_signing_evidence_rewards) + (Sink_container (Contract (Contract.implicit_contract payload_producer))) reward | Error _ -> (* reward is Tez.zero *) return (ctxt, [])) >|=? fun (ctxt, reward_balance_updates) -> @@ -2948,7 +2966,11 @@ let apply_contents_list (type kind) ctxt chain_id (apply_mode : apply_mode) mode Nonce.reveal ctxt level nonce >>=? fun ctxt -> let tip = Constants.seed_nonce_revelation_tip ctxt in let contract = Contract.implicit_contract payload_producer in - Token.transfer ctxt `Revelation_rewards (`Contract contract) tip + Token.transfer + ctxt + (Source_infinite Revelation_rewards) + (Sink_container (Contract contract)) + tip >|=? fun (ctxt, balance_updates) -> (ctxt, Single_result (Seed_nonce_revelation_result balance_updates)) | Single (Double_preendorsement_evidence {op1; op2}) -> @@ -2973,12 +2995,16 @@ let apply_contents_list (type kind) ctxt chain_id (apply_mode : apply_mode) mode let blinded_pkh = Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in - let src = `Collected_commitments blinded_pkh in + let src = Token.Collected_commitments blinded_pkh in Token.allocated ctxt src >>=? fun (ctxt, src_exists) -> fail_unless src_exists (Invalid_activation {pkh}) >>=? fun () -> let contract = Contract.implicit_contract (Signature.Ed25519 pkh) in Token.balance ctxt src >>=? fun (ctxt, amount) -> - Token.transfer ctxt src (`Contract contract) amount + Token.transfer + ctxt + (Source_container src) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, bupds) -> return (ctxt, Single_result (Activate_account_result bupds)) | Single (Proposals {source; period; proposals}) -> @@ -3108,8 +3134,8 @@ let apply_liquidity_baking_subsidy ctxt ~toggle_vote = Token.transfer ~origin:Subsidy ctxt - `Liquidity_baking_subsidies - (`Contract liquidity_baking_cpmm_contract) + (Source_infinite Liquidity_baking_subsidies) + (Sink_container (Contract liquidity_baking_cpmm_contract)) liquidity_baking_subsidy >>=? fun (ctxt, balance_updates) -> Script_cache.find ctxt liquidity_baking_cpmm_contract diff --git a/src/proto_alpha/lib_protocol/bootstrap_storage.ml b/src/proto_alpha/lib_protocol/bootstrap_storage.ml index 3636d5f1793e7..1ca42e9246dbe 100644 --- a/src/proto_alpha/lib_protocol/bootstrap_storage.ml +++ b/src/proto_alpha/lib_protocol/bootstrap_storage.ml @@ -30,8 +30,8 @@ let init_account (ctxt, balance_updates) Token.transfer ~origin:Protocol_migration ctxt - `Bootstrap - (`Contract contract) + (Source_infinite Bootstrap) + (Sink_container (Contract contract)) amount >>=? fun (ctxt, new_balance_updates) -> (match public_key with @@ -60,7 +60,12 @@ let init_contract ~typecheck (ctxt, balance_updates) | Some delegate -> Delegate_storage.init ctxt contract delegate) >>=? fun ctxt -> let origin = Receipt_repr.Protocol_migration in - Token.transfer ~origin ctxt `Bootstrap (`Contract contract) amount + Token.transfer + ~origin + ctxt + (Source_infinite Bootstrap) + (Sink_container (Contract contract)) + amount >|=? fun (ctxt, new_balance_updates) -> (ctxt, new_balance_updates @ balance_updates) diff --git a/src/proto_alpha/lib_protocol/delegate_storage.ml b/src/proto_alpha/lib_protocol/delegate_storage.ml index 37110cf1f2d2b..366a6d3fd0d36 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_storage.ml @@ -362,8 +362,8 @@ let distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces = (* Sufficient participation: we pay the rewards *) Token.transfer ctxt - `Endorsing_rewards - (`Contract delegate_contract) + (Source_infinite Endorsing_rewards) + (Sink_container (Contract delegate_contract)) rewards >|=? fun (ctxt, payed_rewards_receipts) -> (ctxt, payed_rewards_receipts @ balance_updates) @@ -371,9 +371,10 @@ let distribute_endorsing_rewards ctxt last_cycle unrevealed_nonces = (* Insufficient participation or unrevealed nonce: no rewards *) Token.transfer ctxt - `Endorsing_rewards - (`Lost_endorsing_rewards - (delegate, not sufficient_participation, not has_revealed_nonces)) + (Source_infinite Endorsing_rewards) + (Sink_infinite + (Lost_endorsing_rewards + (delegate, not sufficient_participation, not has_revealed_nonces))) rewards >|=? fun (ctxt, payed_rewards_receipts) -> (ctxt, payed_rewards_receipts @ balance_updates)) @@ -477,8 +478,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Frozen_deposits delegate) - (`Delegate_balance delegate) + (Source_container (Frozen_deposits delegate)) + (Sink_container (Delegate_balance delegate)) to_reimburse >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else if Tez_repr.(current_amount < maximum_stake_to_be_deposited) then @@ -498,8 +499,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Delegate_balance delegate) - (`Frozen_deposits delegate) + (Source_container (Delegate_balance delegate)) + (Sink_container (Frozen_deposits delegate)) to_freeze >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else return (ctxt, balance_updates)) @@ -525,8 +526,8 @@ let freeze_deposits ?(origin = Receipt_repr.Block_application) ctxt ~new_cycle Token.transfer ~origin ctxt - (`Frozen_deposits delegate) - (`Delegate_balance delegate) + (Source_container (Frozen_deposits delegate)) + (Sink_container (Delegate_balance delegate)) frozen_deposits.current_amount >|=? fun (ctxt, bupds) -> (ctxt, bupds @ balance_updates) else return (ctxt, balance_updates)) @@ -832,8 +833,8 @@ let punish_double_endorsing ctxt delegate (level : Level_repr.t) = in Token.transfer ctxt - (`Frozen_deposits delegate) - `Double_signing_punishments + (Source_container (Frozen_deposits delegate)) + (Sink_infinite Double_signing_punishments) amount_to_burn >>=? fun (ctxt, balance_updates) -> Stake_storage.remove_stake ctxt delegate amount_to_burn >>=? fun ctxt -> @@ -863,8 +864,8 @@ let punish_double_baking ctxt delegate (level : Level_repr.t) = in Token.transfer ctxt - (`Frozen_deposits delegate) - `Double_signing_punishments + (Source_container (Frozen_deposits delegate)) + (Sink_infinite Double_signing_punishments) amount_to_burn >>=? fun (ctxt, balance_updates) -> Stake_storage.remove_stake ctxt delegate amount_to_burn >>=? fun ctxt -> @@ -943,15 +944,22 @@ let record_baking_activity_and_pay_rewards_and_fees ctxt ~payload_producer >>=? fun ctxt -> let pay_payload_producer ctxt delegate = let contract = Contract_repr.implicit_contract delegate in - Token.balance ctxt `Block_fees >>=? fun (ctxt, block_fees) -> + Token.balance ctxt Block_fees >>=? fun (ctxt, block_fees) -> Token.transfer_n ctxt - [(`Block_fees, block_fees); (`Baking_rewards, baking_reward)] - (`Contract contract) + [ + (Source_container Block_fees, block_fees); + (Source_infinite Baking_rewards, baking_reward); + ] + (Sink_container (Contract contract)) in let pay_block_producer ctxt delegate bonus = let contract = Contract_repr.implicit_contract delegate in - Token.transfer ctxt `Baking_bonuses (`Contract contract) bonus + Token.transfer + ctxt + (Source_infinite Baking_bonuses) + (Sink_container (Contract contract)) + bonus in pay_payload_producer ctxt payload_producer >>=? fun (ctxt, balance_updates_payload_producer) -> diff --git a/src/proto_alpha/lib_protocol/fees_storage.ml b/src/proto_alpha/lib_protocol/fees_storage.ml index 9a378f8eef8b5..ef02e16d2167a 100644 --- a/src/proto_alpha/lib_protocol/fees_storage.ml +++ b/src/proto_alpha/lib_protocol/fees_storage.ml @@ -78,7 +78,7 @@ let record_paid_storage_space ctxt contract = let source_must_exist c src = match src with - | `Contract src -> Contract_storage.must_exist c src + | Token.Source_container (Contract src) -> Contract_storage.must_exist c src | _ -> return_unit let burn_storage_fees ?(origin = Receipt_repr.Block_application) c @@ -97,7 +97,7 @@ let burn_storage_fees ?(origin = Receipt_repr.Block_application) c trace Cannot_pay_storage_fee ( source_must_exist c payer >>=? fun () -> - Token.transfer ~origin c payer `Storage_fees to_burn + Token.transfer ~origin c payer (Sink_infinite Storage_fees) to_burn >>=? fun (ctxt, balance_updates) -> return (ctxt, remaining, balance_updates) ) diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml index a3b2b2997bb8d..94a16adc2813c 100644 --- a/src/proto_alpha/lib_protocol/init_storage.ml +++ b/src/proto_alpha/lib_protocol/init_storage.ml @@ -116,8 +116,8 @@ let prepare_first_block ctxt ~typecheck ~level ~timestamp = Commitment_repr.{blinded_public_key_hash; amount} = Token.transfer ctxt - `Initial_commitments - (`Collected_commitments blinded_public_key_hash) + (Source_infinite Initial_commitments) + (Sink_container (Collected_commitments blinded_public_key_hash)) amount >>=? fun (ctxt, new_balance_updates) -> return (ctxt, new_balance_updates @ balance_updates) diff --git a/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml b/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml index bdc133bd0134f..68a4d450ec901 100644 --- a/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml +++ b/src/proto_alpha/lib_protocol/liquidity_baking_migration.ml @@ -122,20 +122,20 @@ let originate ctxt address ~balance script = ~origin:Protocol_migration ctxt ~storage_limit:(Z.of_int64 Int64.max_int) - ~payer:`Liquidity_baking_subsidies + ~payer:(Source_infinite Liquidity_baking_subsidies) >>=? fun (ctxt, _, origination_updates) -> Fees_storage.burn_storage_fees ~origin:Protocol_migration ctxt ~storage_limit:(Z.of_int64 Int64.max_int) - ~payer:`Liquidity_baking_subsidies + ~payer:(Source_infinite Liquidity_baking_subsidies) size >>=? fun (ctxt, _, storage_updates) -> Token.transfer ~origin:Protocol_migration ctxt - `Liquidity_baking_subsidies - (`Contract address) + (Source_infinite Liquidity_baking_subsidies) + (Sink_container (Contract address)) balance >>=? fun (ctxt, transfer_updates) -> let balance_updates = diff --git a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml index 7878b58fd5e48..cfb83fb34d5f5 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml @@ -76,19 +76,26 @@ let init_test ~user_is_delegate = create_context () >>=? fun (ctxt, _) -> let (delegate, delegate_pk, _) = Signature.generate_key () in let delegate_contract = Contract.implicit_contract delegate in - let delegate_account = `Contract (Contract.implicit_contract delegate) in + let delegate_account = + Token.Sink_container (Contract (Contract.implicit_contract delegate)) + in let user_contract = if user_is_delegate then delegate_contract else let (user, _, _) = Signature.generate_key () in Contract.implicit_contract user in - let user_account = `Contract user_contract in + let user_account = Token.Contract user_contract in (* Allocate contracts for user and delegate. *) let user_balance = big_random_amount () in - Token.transfer ctxt `Minted user_account user_balance >>>=? fun (ctxt, _) -> + Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container user_account) + user_balance + >>>=? fun (ctxt, _) -> let delegate_balance = big_random_amount () in - Token.transfer ctxt `Minted delegate_account delegate_balance + Token.transfer ctxt (Source_infinite Minted) delegate_account delegate_balance >>>=? fun (ctxt, _) -> (* Configure delegate, as a delegate by self-delegation, for which revealing its manager key is a prerequisite. *) @@ -118,8 +125,12 @@ let test_delegate_then_freeze_deposit () = let (tx_rollup, _) = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount + let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after freeze. *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance' -> @@ -136,7 +147,11 @@ let test_delegate_then_freeze_deposit () = (staking_balance' -! user_balance) >>=? fun () -> (* Unfreeze the deposit. *) - Token.transfer ctxt deposit_account user_account deposit_amount + Token.transfer + ctxt + (Source_container deposit_account) + (Sink_container user_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance of delegate. *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance''' -> @@ -166,8 +181,12 @@ let test_freeze_deposit_then_delegate () = let (tx_rollup, _) = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount + let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Here, user balance has decreased. Now, fetch staking balance before delegation and after freeze. *) @@ -183,7 +202,11 @@ let test_freeze_deposit_then_delegate () = (user_balance +! staking_balance) >>=? fun () -> (* Unfreeze the deposit. *) - Token.transfer ctxt deposit_account user_account deposit_amount + Token.transfer + ctxt + (Source_container deposit_account) + (Sink_container user_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after unfreeze. *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance'' -> @@ -220,8 +243,12 @@ let test_allocated_when_frozen_deposits_exists ~user_is_delegate () = let (tx_rollup, _) = mk_tx_rollup () in let bond_id = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = user_balance in - let deposit_account = `Frozen_bonds (user_contract, bond_id) in - Token.transfer ctxt user_account deposit_account deposit_amount + let deposit_account = Token.Frozen_bonds (user_contract, bond_id) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that user contract is still allocated, despite a null balance. *) Token.balance ctxt user_account >>>=? fun (ctxt, balance) -> @@ -231,7 +258,11 @@ let test_allocated_when_frozen_deposits_exists ~user_is_delegate () = Assert.equal_bool ~loc:__LOC__ (user_allocated && dep_allocated) true >>=? fun () -> (* Punish the user contract. *) - Token.transfer ctxt deposit_account `Burned deposit_amount + Token.transfer + ctxt + (Source_container deposit_account) + (Sink_infinite Burned) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that user and deposit accounts have been unallocated. *) Token.allocated ctxt user_account >>>=? fun (ctxt, user_allocated) -> @@ -259,11 +290,19 @@ let test_total_stake ~user_is_delegate () = let (tx_rollup, _) = mk_tx_rollup ~nonce () in let bond_id2 = Bond_id.Tx_rollup_bond_id tx_rollup in let deposit_amount = small_random_amount () in - let deposit_account1 = `Frozen_bonds (user_contract, bond_id1) in - Token.transfer ctxt user_account deposit_account1 deposit_amount + let deposit_account1 = Token.Frozen_bonds (user_contract, bond_id1) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account1) + deposit_amount >>>=? fun (ctxt, _) -> - let deposit_account2 = `Frozen_bonds (user_contract, bond_id2) in - Token.transfer ctxt user_account deposit_account2 deposit_amount + let deposit_account2 = Token.Frozen_bonds (user_contract, bond_id2) in + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account2) + deposit_amount >>>=? fun (ctxt, _) -> (* Test folding on bond ids. *) Bond_id.Internal_for_tests.fold_on_bond_ids @@ -289,7 +328,11 @@ let test_total_stake ~user_is_delegate () = Assert.equal_tez ~loc:__LOC__ (stake -! balance) (deposit_amount *! 2L) >>=? fun () -> (* Punish for one deposit. *) - Token.transfer ctxt deposit_account2 `Burned deposit_amount + Token.transfer + ctxt + (Source_container deposit_account2) + (Sink_infinite Burned) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that stake of contract is balance + deposit. *) Contract.get_balance_and_frozen_bonds ctxt user_contract >>>=? fun stake -> @@ -297,7 +340,11 @@ let test_total_stake ~user_is_delegate () = Assert.equal_tez ~loc:__LOC__ (stake -! balance) frozen_bonds >>=? fun () -> Assert.equal_tez ~loc:__LOC__ (stake -! balance) deposit_amount >>=? fun () -> (* Punish for the other deposit. *) - Token.transfer ctxt deposit_account1 `Burned deposit_amount + Token.transfer + ctxt + (Source_container deposit_account1) + (Sink_infinite Burned) + deposit_amount >>>=? fun (ctxt, _) -> (* Check that stake of contract is equal to balance. *) Contract.get_balance_and_frozen_bonds ctxt user_contract >>>=? fun stake -> diff --git a/src/proto_alpha/lib_protocol/test/integration/test_token.ml b/src/proto_alpha/lib_protocol/test/integration/test_token.ml index 7b4294e4fccff..71880469632fe 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_token.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_token.ml @@ -60,11 +60,12 @@ let mk_rollup () = Tx_rollup.Internal_for_tests.originated_tx_rollup nonce let test_simple_balances () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - let src = `Contract (Contract.implicit_contract pkh) in + let src = Token.Contract (Contract.implicit_contract pkh) in let (pkh, _pk, _sk) = Signature.generate_key () in - let dest = `Contract (Contract.implicit_contract pkh) in + let dest = Token.Contract (Contract.implicit_contract pkh) in let amount = Tez.one in - wrap (Token.transfer ctxt src dest amount) >>=? fun (ctxt', _) -> + wrap (Token.transfer ctxt (Source_container src) (Sink_container dest) amount) + >>=? fun (ctxt', _) -> wrap (Token.balance ctxt src) >>=? fun (ctxt, bal_src) -> wrap (Token.balance ctxt' src) >>=? fun (ctxt', bal_src') -> wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) -> @@ -83,7 +84,12 @@ let test_simple_balance_updates () = let (pkh, _pk, _sk) = Signature.generate_key () in let dest = Contract.implicit_contract pkh in let amount = Tez.one in - wrap (Token.transfer ctxt (`Contract src) (`Contract dest) amount) + wrap + (Token.transfer + ctxt + (Source_container (Contract src)) + (Sink_container (Contract dest)) + amount) >>=? fun (_, bal_updates) -> Alcotest.( check @@ -109,11 +115,19 @@ let test_allocated_and_deallocated ctxt dest initial_status status_when_empty = wrap (Token.allocated ctxt dest) >>=? fun (ctxt, allocated) -> Assert.equal_bool ~loc:__LOC__ allocated initial_status >>=? fun () -> let amount = Tez.one in - wrap (Token.transfer ctxt `Minted dest amount) >>=? fun (ctxt', _) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container dest) amount) + >>=? fun (ctxt', _) -> wrap (Token.allocated ctxt' dest) >>=? fun (ctxt', allocated) -> Assert.equal_bool ~loc:__LOC__ allocated true >>=? fun () -> wrap (Token.balance ctxt' dest) >>=? fun (ctxt', bal_dest') -> - wrap (Token.transfer ctxt' dest `Burned bal_dest') >>=? fun (ctxt', _) -> + wrap + (Token.transfer + ctxt' + (Source_container dest) + (Sink_infinite Burned) + bal_dest') + >>=? fun (ctxt', _) -> wrap (Token.allocated ctxt' dest) >>=? fun (_, allocated) -> Assert.equal_bool ~loc:__LOC__ allocated status_when_empty >>=? fun () -> return_unit @@ -127,20 +141,20 @@ let test_allocated_and_still_allocated_when_empty ctxt dest initial_status = let test_allocated () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - let dest = `Delegate_balance pkh in + let dest = Token.Delegate_balance pkh in test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ -> let (pkh, _pk, _sk) = Signature.generate_key () in - let dest = `Contract (Contract.implicit_contract pkh) in + let dest = Token.Contract (Contract.implicit_contract pkh) in test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ -> - let dest = `Collected_commitments Blinded_public_key_hash.zero in + let dest = Token.Collected_commitments Blinded_public_key_hash.zero in test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ -> - let dest = `Frozen_deposits pkh in + let dest = Token.Frozen_deposits pkh in test_allocated_and_still_allocated_when_empty ctxt dest false >>=? fun _ -> - let dest = `Block_fees in + let dest = Token.Block_fees in test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ -> let dest = let bond_id = Bond_id.Tx_rollup_bond_id (mk_rollup ()) in - `Frozen_bonds (Contract.implicit_contract pkh, bond_id) + Token.Frozen_bonds (Contract.implicit_contract pkh, bond_id) in test_allocated_and_deallocated_when_empty ctxt dest @@ -155,20 +169,31 @@ let check_sink_balances ctxt ctxt' dest amount = (`Contract pkh) instead. *) let force_allocation_if_need_be ctxt account = match account with - | `Delegate_balance pkh -> - let account = `Contract (Contract.implicit_contract pkh) in - wrap (Token.transfer ctxt `Minted account Tez.one_mutez) >|=? fst + | Token.Delegate_balance pkh -> + let account = + Token.Sink_container (Contract (Contract.implicit_contract pkh)) + in + wrap (Token.transfer ctxt (Source_infinite Minted) account Tez.one_mutez) + >|=? fst | _ -> return ctxt let test_transferring_to_sink ctxt sink amount expected_bupds = (* Transferring zero must be a noop, and must not return balance updates. *) - wrap (Token.transfer ctxt `Minted sink Tez.zero) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container sink) + Tez.zero) + >>=? fun (ctxt', bupds) -> Assert.equal_bool ~loc:__LOC__ (ctxt == ctxt' && bupds = []) true >>=? fun _ -> (* Force the allocation of [dest] if need be. *) force_allocation_if_need_be ctxt sink >>=? fun ctxt -> (* Test transferring a non null amount. *) - wrap (Token.transfer ctxt `Minted sink amount) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container sink) amount) + >>=? fun (ctxt', bupds) -> check_sink_balances ctxt ctxt' sink amount >>=? fun _ -> let expected_bupds = Receipt.(Minted, Debited amount, Block_application) :: expected_bupds @@ -178,7 +203,9 @@ let test_transferring_to_sink ctxt sink amount expected_bupds = (* Test transferring to go beyond capacity. *) wrap (Token.balance ctxt' sink) >>=? fun (ctxt', bal) -> let amount = Tez.of_mutez_exn Int64.max_int -! bal +! Tez.one_mutez in - wrap (Token.transfer ctxt' `Minted sink amount) >>= fun res -> + wrap + (Token.transfer ctxt' (Source_infinite Minted) (Sink_container sink) amount) + >>= fun res -> Assert.proto_error_with_info ~loc:__LOC__ res "Overflowing tez addition" let test_transferring_to_contract ctxt = @@ -187,7 +214,7 @@ let test_transferring_to_contract ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Contract dest) + (Contract dest) amount [(Contract dest, Credited amount, Block_application)] @@ -196,7 +223,7 @@ let test_transferring_to_collected_commitments ctxt = let bpkh = Blinded_public_key_hash.zero in test_transferring_to_sink ctxt - (`Collected_commitments bpkh) + (Collected_commitments bpkh) amount [(Commitments bpkh, Credited amount, Block_application)] @@ -206,7 +233,7 @@ let test_transferring_to_delegate_balance ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Delegate_balance pkh) + (Delegate_balance pkh) amount [(Contract dest, Credited amount, Block_application)] @@ -215,7 +242,7 @@ let test_transferring_to_frozen_deposits ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Frozen_deposits pkh) + (Frozen_deposits pkh) amount [(Deposits pkh, Credited amount, Block_application)] @@ -223,26 +250,39 @@ let test_transferring_to_collected_fees ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - `Block_fees + Block_fees amount [(Block_fees, Credited amount, Block_application)] let test_transferring_to_burned ctxt = let amount = random_amount () in let minted_bupd = Receipt.(Minted, Debited amount, Block_application) in - wrap (Token.transfer ctxt `Minted `Burned amount) >>=? fun (_, bupds) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_infinite Burned) amount) + >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ (bupds = [minted_bupd; (Burned, Credited amount, Block_application)]) true >>=? fun () -> - wrap (Token.transfer ctxt `Minted `Storage_fees amount) >>=? fun (_, bupds) -> + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_infinite Storage_fees) + amount) + >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ (bupds = [minted_bupd; (Storage_fees, Credited amount, Block_application)]) true >>=? fun () -> - wrap (Token.transfer ctxt `Minted `Double_signing_punishments amount) + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_infinite Double_signing_punishments) + amount) >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ @@ -256,7 +296,11 @@ let test_transferring_to_burned ctxt = let pkh = Signature.Public_key_hash.zero in let (p, r) = (Random.bool (), Random.bool ()) in wrap - (Token.transfer ctxt `Minted (`Lost_endorsing_rewards (pkh, p, r)) amount) + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_infinite (Lost_endorsing_rewards (pkh, p, r))) + amount) >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ @@ -275,7 +319,7 @@ let test_transferring_to_frozen_bonds ctxt = let amount = random_amount () in test_transferring_to_sink ctxt - (`Frozen_bonds (contract, bond_id)) + (Frozen_bonds (contract, bond_id)) amount [(Frozen_bonds (contract, bond_id), Credited amount, Block_application)] @@ -298,11 +342,13 @@ let check_src_balances ctxt ctxt' src amount = let test_transferring_from_unbounded_source ctxt src expected_bupds = (* Transferring zero must not return balance updates. *) - wrap (Token.transfer ctxt src `Burned Tez.zero) >>=? fun (_, bupds) -> + wrap (Token.transfer ctxt src (Sink_infinite Burned) Tez.zero) + >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ (bupds = []) true >>=? fun () -> (* Test transferring a non null amount. *) let amount = random_amount () in - wrap (Token.transfer ctxt src `Burned amount) >>=? fun (_, bupds) -> + wrap (Token.transfer ctxt src (Sink_infinite Burned) amount) + >>=? fun (_, bupds) -> let expected_bupds = expected_bupds amount @ Receipt.[(Burned, Credited amount, Block_application)] @@ -321,48 +367,76 @@ let test_transferring_from_bounded_source ctxt src amount expected_bupds = balance_no_fail ctxt src >>=? fun (ctxt, balance) -> Assert.equal_tez ~loc:__LOC__ balance Tez.zero >>=? fun () -> (* Test transferring from an empty account. *) - wrap (Token.transfer ctxt src `Burned Tez.one) >>= fun res -> + wrap + (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) Tez.one) + >>= fun res -> let error_title = match src with - | `Contract _ -> "Balance too low" - | `Delegate_balance _ | `Frozen_deposits _ | `Frozen_bonds _ -> + | Contract _ -> "Balance too low" + | Delegate_balance _ | Frozen_deposits _ | Frozen_bonds _ -> "Storage error (fatal internal error)" | _ -> "Underflowing tez subtraction" in Assert.proto_error_with_info ~loc:__LOC__ res error_title >>=? fun () -> (* Transferring zero must be a noop, and must not return balance updates. *) - wrap (Token.transfer ctxt src `Burned Tez.zero) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) Tez.zero) + >>=? fun (ctxt', bupds) -> Assert.equal_bool ~loc:__LOC__ (ctxt == ctxt' && bupds = []) true >>=? fun _ -> (* Force the allocation of [dest] if need be. *) force_allocation_if_need_be ctxt src >>=? fun ctxt -> (* Test transferring everything. *) - wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt src `Burned amount) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container src) amount) + >>=? fun (ctxt, _) -> + wrap + (Token.transfer ctxt (Source_container src) (Sink_infinite Burned) amount) + >>=? fun (ctxt', bupds) -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> let expected_bupds = expected_bupds @ Receipt.[(Burned, Credited amount, Block_application)] in Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true >>=? fun () -> (* Test transferring a smaller amount. *) - wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) -> + wrap + (Token.transfer ctxt (Source_infinite Minted) (Sink_container src) amount) + >>=? fun (ctxt, _) -> (match src with - | `Frozen_bonds _ -> - wrap (Token.transfer ctxt src `Burned amount) >>= fun res -> + | Frozen_bonds _ -> + wrap + (Token.transfer + ctxt + (Source_container src) + (Sink_infinite Burned) + amount) + >>= fun res -> let error_title = "Partial spending of frozen bonds" in Assert.proto_error_with_info ~loc:__LOC__ res error_title | _ -> - wrap (Token.transfer ctxt src `Burned amount) >>=? fun (ctxt', bupds) -> + wrap + (Token.transfer + ctxt + (Source_container src) + (Sink_infinite Burned) + amount) + >>=? fun (ctxt', bupds) -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> Assert.equal_bool ~loc:__LOC__ (bupds = expected_bupds) true) >>=? fun () -> (* Test transferring more than available. *) wrap (Token.balance ctxt src) >>=? fun (ctxt, balance) -> - wrap (Token.transfer ctxt src `Burned (balance +! Tez.one)) >>= fun res -> + wrap + (Token.transfer + ctxt + (Source_container src) + (Sink_infinite Burned) + (balance +! Tez.one)) + >>= fun res -> let error_title = match src with - | `Contract _ -> "Balance too low" - | `Frozen_bonds _ -> "Partial spending of frozen bonds" + | Contract _ -> "Balance too low" + | Frozen_bonds _ -> "Partial spending of frozen bonds" | _ -> "Underflowing tez subtraction" in Assert.proto_error_with_info ~loc:__LOC__ res error_title @@ -373,7 +447,7 @@ let test_transferring_from_contract ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - (`Contract src) + (Contract src) amount [(Contract src, Debited amount, Block_application)] @@ -382,7 +456,7 @@ let test_transferring_from_collected_commitments ctxt = let bpkh = Blinded_public_key_hash.zero in test_transferring_from_bounded_source ctxt - (`Collected_commitments bpkh) + (Collected_commitments bpkh) amount [(Commitments bpkh, Debited amount, Block_application)] @@ -392,7 +466,7 @@ let test_transferring_from_delegate_balance ctxt = let src = Contract.implicit_contract pkh in test_transferring_from_bounded_source ctxt - (`Delegate_balance pkh) + (Delegate_balance pkh) amount [(Contract src, Debited amount, Block_application)] @@ -401,7 +475,7 @@ let test_transferring_from_frozen_deposits ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - (`Frozen_deposits pkh) + (Frozen_deposits pkh) amount [(Deposits pkh, Debited amount, Block_application)] @@ -409,7 +483,7 @@ let test_transferring_from_collected_fees ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - `Block_fees + Block_fees amount [(Block_fees, Debited amount, Block_application)] @@ -421,46 +495,62 @@ let test_transferring_from_frozen_bonds ctxt = let amount = random_amount () in test_transferring_from_bounded_source ctxt - (`Frozen_bonds (contract, bond_id)) + (Frozen_bonds (contract, bond_id)) amount [(Frozen_bonds (contract, bond_id), Debited amount, Block_application)] let test_transferring_from_source () = Random.init 0 ; create_context () >>=? fun (ctxt, _) -> - test_transferring_from_unbounded_source ctxt `Invoice (fun am -> - [(Invoice, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Invoice) + (fun am -> [(Invoice, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Bootstrap (fun am -> - [(Bootstrap, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Bootstrap) + (fun am -> [(Bootstrap, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Initial_commitments (fun am -> - [(Initial_commitments, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Initial_commitments) + (fun am -> [(Initial_commitments, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Revelation_rewards (fun am -> - [(Nonce_revelation_rewards, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Revelation_rewards) + (fun am -> [(Nonce_revelation_rewards, Debited am, Block_application)]) >>=? fun _ -> test_transferring_from_unbounded_source ctxt - `Double_signing_evidence_rewards + (Source_infinite Double_signing_evidence_rewards) (fun am -> [(Double_signing_evidence_rewards, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Endorsing_rewards (fun am -> - [(Endorsing_rewards, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Endorsing_rewards) + (fun am -> [(Endorsing_rewards, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Baking_rewards (fun am -> - [(Baking_rewards, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Baking_rewards) + (fun am -> [(Baking_rewards, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Baking_bonuses (fun am -> - [(Baking_bonuses, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Baking_bonuses) + (fun am -> [(Baking_bonuses, Debited am, Block_application)]) >>=? fun _ -> - test_transferring_from_unbounded_source ctxt `Minted (fun am -> - [(Minted, Debited am, Block_application)]) + test_transferring_from_unbounded_source + ctxt + (Source_infinite Minted) + (fun am -> [(Minted, Debited am, Block_application)]) >>=? fun _ -> test_transferring_from_unbounded_source ctxt - `Liquidity_baking_subsidies + (Source_infinite Liquidity_baking_subsidies) (fun am -> [(Liquidity_baking_subsidies, Debited am, Block_application)]) >>=? fun _ -> test_transferring_from_contract ctxt >>=? fun _ -> @@ -484,23 +574,25 @@ let cast_to_container_type x = (** Generates all combinations of constructors. *) let build_test_cases () = create_context () >>=? fun (ctxt, pkh) -> - let origin = `Contract (Contract.implicit_contract pkh) in + let origin = + Token.Source_container (Contract (Contract.implicit_contract pkh)) + in let (user1, _, _) = Signature.generate_key () in - let user1c = `Contract (Contract.implicit_contract user1) in + let user1c = Token.Contract (Contract.implicit_contract user1) in let (user2, _, _) = Signature.generate_key () in - let user2c = `Contract (Contract.implicit_contract user2) in + let user2c = Token.Contract (Contract.implicit_contract user2) in let (baker1, baker1_pk, _) = Signature.generate_key () in - let baker1c = `Contract (Contract.implicit_contract baker1) in + let baker1c = Token.Contract (Contract.implicit_contract baker1) in let (baker2, baker2_pk, _) = Signature.generate_key () in - let baker2c = `Contract (Contract.implicit_contract baker2) in + let baker2c = Token.Contract (Contract.implicit_contract baker2) in (* Allocate contracts for user1, user2, baker1, and baker2. *) - wrap (Token.transfer ctxt origin user1c (random_amount ())) + wrap (Token.transfer ctxt origin (Sink_container user1c) (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user2c (random_amount ())) + wrap (Token.transfer ctxt origin (Sink_container user2c) (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin baker1c (random_amount ())) + wrap (Token.transfer ctxt origin (Sink_container baker1c) (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin baker2c (random_amount ())) + wrap (Token.transfer ctxt origin (Sink_container baker2c) (random_amount ())) >>=? fun (ctxt, _) -> (* Configure baker1, and baker2 as delegates by self-delegation, for which revealing their manager key is a prerequisite. *) @@ -521,82 +613,90 @@ let build_test_cases () = let baker2ic = Contract.implicit_contract baker2 in let src_list = [ - (`Invoice, random_amount ()); - (`Bootstrap, random_amount ()); - (`Initial_commitments, random_amount ()); - (`Minted, random_amount ()); - (`Liquidity_baking_subsidies, random_amount ()); - (`Collected_commitments Blinded_public_key_hash.zero, random_amount ()); - (`Delegate_balance baker1, random_amount ()); - (`Delegate_balance baker2, random_amount ()); - (`Block_fees, random_amount ()); - (user1c, random_amount ()); - (user2c, random_amount ()); - (baker1c, random_amount ()); - (baker2c, random_amount ()); - (`Frozen_bonds (user1ic, bond_id1), random_amount ()); - (`Frozen_bonds (baker2ic, bond_id2), random_amount ()); + (Token.Source_infinite Invoice, random_amount ()); + (Source_infinite Bootstrap, random_amount ()); + (Source_infinite Initial_commitments, random_amount ()); + (Source_infinite Minted, random_amount ()); + (Source_infinite Liquidity_baking_subsidies, random_amount ()); + ( Source_container (Collected_commitments Blinded_public_key_hash.zero), + random_amount () ); + (Source_container (Delegate_balance baker1), random_amount ()); + (Source_container (Delegate_balance baker2), random_amount ()); + (Source_container Block_fees, random_amount ()); + (Source_container user1c, random_amount ()); + (Source_container user2c, random_amount ()); + (Source_container baker1c, random_amount ()); + (Source_container baker2c, random_amount ()); + (Source_container (Frozen_bonds (user1ic, bond_id1)), random_amount ()); + (Source_container (Frozen_bonds (baker2ic, bond_id2)), random_amount ()); ] in let dest_list = [ - `Collected_commitments Blinded_public_key_hash.zero; - `Delegate_balance baker1; - `Delegate_balance baker2; - `Block_fees; - user1c; - user2c; - baker1c; - baker2c; - `Frozen_bonds (user1ic, bond_id1); - `Frozen_bonds (baker2ic, bond_id2); - `Burned; + Token.Sink_container (Collected_commitments Blinded_public_key_hash.zero); + Sink_container (Delegate_balance baker1); + Sink_container (Delegate_balance baker2); + Sink_container Block_fees; + Sink_container user1c; + Sink_container user2c; + Sink_container baker1c; + Sink_container baker2c; + Sink_container (Frozen_bonds (user1ic, bond_id1)); + Sink_container (Frozen_bonds (baker2ic, bond_id2)); + Sink_infinite Burned; ] in return (ctxt, List.product src_list dest_list) -let check_src_balances ctxt ctxt' src amount = - match cast_to_container_type src with - | None -> return_unit - | Some src -> check_src_balances ctxt ctxt' src amount - -let check_sink_balances ctxt ctxt' dest amount = - match cast_to_container_type dest with - | None -> return_unit - | Some dest -> check_sink_balances ctxt ctxt' dest amount - let rec check_balances ctxt ctxt' src dest amount = - match (cast_to_container_type src, cast_to_container_type dest) with - | (None, None) -> return_unit - | (Some (`Delegate_balance d), Some (`Contract c as contract)) + match (src, dest) with + | ( Token.Source_container (Delegate_balance d), + Token.Sink_container (Contract c as contract) ) when Contract.implicit_contract d = c -> (* src and dest are in fact referring to the same contract *) - check_balances ctxt ctxt' contract contract amount - | (Some (`Contract c as contract), Some (`Delegate_balance d)) + check_balances + ctxt + ctxt' + (Source_container contract) + (Sink_container contract) + amount + | ( Source_container (Contract c as contract), + Sink_container (Delegate_balance d) ) when Contract.implicit_contract d = c -> (* src and dest are in fact referring to the same contract *) - check_balances ctxt ctxt' contract contract amount - | (Some src, Some dest) when src = dest -> + check_balances + ctxt + ctxt' + (Source_container contract) + (Sink_container contract) + amount + | (Source_container src, Sink_container dest) when src = dest -> (* src and dest are the same contract *) wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) -> wrap (Token.balance ctxt' dest) >>=? fun (_, bal_dest') -> Assert.equal_tez ~loc:__LOC__ bal_dest bal_dest' - | (Some src, None) -> check_src_balances ctxt ctxt' src amount - | (None, Some dest) -> check_sink_balances ctxt ctxt' dest amount - | (Some src, Some dest) -> + | (Source_container src, Sink_container dest) -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> check_sink_balances ctxt ctxt' dest amount + | (Source_container src, _) -> check_src_balances ctxt ctxt' src amount + | (_, Sink_container dest) -> check_sink_balances ctxt ctxt' dest amount + | (_, _) -> return_unit let test_all_combinations_of_sources_and_sinks () = Random.init 0 ; build_test_cases () >>=? fun (ctxt, cases) -> List.iter_es (fun ((src, amount), dest) -> - (match cast_to_container_type src with - | None -> return ctxt - | Some src -> - wrap (Token.transfer ctxt `Minted src amount) >>=? fun (ctxt, _) -> - return ctxt) + (match src with + | Token.Source_container src -> + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container src) + amount) + >>=? fun (ctxt, _) -> return ctxt + | _ -> return ctxt) >>=? fun ctxt -> wrap (Token.transfer ctxt src dest amount) >>=? fun (ctxt', _) -> check_balances ctxt ctxt' src dest amount) @@ -631,15 +731,20 @@ let coalesce_balance_updates bu1 bu2 = (** Check that elt has the same balance in ctxt1 and ctxt2. *) let check_balances_are_consistent ctxt1 ctxt2 elt = - match elt with - | #Token.container as elt -> - Token.balance ctxt1 elt >>=? fun (_, elt_bal1) -> - Token.balance ctxt2 elt >>=? fun (_, elt_bal2) -> - assert (elt_bal1 = elt_bal2) ; - return_unit - | `Invoice | `Bootstrap | `Initial_commitments | `Minted - | `Liquidity_baking_subsidies | `Burned -> - return_unit + Token.balance ctxt1 elt >>=? fun (_, elt_bal1) -> + Token.balance ctxt2 elt >>=? fun (_, elt_bal2) -> + assert (elt_bal1 = elt_bal2) ; + return_unit + +let check_balances_are_consistent_source ctxt1 ctxt2 src = + match src with + | Token.Source_container elt -> check_balances_are_consistent ctxt1 ctxt2 elt + | _ -> return_unit + +let check_balances_are_consistent_dest ctxt1 ctxt2 dest = + match dest with + | Token.Sink_container elt -> check_balances_are_consistent ctxt1 ctxt2 elt + | _ -> return_unit (** Test that [transfer_n] is equivalent to n debits followed by n credits. *) let test_transfer_n ctxt src dest = @@ -648,29 +753,29 @@ let test_transfer_n ctxt src dest = (* Debit all sources. *) List.fold_left_es (fun (ctxt, bal_updates) (src, am) -> - Token.transfer ctxt src `Burned am >>=? fun (ctxt, debit_logs) -> - return (ctxt, bal_updates @ debit_logs)) + Token.transfer ctxt src (Sink_infinite Burned) am + >>=? fun (ctxt, debit_logs) -> return (ctxt, bal_updates @ debit_logs)) (ctxt, []) src >>=? fun (ctxt, debit_logs) -> (* remove burning balance updates *) let debit_logs = List.filter - (fun b -> match b with (Receipt.Burned, _, _) -> false | _ -> true) + (fun b -> match b with (Receipt.(Burned), _, _) -> false | _ -> true) debit_logs in (* Credit the sink for each source. *) List.fold_left_es (fun (ctxt, bal_updates) (_, am) -> - Token.transfer ctxt `Minted dest am >>=? fun (ctxt, credit_logs) -> - return (ctxt, bal_updates @ credit_logs)) + Token.transfer ctxt (Source_infinite Minted) dest am + >>=? fun (ctxt, credit_logs) -> return (ctxt, bal_updates @ credit_logs)) (ctxt, []) src >>=? fun (ctxt2, credit_logs) -> (* remove minting balance updates *) let credit_logs = List.filter - (fun b -> match b with (Receipt.Minted, _, _) -> false | _ -> true) + (fun b -> match b with (Receipt.(Minted), _, _) -> false | _ -> true) credit_logs in (* Check equivalence of balance updates. *) @@ -681,46 +786,56 @@ let test_transfer_n ctxt src dest = in assert (bal_updates1 = debit_logs @ credit_logs) ; (* Check balances are the same in ctxt1 and ctxt2. *) - List.(iter_es (check_balances_are_consistent ctxt1 ctxt2) (map fst src)) - >>=? fun _ -> check_balances_are_consistent ctxt1 ctxt2 dest + List.( + iter_es (check_balances_are_consistent_source ctxt1 ctxt2) (map fst src)) + >>=? fun _ -> check_balances_are_consistent_dest ctxt1 ctxt2 dest let test_transfer_n_with_empty_source () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - wrap (test_transfer_n ctxt [] `Block_fees) >>=? fun _ -> - let dest = `Delegate_balance pkh in + wrap (test_transfer_n ctxt [] (Sink_container Block_fees)) >>=? fun _ -> + let dest = Token.Sink_container (Delegate_balance pkh) in wrap (test_transfer_n ctxt [] dest) let test_transfer_n_with_non_empty_source () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - let origin = `Contract (Contract.implicit_contract pkh) in + let origin = + Token.Source_container (Contract (Contract.implicit_contract pkh)) + in let (user1, _, _) = Signature.generate_key () in - let user1c = `Contract (Contract.implicit_contract user1) in + let user1c = Token.Contract (Contract.implicit_contract user1) in let (user2, _, _) = Signature.generate_key () in - let user2c = `Contract (Contract.implicit_contract user2) in + let user2c = Token.Contract (Contract.implicit_contract user2) in let (user3, _, _) = Signature.generate_key () in - let user3c = `Contract (Contract.implicit_contract user3) in + let user3c = Token.Contract (Contract.implicit_contract user3) in let (user4, _, _) = Signature.generate_key () in - let user4c = `Contract (Contract.implicit_contract user4) in + let user4c = Token.Contract (Contract.implicit_contract user4) in (* Allocate contracts for user1, user2, user3, and user4. *) let amount = match Tez.of_mutez 1000L with None -> assert false | Some x -> x in - wrap (Token.transfer ctxt origin user1c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user2c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user3c amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin user4c (random_amount ())) + wrap (Token.transfer ctxt origin (Sink_container user1c) amount) + >>=? fun (ctxt, _) -> + wrap (Token.transfer ctxt origin (Sink_container user2c) amount) + >>=? fun (ctxt, _) -> + wrap (Token.transfer ctxt origin (Sink_container user3c) amount) + >>=? fun (ctxt, _) -> + wrap (Token.transfer ctxt origin (Sink_container user4c) (random_amount ())) >>=? fun (ctxt, _) -> let sources = [ - (user2c, random_amount ()); - (user3c, random_amount ()); - (user4c, random_amount ()); + (Token.Source_container user2c, random_amount ()); + (Source_container user3c, random_amount ()); + (Source_container user4c, random_amount ()); ] in - wrap (test_transfer_n ctxt sources user1c) >>=? fun _ -> - wrap (test_transfer_n ctxt ((user1c, random_amount ()) :: sources) user1c) + wrap (test_transfer_n ctxt sources (Sink_container user1c)) >>=? fun _ -> + wrap + (test_transfer_n + ctxt + ((Source_container user1c, random_amount ()) :: sources) + (Sink_container user1c)) let tests = Tztest. diff --git a/src/proto_alpha/lib_protocol/token.ml b/src/proto_alpha/lib_protocol/token.ml index 67f1083a0039d..a25df17641010 100644 --- a/src/proto_alpha/lib_protocol/token.ml +++ b/src/proto_alpha/lib_protocol/token.ml @@ -24,70 +24,72 @@ (*****************************************************************************) type container = - [ `Contract of Contract_repr.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ] + | Contract of Contract_repr.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract_repr.t * Bond_id_repr.t type infinite_source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards ] + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards -type source = [infinite_source | container] +type source = + | Source_infinite of infinite_source + | Source_container of container type infinite_sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Tx_rollup_rejection_punishments - | `Burned ] + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Burned + | Tx_rollup_rejection_punishments -type sink = [infinite_sink | container] +type sink = Sink_infinite of infinite_sink | Sink_container of container let allocated ctxt stored = match stored with - | `Contract contract -> + | Contract contract -> Contract_storage.allocated ctxt contract >|=? fun allocated -> (ctxt, allocated) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.exists ctxt bpkh >|= ok >|=? fun allocated -> (ctxt, allocated) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.implicit_contract delegate in Contract_storage.allocated ctxt contract >|=? fun allocated -> (ctxt, allocated) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> let contract = Contract_repr.implicit_contract delegate in Frozen_deposits_storage.allocated ctxt contract >|= fun allocated -> ok (ctxt, allocated) - | `Block_fees -> return (ctxt, true) - | `Frozen_bonds (contract, bond_id) -> + | Block_fees -> return (ctxt, true) + | Frozen_bonds (contract, bond_id) -> Contract_storage.bond_allocated ctxt contract bond_id let balance ctxt stored = match stored with - | `Contract contract -> + | Contract contract -> Contract_storage.get_balance ctxt contract >|=? fun balance -> (ctxt, balance) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.committed_amount ctxt bpkh >|=? fun balance -> (ctxt, balance) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.implicit_contract delegate in Storage.Contract.Spendable_balance.get ctxt contract >|=? fun balance -> (ctxt, balance) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> let contract = Contract_repr.implicit_contract delegate in Frozen_deposits_storage.find ctxt contract >|=? fun frozen_deposits -> let balance = @@ -96,44 +98,44 @@ let balance ctxt stored = | Some frozen_deposits -> frozen_deposits.current_amount in (ctxt, balance) - | `Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt) - | `Frozen_bonds (contract, bond_id) -> + | Block_fees -> return (ctxt, Raw_context.get_collected_fees ctxt) + | Frozen_bonds (contract, bond_id) -> Contract_storage.find_bond ctxt contract bond_id >|=? fun (ctxt, balance_opt) -> (ctxt, Option.value ~default:Tez_repr.zero balance_opt) -let credit ctxt dest amount origin = +let credit ctxt (dest : sink) amount origin = let open Receipt_repr in (match dest with - | #infinite_sink as infinite_sink -> + | Sink_infinite infinite_sink -> let sink = match infinite_sink with - | `Storage_fees -> Storage_fees - | `Double_signing_punishments -> Double_signing_punishments - | `Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r) - | `Tx_rollup_rejection_punishments -> Tx_rollup_rejection_punishments - | `Burned -> Burned + | Storage_fees -> Storage_fees + | Double_signing_punishments -> Double_signing_punishments + | Lost_endorsing_rewards (d, p, r) -> Lost_endorsing_rewards (d, p, r) + | Tx_rollup_rejection_punishments -> Tx_rollup_rejection_punishments + | Burned -> Burned in return (ctxt, sink) - | #container as container -> ( + | Sink_container container -> ( match container with - | `Contract dest -> + | Contract dest -> Contract_storage.credit_only_call_from_token ctxt dest amount >|=? fun ctxt -> (ctxt, Contract dest) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.increase_commitment_only_call_from_token ctxt bpkh amount >|=? fun ctxt -> (ctxt, Commitments bpkh) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.implicit_contract delegate in Contract_storage.increase_balance_only_call_from_token ctxt contract amount >|=? fun ctxt -> (ctxt, Contract contract) - | `Frozen_deposits delegate as dest -> + | Frozen_deposits delegate as dest -> allocated ctxt dest >>=? fun (ctxt, allocated) -> (if not allocated then Frozen_deposits_storage.init ctxt delegate else return ctxt) @@ -143,10 +145,10 @@ let credit ctxt dest amount origin = delegate amount >|=? fun ctxt -> (ctxt, Deposits delegate) - | `Block_fees -> + | Block_fees -> Raw_context.credit_collected_fees_only_call_from_token ctxt amount >>?= fun ctxt -> return (ctxt, Block_fees) - | `Frozen_bonds (contract, bond_id) -> + | Frozen_bonds (contract, bond_id) -> Contract_storage.credit_bond_only_call_from_token ctxt contract @@ -155,53 +157,53 @@ let credit ctxt dest amount origin = >>=? fun ctxt -> return (ctxt, Frozen_bonds (contract, bond_id)))) >|=? fun (ctxt, balance) -> (ctxt, (balance, Credited amount, origin)) -let spend ctxt src amount origin = +let spend ctxt (src : source) amount origin = let open Receipt_repr in (match src with - | #infinite_source as infinite_source -> + | Source_infinite infinite_source -> let src = match infinite_source with - | `Bootstrap -> Bootstrap - | `Invoice -> Invoice - | `Initial_commitments -> Initial_commitments - | `Minted -> Minted - | `Liquidity_baking_subsidies -> Liquidity_baking_subsidies - | `Revelation_rewards -> Nonce_revelation_rewards - | `Double_signing_evidence_rewards -> Double_signing_evidence_rewards - | `Endorsing_rewards -> Endorsing_rewards - | `Baking_rewards -> Baking_rewards - | `Baking_bonuses -> Baking_bonuses - | `Tx_rollup_rejection_rewards -> Tx_rollup_rejection_rewards + | Bootstrap -> Bootstrap + | Invoice -> Invoice + | Initial_commitments -> Initial_commitments + | Minted -> Minted + | Liquidity_baking_subsidies -> Liquidity_baking_subsidies + | Revelation_rewards -> Nonce_revelation_rewards + | Double_signing_evidence_rewards -> Double_signing_evidence_rewards + | Endorsing_rewards -> Endorsing_rewards + | Baking_rewards -> Baking_rewards + | Baking_bonuses -> Baking_bonuses + | Tx_rollup_rejection_rewards -> Tx_rollup_rejection_rewards in return (ctxt, src) - | #container as container -> ( + | Source_container container -> ( match container with - | `Contract src -> + | Contract src -> Contract_storage.spend_only_call_from_token ctxt src amount >|=? fun ctxt -> (ctxt, Contract src) - | `Collected_commitments bpkh -> + | Collected_commitments bpkh -> Commitment_storage.decrease_commitment_only_call_from_token ctxt bpkh amount >|=? fun ctxt -> (ctxt, Commitments bpkh) - | `Delegate_balance delegate -> + | Delegate_balance delegate -> let contract = Contract_repr.implicit_contract delegate in Contract_storage.decrease_balance_only_call_from_token ctxt contract amount >|=? fun ctxt -> (ctxt, Contract contract) - | `Frozen_deposits delegate -> + | Frozen_deposits delegate -> Frozen_deposits_storage.spend_only_call_from_token ctxt delegate amount >|=? fun ctxt -> (ctxt, Deposits delegate) - | `Block_fees -> + | Block_fees -> Raw_context.spend_collected_fees_only_call_from_token ctxt amount >>?= fun ctxt -> return (ctxt, Block_fees) - | `Frozen_bonds (contract, bond_id) -> + | Frozen_bonds (contract, bond_id) -> Contract_storage.spend_bond_only_call_from_token ctxt contract @@ -234,9 +236,10 @@ let transfer_n ?(origin = Receipt_repr.Block_application) ctxt src dest = List.fold_left_es (fun ctxt (source, _amount) -> match source with - | `Contract contract | `Frozen_bonds (contract, _) -> + | Source_container (Contract contract) + | Source_container (Frozen_bonds (contract, _)) -> Contract_storage.ensure_deallocated_if_empty ctxt contract - | #source -> return ctxt) + | _ -> return ctxt) ctxt sources >|=? fun ctxt -> diff --git a/src/proto_alpha/lib_protocol/token.mli b/src/proto_alpha/lib_protocol/token.mli index 2fe5f2cb84469..fcbc3b0e396f4 100644 --- a/src/proto_alpha/lib_protocol/token.mli +++ b/src/proto_alpha/lib_protocol/token.mli @@ -43,42 +43,44 @@ stake. *) type container = - [ `Contract of Contract_repr.t - | `Collected_commitments of Blinded_public_key_hash.t - | `Delegate_balance of Signature.Public_key_hash.t - | `Frozen_deposits of Signature.Public_key_hash.t - | `Block_fees - | `Frozen_bonds of Contract_repr.t * Bond_id_repr.t ] + | Contract of Contract_repr.t + | Collected_commitments of Blinded_public_key_hash.t + | Delegate_balance of Signature.Public_key_hash.t + | Frozen_deposits of Signature.Public_key_hash.t + | Block_fees + | Frozen_bonds of Contract_repr.t * Bond_id_repr.t (** [infinite_source] defines types of tokens provides which are considered to be ** of infinite capacity. *) type infinite_source = - [ `Invoice - | `Bootstrap - | `Initial_commitments - | `Revelation_rewards - | `Double_signing_evidence_rewards - | `Endorsing_rewards - | `Baking_rewards - | `Baking_bonuses - | `Minted - | `Liquidity_baking_subsidies - | `Tx_rollup_rejection_rewards ] + | Invoice + | Bootstrap + | Initial_commitments + | Revelation_rewards + | Double_signing_evidence_rewards + | Endorsing_rewards + | Baking_rewards + | Baking_bonuses + | Minted + | Liquidity_baking_subsidies + | Tx_rollup_rejection_rewards (** [source] is the type of token providers. Token providers that are not containers are considered to have infinite capacity. *) -type source = [infinite_source | container] +type source = + | Source_infinite of infinite_source + | Source_container of container type infinite_sink = - [ `Storage_fees - | `Double_signing_punishments - | `Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | `Tx_rollup_rejection_punishments - | `Burned ] + | Storage_fees + | Double_signing_punishments + | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool + | Burned + | Tx_rollup_rejection_punishments (** [sink] is the type of token receivers. Token receivers that are not containers are considered to have infinite capacity. *) -type sink = [infinite_sink | container] +type sink = Sink_infinite of infinite_sink | Sink_container of container (** [allocated ctxt container] returns a new context because of possible access to carbonated data, and a boolean that is [true] when @@ -109,8 +111,8 @@ val balance : val transfer_n : ?origin:Receipt_repr.update_origin -> Raw_context.t -> - ([< source] * Tez_repr.t) list -> - [< sink] -> + (source * Tez_repr.t) list -> + sink -> (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t (** [transfer ?origin ctxt src dest amount] transfers [amount] Tez from source @@ -137,7 +139,7 @@ val transfer_n : val transfer : ?origin:Receipt_repr.update_origin -> Raw_context.t -> - [< source] -> - [< sink] -> + source -> + sink -> Tez_repr.t -> (Raw_context.t * Receipt_repr.balance_updates) tzresult Lwt.t -- GitLab From 30f76dd84a07fb74b56c0bb7d6ff5d60dd5d29f9 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 5 Nov 2021 17:51:06 +0100 Subject: [PATCH 010/105] Proto: expand match on extensible type for coq-of-ocaml --- src/proto_alpha/lib_protocol/cache_repr.ml | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/cache_repr.ml b/src/proto_alpha/lib_protocol/cache_repr.ml index 1fb43b8739c3e..2359480d4dc04 100644 --- a/src/proto_alpha/lib_protocol/cache_repr.ml +++ b/src/proto_alpha/lib_protocol/cache_repr.ml @@ -264,15 +264,17 @@ let register_exn (type cvalue) >>?= fun ctxt -> Admin.find ctxt (mk ~id) >>= function | None -> return None - | Some (K v) -> return (Some v) - | _ -> - (* This execution path is impossible because all the keys of - C's namespace (which is unique to C) are constructed with - [K]. This [assert false] could have been pushed into the - environment in exchange for extra complexity. The - argument that justifies this [assert false] seems - simple enough to keep the current design though. *) - assert false + | Some value -> ( + match value with + | K v -> return (Some v) + | _ -> + (* This execution path is impossible because all the keys of + C's namespace (which is unique to C) are constructed with + [K]. This [assert false] could have been pushed into the + environment in exchange for extra complexity. The + argument that justifies this [assert false] seems + simple enough to keep the current design though. *) + assert false) let list_identifiers ctxt = Admin.list_keys ctxt ~cache_index:C.cache_index |> function -- GitLab From 666284d47e1ea5f9c0d8eaf576effa78bbb45a8d Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 5 Nov 2021 18:53:11 +0100 Subject: [PATCH 011/105] Proto: add coq-of-ocaml annotations --- src/proto_alpha/lib_protocol/round_repr.ml | 2 +- src/proto_alpha/lib_protocol/script_typed_ir_size.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/round_repr.ml b/src/proto_alpha/lib_protocol/round_repr.ml index 8a60fa3176841..fb355745b3a4b 100644 --- a/src/proto_alpha/lib_protocol/round_repr.ml +++ b/src/proto_alpha/lib_protocol/round_repr.ml @@ -107,7 +107,7 @@ let encoding = (fun i -> i) (fun i -> match of_int32 i with - | Ok _ as res -> res + | Ok _ as res -> res [@coq_cast] | Error _ -> Error "Round_repr.encoding: negative round") Data_encoding.int32 diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 296631a49692e..62ecde31e7b03 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -34,10 +34,10 @@ let sapling_memo_size_size = !!0 module Ty_size = struct let base_basic = !!0 + (* Basic types count for 0 because they are all static values, hence shared and not counted by `reachable_words`. On the other hand compound types are functions, hence not shared. *) - let base_compound_no_meta = header_size let base_compound _meta = h1w -- GitLab From cdeaf56bdc54238b39d60cd098bc513f8d2f6505 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 5 Nov 2021 21:19:25 +0100 Subject: [PATCH 012/105] Proto: add fixpoint annotation for coq-of-ocaml --- src/proto_alpha/lib_protocol/sampler.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/sampler.ml b/src/proto_alpha/lib_protocol/sampler.ml index b390b6dcf54be..6f42b1da9ad1b 100644 --- a/src/proto_alpha/lib_protocol/sampler.ml +++ b/src/proto_alpha/lib_protocol/sampler.ml @@ -74,7 +74,7 @@ module Make (Mass : SMass) : S with type mass = Mass.t = struct alias : int FallbackArray.t; } - let rec init_loop total p alias small large = + let[@coq_struct "small"] rec init_loop total p alias small large = match (small, large) with | ([], _) -> List.iter (fun (_, i) -> FallbackArray.set p i total) large | (_, []) -> -- GitLab From 1df5f1dc1b94d24ab3895c66ba9afb5a4f429962 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 5 Nov 2021 21:19:41 +0100 Subject: [PATCH 013/105] Proto: namespace similar constructors for Coq --- .../client_baking_denunciation.ml | 6 ++-- .../lib_protocol/alpha_context.mli | 21 +++++++------ src/proto_alpha/lib_protocol/apply.ml | 8 ++--- .../lib_protocol/operation_repr.ml | 31 ++++++++++--------- .../lib_protocol/operation_repr.mli | 21 +++++++------ 5 files changed, 45 insertions(+), 42 deletions(-) diff --git a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml index 8fef9976c5010..97f85664b1fb0 100644 --- a/src/proto_alpha/lib_delegate/client_baking_denunciation.ml +++ b/src/proto_alpha/lib_delegate/client_baking_denunciation.ml @@ -113,7 +113,7 @@ let get_block_offset level = Events.(emit invalid_level_conversion) (Environment.wrap_tztrace errs) >>= fun () -> Lwt.return (`Head 0) -let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) +let get_payload_hash (type kind) (op_kind : kind Consensus_operation_type.t) (op : kind Operation.t) = match (op_kind, op.protocol_data.contents) with | (Preendorsement, Single (Preendorsement consensus_content)) @@ -122,7 +122,7 @@ let get_payload_hash (type kind) (op_kind : kind consensus_operation_type) | _ -> . let double_consensus_op_evidence (type kind) : - kind consensus_operation_type -> + kind Consensus_operation_type.t -> #Protocol_client_context.full -> 'a -> branch:Block_hash.t -> @@ -134,7 +134,7 @@ let double_consensus_op_evidence (type kind) : | Preendorsement -> Plugin.RPC.Forge.double_preendorsement_evidence let process_consensus_op (type kind) cctxt - (op_kind : kind consensus_operation_type) (new_op : kind Operation.t) + (op_kind : kind Consensus_operation_type.t) (new_op : kind Operation.t) chain_id level round slot ops_table = let map = Option.value ~default:Slot_Map.empty diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index b0553d384df45..d71d67813a324 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2858,12 +2858,13 @@ module Kind : sig | Sc_rollup_publish_manager_kind : sc_rollup_publish manager end -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type +module Consensus_operation_type : sig + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t -val pp_operation_kind : - Format.formatter -> 'kind consensus_operation_type -> unit + val pp : Format.formatter -> 'kind t -> unit +end type consensus_content = { slot : Slot.t; @@ -3081,13 +3082,13 @@ module Operation : sig type nonrec packed_protocol_data = packed_protocol_data - type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t + module Consensus_watermark : sig + type t = Endorsement of Chain_id.t | Preendorsement of Chain_id.t + end - val to_watermark : consensus_watermark -> Signature.watermark + val to_watermark : Consensus_watermark.t -> Signature.watermark - val of_watermark : Signature.watermark -> consensus_watermark option + val of_watermark : Signature.watermark -> Consensus_watermark.t option val protocol_data_encoding : packed_protocol_data Data_encoding.t diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 8d11a4875e303..5a49cc6d30577 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -2509,7 +2509,7 @@ type 'consensus_op_kind expected_consensus_content = { let compute_expected_consensus_content (type consensus_op_kind) ~(current_level : Level.t) ~(proposal_level : Level.t) (ctxt : context) (application_mode : apply_mode) - (operation_kind : consensus_op_kind consensus_operation_type) + (operation_kind : consensus_op_kind Consensus_operation_type.t) (operation_round : Round.t) (operation_level : Raw_level.t) : (context * consensus_op_kind expected_consensus_content) tzresult Lwt.t = match operation_kind with @@ -2614,7 +2614,7 @@ let check_operation_branch ~expected ~provided = (Block_hash.equal expected provided) (Wrong_consensus_operation_branch (expected, provided)) -let check_round (type kind) (operation_kind : kind consensus_operation_type) +let check_round (type kind) (operation_kind : kind Consensus_operation_type.t) (apply_mode : apply_mode) ~(expected : Round.t) ~(provided : Round.t) : unit tzresult = match apply_mode with @@ -2640,7 +2640,7 @@ let check_round (type kind) (operation_kind : kind consensus_operation_type) let check_consensus_content (type kind) (apply_mode : apply_mode) (content : consensus_content) (operation_branch : Block_hash.t) - (operation_kind : kind consensus_operation_type) + (operation_kind : kind Consensus_operation_type.t) (expected_content : kind expected_consensus_content) : unit tzresult = let expected_level = expected_content.level.level in let provided_level = content.level in @@ -2668,7 +2668,7 @@ let check_consensus_content (type kind) (apply_mode : apply_mode) a preendorsement pointing to the direct proposal. This preendorsement wouldn't be able to propagate for a subsequent proposal using it as a locked_round evidence. *) let validate_consensus_contents (type kind) ctxt chain_id - (operation_kind : kind consensus_operation_type) + (operation_kind : kind Consensus_operation_type.t) (operation : kind operation) (apply_mode : apply_mode) (content : consensus_content) : (context * public_key_hash * int) tzresult Lwt.t = diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 2493273bde08e..0de423622ce0c 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -122,15 +122,16 @@ module Kind = struct | Sc_rollup_publish_manager_kind : sc_rollup_publish manager end -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type - -let pp_operation_kind (type kind) ppf - (operation_kind : kind consensus_operation_type) = - match operation_kind with - | Endorsement -> Format.fprintf ppf "Endorsement" - | Preendorsement -> Format.fprintf ppf "Preendorsement" +module Consensus_operation_type = struct + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t + + let pp (type kind) ppf (operation_kind : kind t) = + match operation_kind with + | Endorsement -> Format.fprintf ppf "Endorsement" + | Preendorsement -> Format.fprintf ppf "Preendorsement" +end type consensus_content = { slot : Slot_repr.t; @@ -171,12 +172,12 @@ let pp_consensus_content ppf content = Block_payload_hash.pp_short content.block_payload_hash -type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t +module Consensus_watermark = struct + type t = Endorsement of Chain_id.t | Preendorsement of Chain_id.t +end let bytes_of_consensus_watermark = function - | Preendorsement chain_id -> + | Consensus_watermark.Preendorsement chain_id -> Bytes.cat (Bytes.of_string "\x12") (Chain_id.to_bytes chain_id) | Endorsement chain_id -> Bytes.cat (Bytes.of_string "\x13") (Chain_id.to_bytes chain_id) @@ -189,11 +190,11 @@ let of_watermark = function match Bytes.get b 0 with | '\x12' -> Option.map - (fun chain_id -> Endorsement chain_id) + (fun chain_id -> Consensus_watermark.Endorsement chain_id) (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1))) | '\x13' -> Option.map - (fun chain_id -> Preendorsement chain_id) + (fun chain_id -> Consensus_watermark.Preendorsement chain_id) (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1))) | _ -> None else None diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index de7e706f444b3..c2ade0f5e2661 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -151,12 +151,13 @@ module Kind : sig | Sc_rollup_publish_manager_kind : sc_rollup_publish manager end -type 'a consensus_operation_type = - | Endorsement : Kind.endorsement consensus_operation_type - | Preendorsement : Kind.preendorsement consensus_operation_type +module Consensus_operation_type : sig + type 'a t = + | Endorsement : Kind.endorsement t + | Preendorsement : Kind.preendorsement t -val pp_operation_kind : - Format.formatter -> 'kind consensus_operation_type -> unit + val pp : Format.formatter -> 'kind t -> unit +end type consensus_content = { slot : Slot_repr.t; @@ -173,13 +174,13 @@ val consensus_content_encoding : consensus_content Data_encoding.t val pp_consensus_content : Format.formatter -> consensus_content -> unit -type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t +module Consensus_watermark : sig + type t = Endorsement of Chain_id.t | Preendorsement of Chain_id.t +end -val to_watermark : consensus_watermark -> Signature.watermark +val to_watermark : Consensus_watermark.t -> Signature.watermark -val of_watermark : Signature.watermark -> consensus_watermark option +val of_watermark : Signature.watermark -> Consensus_watermark.t option type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} -- GitLab From e1fc53717c572becf3e3003ed40cafe1fdb771ad Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 5 Nov 2021 22:01:20 +0100 Subject: [PATCH 014/105] Proto: add coq-of-ocaml annotations to compile operation_repr --- .../lib_protocol/operation_repr.ml | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 0de423622ce0c..a64a9d41be519 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -983,7 +983,9 @@ module Encoding = struct encoding = consensus_content_encoding; select = (function Contents (Preendorsement _ as op) -> Some op | _ -> None); - proj = (fun (Preendorsement preendorsement) -> preendorsement); + proj = + (fun [@coq_match_with_default] (Preendorsement preendorsement) -> + preendorsement); inj = (fun preendorsement -> Preendorsement preendorsement); } @@ -1013,19 +1015,17 @@ module Encoding = struct @@ union [make preendorsement_case])) (varopt "signature" Signature.encoding))) - let endorsement_encoding = - obj4 - (req "slot" Slot_repr.encoding) - (req "level" Raw_level_repr.encoding) - (req "round" Round_repr.encoding) - (req "block_payload_hash" Block_payload_hash.encoding) - let endorsement_case = Case { tag = 21; name = "endorsement"; - encoding = endorsement_encoding; + encoding = + obj4 + (req "slot" Slot_repr.encoding) + (req "level" Raw_level_repr.encoding) + (req "round" Round_repr.encoding) + (req "block_payload_hash" Block_payload_hash.encoding); select = (function Contents (Endorsement _ as op) -> Some op | _ -> None); proj = @@ -1421,7 +1421,7 @@ let raw ({shell; protocol_data} : _ operation) = let acceptable_passes (op : packed_operation) = let (Operation_data protocol_data) = op.protocol_data in - match protocol_data.contents with + match[@coq_match_with_default] protocol_data.contents with | Single (Failing_noop _) -> [] | Single (Preendorsement _) -> [0] | Single (Endorsement _) -> [0] @@ -1492,7 +1492,7 @@ let check_signature (type kind) key chain_id match protocol_data.signature with | None -> error Missing_signature | Some signature -> ( - match protocol_data.contents with + match[@coq_match_with_default] protocol_data.contents with | Single (Preendorsement _) as contents -> check ~watermark:(to_watermark (Preendorsement chain_id)) -- GitLab From afcec7f9029aa5971731cac70b594f20eba6d75c Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Sat, 6 Nov 2021 00:37:49 +0100 Subject: [PATCH 015/105] Proto: add coq-of-ocaml attributes --- src/proto_alpha/lib_protocol/apply.ml | 28 +++++++++++-------- src/proto_alpha/lib_protocol/apply_results.ml | 2 +- src/proto_alpha/lib_protocol/baking.ml | 2 +- 3 files changed, 18 insertions(+), 14 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 5a49cc6d30577..fcfe067214356 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -2218,7 +2218,7 @@ let skipped_operation_result : : kind successful_manager_operation_result) | _ -> Skipped (manager_kind operation)) -let rec mark_skipped : +let[@coq_axiom_with_reason "gadts"] rec mark_skipped : type kind. payload_producer:Signature.Public_key_hash.t -> Level.t -> @@ -2349,7 +2349,7 @@ let check_manager_signature ctxt chain_id (op : _ Kind.manager contents_list) find_manager_public_key ctxt op >>=? fun public_key -> Lwt.return (Operation.check_signature public_key chain_id raw_operation) -let rec apply_manager_contents_list_rec : +let[@coq_axiom_with_reason "gadts"] rec apply_manager_contents_list_rec : type kind. context -> Script_ir_translator.unparsing_mode -> @@ -2485,7 +2485,7 @@ let get_predecessor_level = function predecessor_level let record_operation (type kind) ctxt (operation : kind operation) : context = - match operation.protocol_data.contents with + match[@coq_match_with_default] operation.protocol_data.contents with | Single (Preendorsement _) -> ctxt | Single (Endorsement _) -> ctxt | Single @@ -2667,8 +2667,8 @@ let check_consensus_content (type kind) (apply_mode : apply_mode) to the grandfather: the block hash used in the payload_hash. Otherwise we could produce a preendorsement pointing to the direct proposal. This preendorsement wouldn't be able to propagate for a subsequent proposal using it as a locked_round evidence. *) -let validate_consensus_contents (type kind) ctxt chain_id - (operation_kind : kind Consensus_operation_type.t) +let[@coq_axiom_with_reason "bug in coq-of-ocaml"] validate_consensus_contents + (type kind) ctxt chain_id (operation_kind : kind Consensus_operation_type.t) (operation : kind operation) (apply_mode : apply_mode) (content : consensus_content) : (context * public_key_hash * int) tzresult Lwt.t = @@ -2735,13 +2735,15 @@ let check_denunciation_age ctxt kind given_level = (Outdated_denunciation {kind; level = given_level; last_cycle = last_slashable_cycle}) +type mistake = Double_baking | Double_endorsing + let punish_delegate ctxt delegate level mistake mk_result ~payload_producer = let (already_slashed, punish) = match mistake with - | `Double_baking -> + | Double_baking -> ( Delegate.already_slashed_for_double_baking, Delegate.punish_double_baking ) - | `Double_endorsing -> + | Double_endorsing -> ( Delegate.already_slashed_for_double_endorsing, Delegate.punish_double_endorsing ) in @@ -2769,13 +2771,15 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id Lwt.t = let mk_result (balance_updates : Receipt.balance_updates) : kind Kind.double_consensus_operation_evidence contents_result = - match op1.protocol_data.contents with + match[@coq_match_with_default] op1.protocol_data.contents with | Single (Preendorsement _) -> Double_preendorsement_evidence_result balance_updates | Single (Endorsement _) -> Double_endorsement_evidence_result balance_updates in - match (op1.protocol_data.contents, op2.protocol_data.contents) with + match[@coq_match_with_default] + (op1.protocol_data.contents, op2.protocol_data.contents) + with | (Single (Preendorsement e1), Single (Preendorsement e2)) | (Single (Endorsement e1), Single (Endorsement e2)) -> let kind = if preendorsement then Preendorsement else Endorsement in @@ -2811,7 +2815,7 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id ctxt delegate level - `Double_endorsing + Double_endorsing mk_result ~payload_producer @@ -2854,7 +2858,7 @@ let punish_double_baking ctxt chain_id bh1 bh2 ~payload_producer = ctxt delegate level - `Double_baking + Double_baking ~payload_producer (fun balance_updates -> Double_baking_evidence_result balance_updates) @@ -2875,7 +2879,7 @@ let is_parent_endorsement ctxt ~proposal_level ~grand_parent_round let validate_grand_parent_endorsement ctxt chain_id (op : Kind.endorsement operation) = - match op.protocol_data.contents with + match[@coq_match_with_default] op.protocol_data.contents with | Single (Endorsement e) -> let level = Level.from_raw ctxt e.level in Stake_distribution.slot_owner ctxt level e.slot diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 5d604f772b886..f1312a7b352fa 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -585,7 +585,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Set_deposits_limit_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Set_deposits_limit_result {consumed_gas} -> (Gas.Arith.ceil consumed_gas, consumed_gas)) ~inj:(fun (consumed_gas, consumed_milligas) -> diff --git a/src/proto_alpha/lib_protocol/baking.ml b/src/proto_alpha/lib_protocol/baking.ml index eb10613fe00df..b3fd2f26f4b89 100644 --- a/src/proto_alpha/lib_protocol/baking.ml +++ b/src/proto_alpha/lib_protocol/baking.ml @@ -70,7 +70,7 @@ let bonus_baking_reward ctxt ~endorsing_power = Tez.(baking_reward_bonus_per_slot *? Int64.of_int extra_endorsing_power) let baking_rights c level = - let rec f c round = + let[@coq_struct "round"] rec f c round = Stake_distribution.baking_rights_owner c level ~round >>=? fun (c, _slot, (delegate, _)) -> return (LCons (delegate, fun () -> f c (Round.succ round))) -- GitLab From 274a29b5864edb9b80810ab1a9063010c8cf2748 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Sat, 6 Nov 2021 01:07:55 +0100 Subject: [PATCH 016/105] Proto: add attributes to compile in Coq --- .../lib_protocol/ticket_scanner.ml | 40 +++++++++---------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index 2956a01816d12..77096a85b495e 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -143,7 +143,7 @@ module Ticket_inspection = struct The returned value matches the given shape of the [ty] value, except it collapses whole branches where no types embed tickets to [False_ht]. *) - let rec has_tickets_of_ty : + let rec has_tickets_of_ty_aux : type a ac ret. (a, ac) Script_typed_ir.ty -> (a, ret) continuation -> ret tzresult = fun ty k -> @@ -180,11 +180,11 @@ module Ticket_inspection = struct a packable type and tickets are not packable. *) (k [@ocaml.tailcall]) False_ht | Option_t (ty, _, _) -> - (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty (fun ht -> let opt_hty = map_has_tickets (fun ht -> Option_ht ht) ht in (k [@ocaml.tailcall]) opt_hty) | List_t (ty, _) -> - (has_tickets_of_ty [@ocaml.tailcall]) ty (fun ht -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty (fun ht -> let list_hty = map_has_tickets (fun ht -> List_ht ht) ht in (k [@ocaml.tailcall]) list_hty) | Set_t (key_ty, _) -> @@ -219,7 +219,7 @@ module Ticket_inspection = struct | Chest_t -> (k [@ocaml.tailcall]) False_ht | Chest_key_t -> (k [@ocaml.tailcall]) False_ht - and has_tickets_of_pair : + and[@coq_mutual_as_notation] has_tickets_of_pair : type a ac b bc c ret. (a, ac) Script_typed_ir.ty -> (b, bc) Script_typed_ir.ty -> @@ -227,11 +227,11 @@ module Ticket_inspection = struct (c, ret) continuation -> ret tzresult = fun ty1 ty2 ~pair k -> - (has_tickets_of_ty [@ocaml.tailcall]) ty1 (fun ht1 -> - (has_tickets_of_ty [@ocaml.tailcall]) ty2 (fun ht2 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty1 (fun ht1 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) ty2 (fun ht2 -> (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2))) - and has_tickets_of_key_and_value : + and[@coq_mutual_as_notation] has_tickets_of_key_and_value : type k v vc t ret. k Script_typed_ir.comparable_ty -> (v, vc) Script_typed_ir.ty -> @@ -240,12 +240,12 @@ module Ticket_inspection = struct ret tzresult = fun key_ty val_ty ~pair k -> (has_tickets_of_comparable [@ocaml.tailcall]) key_ty (fun ht1 -> - (has_tickets_of_ty [@ocaml.tailcall]) val_ty (fun ht2 -> + (has_tickets_of_ty_aux [@ocaml.tailcall]) val_ty (fun ht2 -> (k [@ocaml.tailcall]) (pair_has_tickets pair ht1 ht2))) let has_tickets_of_ty ctxt ty = Gas.consume ctxt (Ticket_costs.has_tickets_of_ty_cost ty) >>? fun ctxt -> - has_tickets_of_ty ty ok >|? fun ht -> (ht, ctxt) + has_tickets_of_ty_aux ty ok >|? fun ht -> (ht, ctxt) end module Ticket_collection = struct @@ -307,7 +307,7 @@ module Ticket_collection = struct comparable. *) (tickets_of_comparable [@ocaml.tailcall]) ctxt key_ty acc k - let rec tickets_of_value : + let[@coq_axiom_with_reason "gadts"] rec tickets_of_value_aux : type a ac ret. include_lazy:bool -> Alpha_context.context -> @@ -324,7 +324,7 @@ module Ticket_collection = struct | (False_ht, _) -> (k [@ocaml.tailcall]) ctxt acc | (Pair_ht (hty1, hty2), Pair_t (ty1, ty2, _, _)) -> let (l, r) = x in - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt hty1 @@ -332,7 +332,7 @@ module Ticket_collection = struct l acc (fun ctxt acc -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt hty2 @@ -343,7 +343,7 @@ module Ticket_collection = struct | (Union_ht (htyl, htyr), Union_t (tyl, tyr, _, _)) -> ( match x with | L v -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt htyl @@ -352,7 +352,7 @@ module Ticket_collection = struct acc k | R v -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt htyr @@ -363,7 +363,7 @@ module Ticket_collection = struct | (Option_ht el_hty, Option_t (el_ty, _, _)) -> ( match x with | Some x -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt el_hty @@ -405,7 +405,7 @@ module Ticket_collection = struct | (True_ht, Ticket_t (comp_ty, _)) -> (k [@ocaml.tailcall]) ctxt (Ex_ticket (comp_ty, x) :: acc) - and tickets_of_list : + and[@coq_axiom_with_reason "gadts"] tickets_of_list : type a ac ret. Alpha_context.context -> include_lazy:bool -> @@ -419,7 +419,7 @@ module Ticket_collection = struct consume_gas_steps ctxt ~num_steps:1 >>?= fun ctxt -> match elements with | elem :: elems -> - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ctxt el_hty @@ -437,7 +437,7 @@ module Ticket_collection = struct k) | [] -> (k [@ocaml.tailcall]) ctxt acc - and tickets_of_map : + and[@coq_axiom_with_reason "gadts"] tickets_of_map : type k v vc ret. include_lazy:bool -> Alpha_context.context -> @@ -462,7 +462,7 @@ module Ticket_collection = struct acc k - and tickets_of_big_map : + and[@coq_axiom_with_reason "gadts"] tickets_of_big_map : type k v ret. Alpha_context.context -> v Ticket_inspection.has_tickets -> @@ -509,7 +509,7 @@ module Ticket_collection = struct | None -> (k [@ocaml.tailcall]) ctxt acc) let tickets_of_value ctxt ~include_lazy ht ty x = - tickets_of_value ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets -> + tickets_of_value_aux ctxt ~include_lazy ht ty x [] (fun ctxt ex_tickets -> return (ex_tickets, ctxt)) end -- GitLab From 488119fb3a6ef1c29be6455c2b17780405b336cd Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 18 Nov 2021 18:10:12 +0100 Subject: [PATCH 017/105] Proto: do an explicit cast for Coq --- src/proto_alpha/lib_protocol/round_repr.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/round_repr.ml b/src/proto_alpha/lib_protocol/round_repr.ml index fb355745b3a4b..8a0f59d8ab967 100644 --- a/src/proto_alpha/lib_protocol/round_repr.ml +++ b/src/proto_alpha/lib_protocol/round_repr.ml @@ -107,7 +107,7 @@ let encoding = (fun i -> i) (fun i -> match of_int32 i with - | Ok _ as res -> res [@coq_cast] + | Ok round -> Ok round | Error _ -> Error "Round_repr.encoding: negative round") Data_encoding.int32 -- GitLab From eee110b1a6dd157780348a7bd204d19d46f2fe0c Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 26 Nov 2021 12:56:43 +0100 Subject: [PATCH 018/105] Proto: name the order type for coq-of-ocaml --- src/lib_context/sigs/context.ml | 4 ++++ src/lib_protocol_environment/sigs/v4/context.mli | 6 +++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/src/lib_context/sigs/context.ml b/src/lib_context/sigs/context.ml index 341c915a8e9dd..0c53f4353558f 100644 --- a/src/lib_context/sigs/context.ml +++ b/src/lib_context/sigs/context.ml @@ -26,6 +26,10 @@ (** The tree depth of a fold. See the [fold] function for more information. *) type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] +(** The order in which we fold over elements. See the [View.fold] function for + more information. *) +type order = [`Sorted | `Undefined] + module type VIEW = sig (** The type for context views. *) type t diff --git a/src/lib_protocol_environment/sigs/v4/context.mli b/src/lib_protocol_environment/sigs/v4/context.mli index 6114a50ed3948..6447c03f7e1b0 100644 --- a/src/lib_protocol_environment/sigs/v4/context.mli +++ b/src/lib_protocol_environment/sigs/v4/context.mli @@ -31,6 +31,10 @@ (** The tree depth of a fold. See the [fold] function for more information. *) type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] +(** The order in which we fold over elements. See the [fold] function for more + information. *) +type order = [`Sorted | `Undefined] + module type VIEW = sig (** The type for context views. *) type t @@ -113,7 +117,7 @@ module type VIEW = sig ?depth:depth -> t -> key -> - order:[`Sorted | `Undefined] -> + order:order -> init:'a -> f:(key -> tree -> 'a -> 'a Lwt.t) -> 'a Lwt.t -- GitLab From d6280d895ef5495e3c1b1f5a13920b497e78080c Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Mon, 29 Nov 2021 22:45:00 +0100 Subject: [PATCH 019/105] Proto: LARGE CHANGE: compile script_interpreter_defs to Coq --- src/proto_alpha/lib_protocol/sapling_repr.ml | 2 + .../lib_protocol/script_interpreter_defs.ml | 440 +++++++++--------- 2 files changed, 211 insertions(+), 231 deletions(-) diff --git a/src/proto_alpha/lib_protocol/sapling_repr.ml b/src/proto_alpha/lib_protocol/sapling_repr.ml index 0b472fea5c28f..414854256b377 100644 --- a/src/proto_alpha/lib_protocol/sapling_repr.ml +++ b/src/proto_alpha/lib_protocol/sapling_repr.ml @@ -25,6 +25,8 @@ type transaction = Sapling.UTXO.transaction +type legacy_transaction = Sapling.UTXO.Legacy.transaction + let transaction_encoding = Sapling.UTXO.transaction_encoding (* The two data structures in the state are all ordered by position, a diff diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 12fc3baf22489..3c6607667005e 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -54,291 +54,269 @@ module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = fun i accu stack -> - match i with - | IList_map _ -> - let list = accu in - Interp_costs.list_map list - | IList_iter _ -> - let list = accu in - Interp_costs.list_iter list - | ISet_iter _ -> - let set = accu in - Interp_costs.set_iter set - | ISet_mem _ -> - let v = accu and (set, _) = stack in + match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with + | (IList_map _, (list : _ boxed_list), _) -> Interp_costs.list_map list + | (IList_iter _, (list : _ boxed_list), _) -> Interp_costs.list_iter list + | (ISet_iter _, (set : _ set), _) -> Interp_costs.set_iter set + | (ISet_mem _, v, (stack : _ * _)) -> + let (set, _) = stack in Interp_costs.set_mem v set - | ISet_update _ -> - let v = accu and (_, (set, _)) = stack in + | (ISet_update _, v, (stack : _ * (_ * _))) -> + let (_, (set, _)) = stack in Interp_costs.set_update v set - | IMap_map _ -> - let map = accu in - Interp_costs.map_map map - | IMap_iter _ -> - let map = accu in - Interp_costs.map_iter map - | IMap_mem _ -> - let v = accu and (map, _) = stack in + | (IMap_map _, (map : (_, _) map), _) -> Interp_costs.map_map map + | (IMap_iter _, (map : (_, _) map), _) -> Interp_costs.map_iter map + | (IMap_mem _, v, (stack : (a, _) map * _)) -> + let (map, _) = stack in Interp_costs.map_mem v map - | IMap_get _ -> - let v = accu and (map, _) = stack in + | (IMap_get _, v, (stack : (a, _) map * _)) -> + let (map, _) = stack in Interp_costs.map_get v map - | IMap_update _ -> - let k = accu and (_, (map, _)) = stack in + | (IMap_update _, k, (stack : _ * ((a, _) map * _))) -> + let (_, (map, _)) = stack in Interp_costs.map_update k map - | IMap_get_and_update _ -> - let k = accu and (_, (map, _)) = stack in + | (IMap_get_and_update _, k, (stack : _ * ((a, _) map * _))) -> + let (_, (map, _)) = stack in Interp_costs.map_get_and_update k map - | IBig_map_mem _ -> + | (IBig_map_mem _, _, (stack : (a, _) big_map * _)) -> let (Big_map map, _) = stack in Interp_costs.big_map_mem map.diff - | IBig_map_get _ -> + | (IBig_map_get _, _, (stack : (a, _) big_map * _)) -> let (Big_map map, _) = stack in Interp_costs.big_map_get map.diff - | IBig_map_update _ -> + | (IBig_map_update _, _, (stack : _ * ((a, _) big_map * _))) -> let (_, (Big_map map, _)) = stack in Interp_costs.big_map_update map.diff - | IBig_map_get_and_update _ -> + | (IBig_map_get_and_update _, _, (stack : _ * ((a, _) big_map * _))) -> let (_, (Big_map map, _)) = stack in Interp_costs.big_map_get_and_update map.diff - | IAdd_seconds_to_timestamp _ -> - let n = accu and (t, _) = stack in + | ( IAdd_seconds_to_timestamp _, + (n : _ Script_int.num), + (stack : Script_timestamp.t * _) ) -> + let (t, _) = stack in Interp_costs.add_seconds_timestamp n t - | IAdd_timestamp_to_seconds _ -> - let t = accu and (n, _) = stack in + | ( IAdd_timestamp_to_seconds _, + (t : Script_timestamp.t), + (stack : _ Script_int.num * _) ) -> + let (n, _) = stack in Interp_costs.add_timestamp_seconds t n - | ISub_timestamp_seconds _ -> - let t = accu and (n, _) = stack in + | ( ISub_timestamp_seconds _, + (t : Script_timestamp.t), + (stack : _ Script_int.num * _) ) -> + let (n, _) = stack in Interp_costs.sub_timestamp_seconds t n - | IDiff_timestamps _ -> - let t1 = accu and (t2, _) = stack in + | ( IDiff_timestamps _, + (t1 : Script_timestamp.t), + (stack : Script_timestamp.t * _) ) -> + let (t2, _) = stack in Interp_costs.diff_timestamps t1 t2 - | IConcat_string_pair _ -> - let x = accu and (y, _) = stack in + | (IConcat_string_pair _, (x : Script_string.t), (stack : Script_string.t * _)) + -> + let (y, _) = stack in Interp_costs.concat_string_pair x y - | IConcat_string _ -> - let ss = accu in + | (IConcat_string _, (ss : _ boxed_list), _) -> Interp_costs.concat_string_precheck ss - | ISlice_string _ -> - let _offset = accu in + | ( ISlice_string _, + _offset, + (stack : _ Script_int.num * (Script_string.t * _)) ) -> let (_length, (s, _)) = stack in Interp_costs.slice_string s - | IConcat_bytes_pair _ -> - let x = accu and (y, _) = stack in + | (IConcat_bytes_pair _, (x : bytes), (stack : bytes * _)) -> + let (y, _) = stack in Interp_costs.concat_bytes_pair x y - | IConcat_bytes _ -> - let ss = accu in + | (IConcat_bytes _, (ss : _ boxed_list), _) -> Interp_costs.concat_string_precheck ss - | ISlice_bytes _ -> + | (ISlice_bytes _, _, (stack : _ * (bytes * _))) -> let (_, (s, _)) = stack in Interp_costs.slice_bytes s - | IMul_teznat _ -> Interp_costs.mul_teznat - | IMul_nattez _ -> Interp_costs.mul_nattez - | IAbs_int _ -> - let x = accu in - Interp_costs.abs_int x - | INeg _ -> - let x = accu in - Interp_costs.neg x - | IAdd_int _ -> - let x = accu and (y, _) = stack in + | (IMul_teznat _, _, _) -> Interp_costs.mul_teznat + | (IMul_nattez _, _, _) -> Interp_costs.mul_nattez + | (IAbs_int _, (x : _ Script_int.num), _) -> Interp_costs.abs_int x + | (INeg _, (x : _ Script_int.num), _) -> Interp_costs.neg x + | (IAdd_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.add_int x y - | IAdd_nat _ -> - let x = accu and (y, _) = stack in + | (IAdd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.add_nat x y - | ISub_int _ -> - let x = accu and (y, _) = stack in + | (ISub_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.sub_int x y - | IMul_int _ -> - let x = accu and (y, _) = stack in + | (IMul_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.mul_int x y - | IMul_nat _ -> - let x = accu and (y, _) = stack in + | (IMul_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.mul_nat x y - | IEdiv_teznat _ -> - let x = accu and (y, _) = stack in + | (IEdiv_teznat _, x, (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.ediv_teznat x y - | IEdiv_int _ -> - let x = accu and (y, _) = stack in + | (IEdiv_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.ediv_int x y - | IEdiv_nat _ -> - let x = accu and (y, _) = stack in + | (IEdiv_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.ediv_nat x y - | ILsl_nat _ -> - let x = accu in - Interp_costs.lsl_nat x - | ILsr_nat _ -> - let x = accu in - Interp_costs.lsr_nat x - | IOr_nat _ -> - let x = accu and (y, _) = stack in + | (ILsl_nat _, (x : _ Script_int.num), _) -> Interp_costs.lsl_nat x + | (ILsr_nat _, (x : _ Script_int.num), _) -> Interp_costs.lsr_nat x + | (IOr_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.or_nat x y - | IAnd_nat _ -> - let x = accu and (y, _) = stack in + | (IAnd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.and_nat x y - | IAnd_int_nat _ -> - let x = accu and (y, _) = stack in + | (IAnd_int_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.and_int_nat x y - | IXor_nat _ -> - let x = accu and (y, _) = stack in + | (IXor_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _)) -> + let (y, _) = stack in Interp_costs.xor_nat x y - | INot_int _ -> - let x = accu in - Interp_costs.not_int x - | ICompare (_, ty, _) -> - let a = accu and (b, _) = stack in + | (INot_int _, (x : _ Script_int.num), _) -> Interp_costs.not_int x + | (ICompare (_, ty, _), a, (stack : a * _)) -> + let (b, _) = stack in Interp_costs.compare ty a b - | ICheck_signature _ -> - let key = accu and (_, (message, _)) = stack in + | (ICheck_signature _, (key : public_key), (stack : _ * (bytes * _))) -> + let (_, (message, _)) = stack in Interp_costs.check_signature key message - | IHash_key _ -> - let pk = accu in - Interp_costs.hash_key pk - | IBlake2b _ -> - let bytes = accu in - Interp_costs.blake2b bytes - | ISha256 _ -> - let bytes = accu in - Interp_costs.sha256 bytes - | ISha512 _ -> - let bytes = accu in - Interp_costs.sha512 bytes - | IKeccak _ -> - let bytes = accu in - Interp_costs.keccak bytes - | ISha3 _ -> - let bytes = accu in - Interp_costs.sha3 bytes - | IPairing_check_bls12_381 _ -> - let pairs = accu in + | (IHash_key _, (pk : public_key), _) -> Interp_costs.hash_key pk + | (IBlake2b _, (bytes : bytes), _) -> Interp_costs.blake2b bytes + | (ISha256 _, (bytes : bytes), _) -> Interp_costs.sha256 bytes + | (ISha512 _, (bytes : bytes), _) -> Interp_costs.sha512 bytes + | (IKeccak _, (bytes : bytes), _) -> Interp_costs.keccak bytes + | (ISha3 _, (bytes : bytes), _) -> Interp_costs.sha3 bytes + | (IPairing_check_bls12_381 _, (pairs : _ boxed_list), _) -> Interp_costs.pairing_check_bls12_381 pairs - | ISapling_verify_update _ -> + | (ISapling_verify_update _, (accu : Sapling_repr.transaction), _) -> let tx = accu in let inputs = Gas_input_size.sapling_transaction_inputs tx in let outputs = Gas_input_size.sapling_transaction_outputs tx in let bound_data = Gas_input_size.sapling_transaction_bound_data tx in Interp_costs.sapling_verify_update ~inputs ~outputs ~bound_data - | ISapling_verify_update_deprecated _ -> + | ( ISapling_verify_update_deprecated _, + (accu : Sapling_repr.legacy_transaction), + _ ) -> let tx = accu in let inputs = List.length tx.inputs in let outputs = List.length tx.outputs in Interp_costs.sapling_verify_update_deprecated ~inputs ~outputs - | ISplit_ticket _ -> + | (ISplit_ticket _, (accu : _ ticket), (stack : (_ * _) * _)) -> let ticket = accu and ((amount_a, amount_b), _) = stack in Interp_costs.split_ticket ticket.amount amount_a amount_b - | IJoin_tickets (_, ty, _) -> - let (ticket_a, ticket_b) = accu in + | (IJoin_tickets (_, ty, _), (ticket_a_b : _ ticket * _ ticket), _) -> + let (ticket_a, ticket_b) = ticket_a_b in Interp_costs.join_tickets ty ticket_a ticket_b - | IHalt _ -> Interp_costs.halt - | IDrop _ -> Interp_costs.drop - | IDup _ -> Interp_costs.dup - | ISwap _ -> Interp_costs.swap - | IConst _ -> Interp_costs.const - | ICons_some _ -> Interp_costs.cons_some - | ICons_none _ -> Interp_costs.cons_none - | IIf_none _ -> Interp_costs.if_none - | IOpt_map _ -> Interp_costs.opt_map - | ICons_pair _ -> Interp_costs.cons_pair - | IUnpair _ -> Interp_costs.unpair - | ICar _ -> Interp_costs.car - | ICdr _ -> Interp_costs.cdr - | ICons_left _ -> Interp_costs.cons_left - | ICons_right _ -> Interp_costs.cons_right - | IIf_left _ -> Interp_costs.if_left - | ICons_list _ -> Interp_costs.cons_list - | INil _ -> Interp_costs.nil - | IIf_cons _ -> Interp_costs.if_cons - | IList_size _ -> Interp_costs.list_size - | IEmpty_set _ -> Interp_costs.empty_set - | ISet_size _ -> Interp_costs.set_size - | IEmpty_map _ -> Interp_costs.empty_map - | IMap_size _ -> Interp_costs.map_size - | IEmpty_big_map _ -> Interp_costs.empty_big_map - | IString_size _ -> Interp_costs.string_size - | IBytes_size _ -> Interp_costs.bytes_size - | IAdd_tez _ -> Interp_costs.add_tez - | ISub_tez _ -> Interp_costs.sub_tez - | ISub_tez_legacy _ -> Interp_costs.sub_tez_legacy - | IOr _ -> Interp_costs.bool_or - | IAnd _ -> Interp_costs.bool_and - | IXor _ -> Interp_costs.bool_xor - | INot _ -> Interp_costs.bool_not - | IIs_nat _ -> Interp_costs.is_nat - | IInt_nat _ -> Interp_costs.int_nat - | IInt_bls12_381_fr _ -> Interp_costs.int_bls12_381_fr - | IEdiv_tez _ -> Interp_costs.ediv_tez - | IIf _ -> Interp_costs.if_ - | ILoop _ -> Interp_costs.loop - | ILoop_left _ -> Interp_costs.loop_left - | IDip _ -> Interp_costs.dip - | IExec _ -> Interp_costs.exec - | IApply _ -> Interp_costs.apply - | ILambda _ -> Interp_costs.lambda - | IFailwith _ -> Gas.free - | IEq _ -> Interp_costs.eq - | INeq _ -> Interp_costs.neq - | ILt _ -> Interp_costs.lt - | ILe _ -> Interp_costs.le - | IGt _ -> Interp_costs.gt - | IGe _ -> Interp_costs.ge - | IPack _ -> Gas.free - | IUnpack _ -> + | (IHalt _, _, _) -> Interp_costs.halt + | (IDrop _, _, _) -> Interp_costs.drop + | (IDup _, _, _) -> Interp_costs.dup + | (ISwap _, _, _) -> Interp_costs.swap + | (IConst _, _, _) -> Interp_costs.const + | (ICons_some _, _, _) -> Interp_costs.cons_some + | (ICons_none _, _, _) -> Interp_costs.cons_none + | (IIf_none _, _, _) -> Interp_costs.if_none + | (IOpt_map _, _, _) -> Interp_costs.opt_map + | (ICons_pair _, _, _) -> Interp_costs.cons_pair + | (IUnpair _, _, _) -> Interp_costs.unpair + | (ICar _, _, _) -> Interp_costs.car + | (ICdr _, _, _) -> Interp_costs.cdr + | (ICons_left _, _, _) -> Interp_costs.cons_left + | (ICons_right _, _, _) -> Interp_costs.cons_right + | (IIf_left _, _, _) -> Interp_costs.if_left + | (ICons_list _, _, _) -> Interp_costs.cons_list + | (INil _, _, _) -> Interp_costs.nil + | (IIf_cons _, _, _) -> Interp_costs.if_cons + | (IList_size _, _, _) -> Interp_costs.list_size + | (IEmpty_set _, _, _) -> Interp_costs.empty_set + | (ISet_size _, _, _) -> Interp_costs.set_size + | (IEmpty_map _, _, _) -> Interp_costs.empty_map + | (IMap_size _, _, _) -> Interp_costs.map_size + | (IEmpty_big_map _, _, _) -> Interp_costs.empty_big_map + | (IString_size _, _, _) -> Interp_costs.string_size + | (IBytes_size _, _, _) -> Interp_costs.bytes_size + | (IAdd_tez _, _, _) -> Interp_costs.add_tez + | (ISub_tez _, _, _) -> Interp_costs.sub_tez + | (ISub_tez_legacy _, _, _) -> Interp_costs.sub_tez_legacy + | (IOr _, _, _) -> Interp_costs.bool_or + | (IAnd _, _, _) -> Interp_costs.bool_and + | (IXor _, _, _) -> Interp_costs.bool_xor + | (INot _, _, _) -> Interp_costs.bool_not + | (IIs_nat _, _, _) -> Interp_costs.is_nat + | (IInt_nat _, _, _) -> Interp_costs.int_nat + | (IInt_bls12_381_fr _, _, _) -> Interp_costs.int_bls12_381_fr + | (IEdiv_tez _, _, _) -> Interp_costs.ediv_tez + | (IIf _, _, _) -> Interp_costs.if_ + | (ILoop _, _, _) -> Interp_costs.loop + | (ILoop_left _, _, _) -> Interp_costs.loop_left + | (IDip _, _, _) -> Interp_costs.dip + | (IExec _, _, _) -> Interp_costs.exec + | (IApply _, _, _) -> Interp_costs.apply + | (ILambda _, _, _) -> Interp_costs.lambda + | (IFailwith _, _, _) -> Gas.free + | (IEq _, _, _) -> Interp_costs.eq + | (INeq _, _, _) -> Interp_costs.neq + | (ILt _, _, _) -> Interp_costs.lt + | (ILe _, _, _) -> Interp_costs.le + | (IGt _, _, _) -> Interp_costs.gt + | (IGe _, _, _) -> Interp_costs.ge + | (IPack _, _, _) -> Gas.free + | (IUnpack _, (accu : bytes), _) -> let b = accu in Interp_costs.unpack b - | IAddress _ -> Interp_costs.address - | IContract _ -> Interp_costs.contract - | ITransfer_tokens _ -> Interp_costs.transfer_tokens - | IView _ -> Interp_costs.view - | IImplicit_account _ -> Interp_costs.implicit_account - | ISet_delegate _ -> Interp_costs.set_delegate - | IBalance _ -> Interp_costs.balance - | ILevel _ -> Interp_costs.level - | INow _ -> Interp_costs.now - | IMin_block_time _ -> Interp_costs.min_block_time - | ISapling_empty_state _ -> Interp_costs.sapling_empty_state - | ISource _ -> Interp_costs.source - | ISender _ -> Interp_costs.sender - | ISelf _ -> Interp_costs.self - | ISelf_address _ -> Interp_costs.self_address - | IAmount _ -> Interp_costs.amount - | IDig (_, n, _, _) -> Interp_costs.dign n - | IDug (_, n, _, _) -> Interp_costs.dugn n - | IDipn (_, n, _, _, _) -> Interp_costs.dipn n - | IDropn (_, n, _, _) -> Interp_costs.dropn n - | IChainId _ -> Interp_costs.chain_id - | ICreate_contract _ -> Interp_costs.create_contract - | INever _ -> ( match accu with _ -> .) - | IVoting_power _ -> Interp_costs.voting_power - | ITotal_voting_power _ -> Interp_costs.total_voting_power - | IAdd_bls12_381_g1 _ -> Interp_costs.add_bls12_381_g1 - | IAdd_bls12_381_g2 _ -> Interp_costs.add_bls12_381_g2 - | IAdd_bls12_381_fr _ -> Interp_costs.add_bls12_381_fr - | IMul_bls12_381_g1 _ -> Interp_costs.mul_bls12_381_g1 - | IMul_bls12_381_g2 _ -> Interp_costs.mul_bls12_381_g2 - | IMul_bls12_381_fr _ -> Interp_costs.mul_bls12_381_fr - | INeg_bls12_381_g1 _ -> Interp_costs.neg_bls12_381_g1 - | INeg_bls12_381_g2 _ -> Interp_costs.neg_bls12_381_g2 - | INeg_bls12_381_fr _ -> Interp_costs.neg_bls12_381_fr - | IMul_bls12_381_fr_z _ -> + | (IAddress _, _, _) -> Interp_costs.address + | (IContract _, _, _) -> Interp_costs.contract + | (ITransfer_tokens _, _, _) -> Interp_costs.transfer_tokens + | (IView _, _, _) -> Interp_costs.view + | (IImplicit_account _, _, _) -> Interp_costs.implicit_account + | (ISet_delegate _, _, _) -> Interp_costs.set_delegate + | (IBalance _, _, _) -> Interp_costs.balance + | (ILevel _, _, _) -> Interp_costs.level + | (INow _, _, _) -> Interp_costs.now + | (IMin_block_time _, _, _) -> Interp_costs.min_block_time + | (ISapling_empty_state _, _, _) -> Interp_costs.sapling_empty_state + | (ISource _, _, _) -> Interp_costs.source + | (ISender _, _, _) -> Interp_costs.sender + | (ISelf _, _, _) -> Interp_costs.self + | (ISelf_address _, _, _) -> Interp_costs.self_address + | (IAmount _, _, _) -> Interp_costs.amount + | (IDig (_, n, _, _), _, _) -> Interp_costs.dign n + | (IDug (_, n, _, _), _, _) -> Interp_costs.dugn n + | (IDipn (_, n, _, _, _), _, _) -> Interp_costs.dipn n + | (IDropn (_, n, _, _), _, _) -> Interp_costs.dropn n + | (IChainId _, _, _) -> Interp_costs.chain_id + | (ICreate_contract _, _, _) -> Interp_costs.create_contract + | (INever _, _, _) -> . + | (IVoting_power _, _, _) -> Interp_costs.voting_power + | (ITotal_voting_power _, _, _) -> Interp_costs.total_voting_power + | (IAdd_bls12_381_g1 _, _, _) -> Interp_costs.add_bls12_381_g1 + | (IAdd_bls12_381_g2 _, _, _) -> Interp_costs.add_bls12_381_g2 + | (IAdd_bls12_381_fr _, _, _) -> Interp_costs.add_bls12_381_fr + | (IMul_bls12_381_g1 _, _, _) -> Interp_costs.mul_bls12_381_g1 + | (IMul_bls12_381_g2 _, _, _) -> Interp_costs.mul_bls12_381_g2 + | (IMul_bls12_381_fr _, _, _) -> Interp_costs.mul_bls12_381_fr + | (INeg_bls12_381_g1 _, _, _) -> Interp_costs.neg_bls12_381_g1 + | (INeg_bls12_381_g2 _, _, _) -> Interp_costs.neg_bls12_381_g2 + | (INeg_bls12_381_fr _, _, _) -> Interp_costs.neg_bls12_381_fr + | (IMul_bls12_381_fr_z _, _, _) -> let z = accu in Interp_costs.mul_bls12_381_fr_z z - | IMul_bls12_381_z_fr _ -> + | (IMul_bls12_381_z_fr _, _, (stack : _ Script_int.num * _)) -> let (z, _) = stack in Interp_costs.mul_bls12_381_z_fr z - | IDup_n (_, n, _, _) -> Interp_costs.dupn n - | IComb (_, n, _, _) -> Interp_costs.comb n - | IUncomb (_, n, _, _) -> Interp_costs.uncomb n - | IComb_get (_, n, _, _) -> Interp_costs.comb_get n - | IComb_set (_, n, _, _) -> Interp_costs.comb_set n - | ITicket _ -> Interp_costs.ticket - | IRead_ticket _ -> Interp_costs.read_ticket - | IOpen_chest _ -> - let _chest_key = accu and (chest, (time, _)) = stack in + | (IDup_n (_, n, _, _), _, _) -> Interp_costs.dupn n + | (IComb (_, n, _, _), _, _) -> Interp_costs.comb n + | (IUncomb (_, n, _, _), _, _) -> Interp_costs.uncomb n + | (IComb_get (_, n, _, _), _, _) -> Interp_costs.comb_get n + | (IComb_set (_, n, _, _), _, _) -> Interp_costs.comb_set n + | (ITicket _, _, _) -> Interp_costs.ticket + | (IRead_ticket _, _, _) -> Interp_costs.read_ticket + | ( IOpen_chest _, + _chest_key, + (stack : Script_timelock.chest * (_ Script_int.num * _)) ) -> + let (chest, (time, _)) = stack in Interp_costs.open_chest ~chest ~time:(Alpha_context.Script_int.to_zint time) - | ILog _ -> Gas.free + | (ILog _, _, _) -> Gas.free [@@ocaml.inline always] - [@@coq_axiom_with_reason "unreachable expression `.` not handled"] let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost = fun ks -> @@ -444,7 +422,7 @@ let id x = x [@@inline] (* The following function pops n elements from the stack and push their reintroduction in the continuations stack. *) -let rec kundip : +let[@coq_struct "w"] rec kundip : type a s e z c u d w b t. (a, s, e, z, c, u, d, w) stack_prefix_preservation_witness -> c -> @@ -452,18 +430,18 @@ let rec kundip : (d, w, b, t) kinstr -> a * s * (e, z, b, t) kinstr = fun w accu stack k -> - match w with - | KPrefix (kinfo, w) -> + match[@coq_match_gadt] (w, accu, stack) with + | (KPrefix (kinfo, w), _, (stack : _ * _)) -> let k = IConst (kinfo, accu, k) in let (accu, stack) = stack in kundip w accu stack k - | KRest -> (accu, stack, k) + | (KRest, (accu : a), (stack : s)) -> (accu, stack, k) (* [apply ctxt gas ty v lam] specializes [lam] by fixing its first formal argument to [v]. The type of [v] is represented by [ty]. *) let apply ctxt gas capture_ty capture lam = let (Lam (descr, expr)) = lam in - let (Item_t (full_arg_ty, _)) = descr.kbef in + let[@coq_match_with_default] (Item_t (full_arg_ty, _)) = descr.kbef in let ctxt = update_context gas ctxt in unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> let loc = Micheline.dummy_location in @@ -655,7 +633,7 @@ let unpack ctxt ~ty ~bytes = a well-typed operation [f] under some prefix of the A-stack exploiting [w] to justify that the shape of the stack is preserved. *) -let rec interp_stack_prefix_preserving_operation : +let[@coq_struct "n"] rec interp_stack_prefix_preserving_operation : type a s b t c u d w result. (a -> s -> (b * t) * result) -> (a, s, b, t, c, u, d, w) stack_prefix_preservation_witness -> @@ -663,11 +641,11 @@ let rec interp_stack_prefix_preserving_operation : u -> (d * w) * result = fun f n accu stk -> - match (n, stk) with - | (KPrefix (_, n), rest) -> + match[@coq_match_gadt_with_result] (n, accu, stk) with + | (KPrefix (_, n), _, (rest : _ * _)) -> interp_stack_prefix_preserving_operation f n (fst rest) (snd rest) |> fun ((v, rest'), result) -> ((accu, (v, rest')), result) - | (KRest, v) -> f accu v + | (KRest, (accu : a), (v : s)) -> f accu v (* -- GitLab From 63fe4015badc0898d3e69be746c504ff14f72304 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 2 Dec 2021 19:46:19 +0100 Subject: [PATCH 020/105] Protocol: name a polymorphic variant for Coq --- src/proto_alpha/lib_protocol/script_repr.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_repr.ml b/src/proto_alpha/lib_protocol/script_repr.ml index aed2abd3de133..139f9cc215b03 100644 --- a/src/proto_alpha/lib_protocol/script_repr.ml +++ b/src/proto_alpha/lib_protocol/script_repr.ml @@ -254,11 +254,13 @@ let force_decode_cost lexpr = ~fun_combine:(fun _ _ -> Gas_limit_repr.free) lexpr +type 'a bytes_or_value = Only_value of 'a | Has_bytes of bytes + let stable_force_decode_cost lexpr = let has_bytes = Data_encoding.apply_lazy - ~fun_value:(fun v -> `Only_value v) - ~fun_bytes:(fun b -> `Has_bytes b) + ~fun_value:(fun v -> Only_value v) + ~fun_bytes:(fun b -> Has_bytes b) ~fun_combine:(fun _v b -> (* When the lazy_expr contains both a deserialized version and a serialized one, we compute the cost from the @@ -267,8 +269,8 @@ let stable_force_decode_cost lexpr = lexpr in match has_bytes with - | `Has_bytes b -> deserialization_cost_estimated_from_bytes (Bytes.length b) - | `Only_value v -> + | Has_bytes b -> deserialization_cost_estimated_from_bytes (Bytes.length b) + | Only_value v -> (* This code path should not be reached in theory because values that are decoded should have been encoded before. Here we use Data_encoding.Binary.length, which yields the same results -- GitLab From 566566f5bef9c0aeede460f08822a40202d0f267 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 2 Dec 2021 22:46:54 +0100 Subject: [PATCH 021/105] Proto: LARGE CHANGE: replace 'let and' by 'let in' in the interpreter --- .../lib_protocol/script_interpreter.ml | 90 ++++++++++++------- 1 file changed, 60 insertions(+), 30 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index a47fa7de1b541..a60ccc289428f 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -435,14 +435,16 @@ and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = fun logger g gas (kinfo, k) ks accu stack -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in match Script_int.shift_left_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = fun logger g gas (kinfo, k) ks accu stack -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in match Script_int.shift_right_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack @@ -461,7 +463,8 @@ and ifailwith : ifailwith_type = and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = fun logger g gas k ks accu stack -> - let arg = accu and (code, stack) = stack in + let arg = accu in + let (code, stack) = stack in let (Lam (code, _)) = code in let code = match logger with @@ -710,7 +713,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let s = Script_string.concat ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack | ISlice_string (_, k) -> - let offset = accu and (length, (s, stack)) = stack in + let offset = accu in + let (length, (s, stack)) = stack in let s_length = Z.of_int (Script_string.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -742,7 +746,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let s = Bytes.concat Bytes.empty ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack | ISlice_bytes (_, k) -> - let offset = accu and (length, (s, stack)) = stack in + let offset = accu in + let (length, (s, stack)) = stack in let s_length = Z.of_int (Bytes.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -810,27 +815,33 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let res = Script_int.neg x in (step [@ocaml.tailcall]) g gas k ks res stack | IAdd_int (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let res = Script_int.add x y in (step [@ocaml.tailcall]) g gas k ks res stack | IAdd_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let res = Script_int.add_n x y in (step [@ocaml.tailcall]) g gas k ks res stack | ISub_int (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let res = Script_int.sub x y in (step [@ocaml.tailcall]) g gas k ks res stack | IMul_int (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let res = Script_int.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack | IMul_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let res = Script_int.mul_n x y in (step [@ocaml.tailcall]) g gas k ks res stack | IEdiv_teznat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let x = Script_int.of_int64 (Tez.to_mutez x) in let result = match Script_int.ediv x y with @@ -847,7 +858,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) g gas k ks result stack | IEdiv_tez (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in let result = @@ -863,29 +875,35 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) g gas k ks result stack | IEdiv_int (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let res = Script_int.ediv x y in (step [@ocaml.tailcall]) g gas k ks res stack | IEdiv_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let res = Script_int.ediv_n x y in (step [@ocaml.tailcall]) g gas k ks res stack | ILsl_nat (kinfo, k) -> ilsl_nat None g gas (kinfo, k) ks accu stack | ILsr_nat (kinfo, k) -> ilsr_nat None g gas (kinfo, k) ks accu stack | IOr_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let res = Script_int.logor x y in (step [@ocaml.tailcall]) g gas k ks res stack | IAnd_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack | IAnd_int_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack | IXor_nat (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let res = Script_int.logxor x y in (step [@ocaml.tailcall]) g gas k ks res stack | INot_int (_, k) -> @@ -1176,7 +1194,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let new_stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks min_block_time new_stack | ICheck_signature (_, k) -> - let key = accu and (signature, (message, stack)) = stack in + let key = accu in + let (signature, (message, stack)) = stack in let res = Script_signature.check key signature message in (step [@ocaml.tailcall]) g gas k ks res stack | IHash_key (_, k) -> @@ -1326,36 +1345,44 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let hash = Raw_hashes.sha3_256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack | IAdd_bls12_381_g1 (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let accu = Script_bls.G1.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IAdd_bls12_381_g2 (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let accu = Script_bls.G2.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IAdd_bls12_381_fr (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let accu = Script_bls.Fr.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IMul_bls12_381_g1 (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let accu = Script_bls.G1.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IMul_bls12_381_g2 (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let accu = Script_bls.G2.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IMul_bls12_381_fr (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let accu = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack | IMul_bls12_381_fr_z (_, k) -> - let x = accu and (y, stack) = stack in + let x = accu in + let (y, stack) = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack | IMul_bls12_381_z_fr (_, k) -> - let y = accu and (x, stack) = stack in + let y = accu in + let (x, stack) = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack @@ -1419,7 +1446,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let accu = aux witness comb in (step [@ocaml.tailcall]) g gas k ks accu stack | IComb_set (_, _, witness, k) -> - let value = accu and (comb, stack) = stack in + let value = accu in + let (comb, stack) = stack in let rec aux : type value before after. (value, before, after) comb_set_gadt_witness -> @@ -1449,7 +1477,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (step [@ocaml.tailcall]) g gas k ks accu stack (* Tickets *) | ITicket (_, k) -> - let contents = accu and (amount, stack) = stack in + let contents = accu in + let (amount, stack) = stack in let ticketer = sc.self in let accu = {ticketer; contents; amount} in (step [@ocaml.tailcall]) g gas k ks accu stack @@ -1461,7 +1490,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let accu = (addr, (contents, amount)) in (step [@ocaml.tailcall]) g gas k ks accu stack | ISplit_ticket (_, k) -> - let ticket = accu and ((amount_a, amount_b), stack) = stack in + let ticket = accu in + let ((amount_a, amount_b), stack) = stack in let result = if Compare.Int.( -- GitLab From 3075ee0b99169fe82f11406e85ca3ce5a61cd9a0 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 3 Dec 2021 15:50:04 +0100 Subject: [PATCH 022/105] Proto: update single letter names for coq-of-ocaml --- src/proto_alpha/lib_protocol/level_storage.ml | 4 ++-- src/proto_alpha/lib_protocol/misc.ml | 6 +++--- src/proto_alpha/lib_protocol/script_interpreter_defs.ml | 4 ++-- src/proto_alpha/lib_protocol/seed_repr.ml | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/level_storage.ml b/src/proto_alpha/lib_protocol/level_storage.ml index 526e64e963887..53f5a46402551 100644 --- a/src/proto_alpha/lib_protocol/level_storage.ml +++ b/src/proto_alpha/lib_protocol/level_storage.ml @@ -73,7 +73,7 @@ let last_level_in_cycle ctxt c = let levels_in_cycle ctxt cycle = let first = first_level_in_cycle ctxt cycle in - let[@coq_struct "n"] rec loop (n : Level_repr.t) acc = + let[@coq_struct "n_value"] rec loop (n : Level_repr.t) acc = if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc) else acc in @@ -89,7 +89,7 @@ let levels_in_current_cycle ctxt ?(offset = 0l) () = let levels_with_commitments_in_cycle ctxt c = let first = first_level_in_cycle ctxt c in - let[@coq_struct "n"] rec loop (n : Level_repr.t) acc = + let[@coq_struct "n_value"] rec loop (n : Level_repr.t) acc = if Cycle_repr.(n.cycle = first.cycle) then if n.expected_commitment then loop (succ ctxt n) (n :: acc) else loop (succ ctxt n) acc diff --git a/src/proto_alpha/lib_protocol/misc.ml b/src/proto_alpha/lib_protocol/misc.ml index bd350a5ef85b2..2fe3e7075f447 100644 --- a/src/proto_alpha/lib_protocol/misc.ml +++ b/src/proto_alpha/lib_protocol/misc.ml @@ -31,15 +31,15 @@ type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t -let[@coq_struct "i"] rec ( --> ) i j = +let[@coq_struct "i_value"] rec ( --> ) i j = (* [i; i+1; ...; j] *) if Compare.Int.(i > j) then [] else i :: (succ i --> j) -let[@coq_struct "j"] rec ( <-- ) i j = +let[@coq_struct "j_value"] rec ( <-- ) i j = (* [j; j-1; ...; i] *) if Compare.Int.(i > j) then [] else j :: (i <-- pred j) -let[@coq_struct "i"] rec ( ---> ) i j = +let[@coq_struct "i_value"] rec ( ---> ) i j = (* [i; i+1; ...; j] *) if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j) diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 3c6607667005e..d627ad93e0ad5 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -422,7 +422,7 @@ let id x = x [@@inline] (* The following function pops n elements from the stack and push their reintroduction in the continuations stack. *) -let[@coq_struct "w"] rec kundip : +let[@coq_struct "w_value"] rec kundip : type a s e z c u d w b t. (a, s, e, z, c, u, d, w) stack_prefix_preservation_witness -> c -> @@ -633,7 +633,7 @@ let unpack ctxt ~ty ~bytes = a well-typed operation [f] under some prefix of the A-stack exploiting [w] to justify that the shape of the stack is preserved. *) -let[@coq_struct "n"] rec interp_stack_prefix_preserving_operation : +let[@coq_struct "n_value"] rec interp_stack_prefix_preserving_operation : type a s b t c u d w result. (a -> s -> (b * t) * result) -> (a, s, b, t, c, u, d, w) stack_prefix_preservation_witness -> diff --git a/src/proto_alpha/lib_protocol/seed_repr.ml b/src/proto_alpha/lib_protocol/seed_repr.ml index b9f6d85160c85..68e4e4452f0d2 100644 --- a/src/proto_alpha/lib_protocol/seed_repr.ml +++ b/src/proto_alpha/lib_protocol/seed_repr.ml @@ -153,7 +153,7 @@ let initial_nonce_hash_0 = hash initial_nonce_0 let deterministic_seed seed = nonce seed zero_bytes let initial_seeds ?initial_seed n = - let[@coq_struct "i"] rec loop acc elt i = + let[@coq_struct "i_value"] rec loop acc elt i = if Compare.Int.(i = 1) then List.rev (elt :: acc) else loop (elt :: acc) (deterministic_seed elt) (i - 1) in -- GitLab From 36efec08c4ff833e358ab637a02b57a7020f3a58 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 3 Dec 2021 22:09:44 +0100 Subject: [PATCH 023/105] Proto: LARGE CHANGE: translate the interpreter --- .../lib_protocol/script_interpreter.ml | 814 +++++++++++------- .../lib_protocol/script_interpreter.mli | 2 +- .../lib_protocol/script_interpreter_defs.ml | 77 +- .../michelson/test_interpretation.ml | 4 +- 4 files changed, 557 insertions(+), 340 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index a60ccc289428f..1d78daf85fe75 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -247,7 +247,7 @@ let () = evaluation rules depending on the continuation at stake. *) -let rec kmap_exit : +let[@coq_struct "gas"] rec kmap_exit : type a b c d e f g h m n o. (a, b, c, d, e, f, g, h, m, n, o) kmap_exit_type = fun mk g gas (body, xs, ys, yk) ks accu stack -> @@ -257,7 +257,8 @@ let rec kmap_exit : (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] -and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = +and[@coq_struct "gas"] kmap_enter : + type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = fun mk g gas (body, xs, ys) ks accu stack -> match xs with | [] -> (next [@ocaml.tailcall]) g gas ks ys (accu, stack) @@ -268,14 +269,16 @@ and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = (step [@ocaml.tailcall]) g gas body ks res stack [@@inline] -and klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type = +and[@coq_struct "gas"] klist_exit : + type a b c d i j. (a, b, c, d, i, j) klist_exit_type = fun mk g gas (body, xs, ys, len) ks accu stack -> let ks = mk (KList_enter_body (body, xs, accu :: ys, len, ks)) in let (accu, stack) = stack in (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] -and klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type = +and[@coq_struct "gas"] klist_enter : + type a b c d e j. (a, b, c, d, e, j) klist_enter_type = fun mk g gas (body, xs, ys, len) ks' accu stack -> match xs with | [] -> @@ -286,22 +289,23 @@ and klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type = (step [@ocaml.tailcall]) g gas body ks x (accu, stack) [@@inline] -and kloop_in_left : type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type - = +and[@coq_struct "gas"] kloop_in_left : + type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type = fun g gas ks0 ki ks' accu stack -> match accu with | L v -> (step [@ocaml.tailcall]) g gas ki ks0 v stack | R v -> (next [@ocaml.tailcall]) g gas ks' v stack [@@inline] -and kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type = +and[@coq_struct "gas"] kloop_in : + type a b c r f s. (a, b, c, r, f, s) kloop_in_type = fun g gas ks0 ki ks' accu stack -> let (accu', stack') = stack in if accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' else (next [@ocaml.tailcall]) g gas ks' accu' stack' [@@inline] -and kiter : type a b s r f. (a, b, s, r, f) kiter_type = +and[@coq_struct "gas"] kiter : type a b s r f. (a, b, s, r, f) kiter_type = fun mk g gas (body, xs) ks accu stack -> match xs with | [] -> (next [@ocaml.tailcall]) g gas ks accu stack @@ -310,7 +314,7 @@ and kiter : type a b s r f. (a, b, s, r, f) kiter_type = (step [@ocaml.tailcall]) g gas body ks x (accu, stack) [@@inline] -and next : +and[@coq_struct "function_parameter"] next : type a s r f. outdated_context * step_constants -> local_gas_counter -> @@ -322,34 +326,38 @@ and next : match consume_control gas ks0 with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match ks0 with - | KLog (ks, logger) -> + match[@coq_match_gadt] (ks0, accu, stack) with + | (KLog (ks, logger), _, _) -> (klog [@ocaml.tailcall]) logger g gas ks0 ks accu stack - | KNil -> Lwt.return (Ok (accu, stack, ctxt, gas)) - | KCons (k, ks) -> (step [@ocaml.tailcall]) g gas k ks accu stack - | KLoop_in (ki, ks') -> + | (KNil, (accu : r), (stack : f)) -> + Lwt.return (Ok (accu, stack, ctxt, gas)) + | (KCons (k, ks), _, _) -> (step [@ocaml.tailcall]) g gas k ks accu stack + | (KLoop_in (ki, ks'), (accu : bool), (stack : _ * _)) -> (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KReturn (stack', ks) -> (next [@ocaml.tailcall]) g gas ks accu stack' - | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack - | KLoop_in_left (ki, ks') -> + | (KReturn (stack', ks), _, _) -> + (next [@ocaml.tailcall]) g gas ks accu stack' + | (KMap_head (f, ks), _, _) -> + (next [@ocaml.tailcall]) g gas ks (f accu) stack + | (KLoop_in_left (ki, ks'), (accu : _ union), _) -> (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KUndip (x, ks) -> (next [@ocaml.tailcall]) g gas ks x (accu, stack) - | KIter (body, xs, ks) -> + | (KUndip (x, ks), _, _) -> + (next [@ocaml.tailcall]) g gas ks x (accu, stack) + | (KIter (body, xs, ks), _, _) -> let extra = (body, xs) in (kiter [@ocaml.tailcall]) id g gas extra ks accu stack - | KList_enter_body (body, xs, ys, len, ks) -> + | (KList_enter_body (body, xs, ys, len, ks), _, _) -> let extra = (body, xs, ys, len) in (klist_enter [@ocaml.tailcall]) id g gas extra ks accu stack - | KList_exit_body (body, xs, ys, len, ks) -> + | (KList_exit_body (body, xs, ys, len, ks), _, (stack : _ * _)) -> let extra = (body, xs, ys, len) in (klist_exit [@ocaml.tailcall]) id g gas extra ks accu stack - | KMap_enter_body (body, xs, ys, ks) -> + | (KMap_enter_body (body, xs, ys, ks), _, _) -> let extra = (body, xs, ys) in (kmap_enter [@ocaml.tailcall]) id g gas extra ks accu stack - | KMap_exit_body (body, xs, ys, yk, ks) -> + | (KMap_exit_body (body, xs, ys, yk, ks), _, (stack : _ * _)) -> let extra = (body, xs, ys, yk) in (kmap_exit [@ocaml.tailcall]) id g gas extra ks accu stack - | KView_exit (orig_step_constants, ks) -> + | (KView_exit (orig_step_constants, ks), _, _) -> let g = (fst g, orig_step_constants) in (next [@ocaml.tailcall]) g gas ks accu stack) @@ -366,10 +374,11 @@ and next : instructions. *) -and ilist_map : type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = +and[@coq_struct "gas"] ilist_map : + type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = fun log_if_needed g gas (body, k) ks accu stack -> let xs = accu.elements in - let ys = [] in + let ys = (([] [@coq_type_annotation]) : f list) in let len = accu.length in let ks = log_if_needed (KList_enter_body (body, xs, ys, len, KCons (k, ks))) @@ -378,7 +387,8 @@ and ilist_map : type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] -and ilist_iter : type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type = +and[@coq_struct "gas"] ilist_iter : + type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type = fun log_if_needed g gas (body, k) ks accu stack -> let xs = accu.elements in let ks = log_if_needed (KIter (body, xs, KCons (k, ks))) in @@ -386,7 +396,8 @@ and ilist_iter : type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type = (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] -and iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = +and[@coq_struct "gas"] iset_iter : + type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = fun log_if_needed g gas (body, k) ks accu stack -> let set = accu in let l = List.rev (Script_set.fold (fun e acc -> e :: acc) set []) in @@ -395,8 +406,8 @@ and iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] -and imap_map : type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type - = +and[@coq_struct "gas"] imap_map : + type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type = fun log_if_needed g gas (body, k) ks accu stack -> let map = accu in let xs = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in @@ -406,7 +417,8 @@ and imap_map : type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] -and imap_iter : type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = +and[@coq_struct "gas"] imap_iter : + type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = fun log_if_needed g gas (body, k) ks accu stack -> let map = accu in let l = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in @@ -415,7 +427,8 @@ and imap_iter : type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] -and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = +and[@coq_struct "gas"] imul_teznat : + type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = fun logger g gas (kinfo, k) ks accu stack -> let x = accu in let (y, stack) = stack in @@ -424,7 +437,8 @@ and imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = +and[@coq_struct "gas"] imul_nattez : + type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = fun logger g gas (kinfo, k) ks accu stack -> let y = accu in let (x, stack) = stack in @@ -433,7 +447,8 @@ and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = +and[@coq_struct "gas"] ilsl_nat : + type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = fun logger g gas (kinfo, k) ks accu stack -> let x = accu in let (y, stack) = stack in @@ -441,7 +456,8 @@ and ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack -and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = +and[@coq_struct "gas"] ilsr_nat : + type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = fun logger g gas (kinfo, k) ks accu stack -> let x = accu in let (y, stack) = stack in @@ -449,7 +465,7 @@ and ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack -and ifailwith : ifailwith_type = +and[@coq_struct "function_parameter"] ifailwith : ifailwith_type = { ifailwith = (fun logger (ctxt, _) gas kloc tv accu -> @@ -461,7 +477,8 @@ and ifailwith : ifailwith_type = get_log logger >>=? fun log -> fail (Reject (kloc, v, log))); } -and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = +and[@coq_struct "gas"] iexec : + type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = fun logger g gas k ks accu stack -> let arg = accu in let (code, stack) = stack in @@ -474,30 +491,41 @@ and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = let ks = KReturn (stack, KCons (k, ks)) in (step [@ocaml.tailcall]) g gas code ks arg (EmptyCell, EmptyCell) -and step : type a s b t r f. (a, s, b, t, r, f) step_type = +and[@coq_struct "function_parameter"] step : + type a s b t r f. (a, s, b, t, r, f) step_type = fun ((ctxt, sc) as g) gas i ks accu stack -> match consume_instr gas i accu stack with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match i with - | ILog (_, event, logger, k) -> + match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with + | (ILog (_, event, logger, k), _, _) -> (log [@ocaml.tailcall]) (logger, event) g gas k ks accu stack - | IHalt _ -> (next [@ocaml.tailcall]) g gas ks accu stack + | (IHalt _, _, _) -> (next [@ocaml.tailcall]) g gas ks accu stack (* stack ops *) - | IDrop (_, k) -> + | (IDrop (_, k), _, (stack : _ * _)) -> let (accu, stack) = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDup (_, k) -> (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) - | ISwap (_, k) -> + | (IDup (_, k), _, _) -> + (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) + | (ISwap (_, k), _, (stack : _ * _)) -> let (top, stack) = stack in (step [@ocaml.tailcall]) g gas k ks top (accu, stack) - | IConst (_, v, k) -> (step [@ocaml.tailcall]) g gas k ks v (accu, stack) + | (IConst (_, v, k), _, _) -> + (step [@ocaml.tailcall]) g gas k ks v (accu, stack) (* options *) - | ICons_some (_, k) -> + | (ICons_some (_, k), _, _) -> (step [@ocaml.tailcall]) g gas k ks (Some accu) stack - | ICons_none (_, k) -> - (step [@ocaml.tailcall]) g gas k ks None (accu, stack) - | IIf_none {branch_if_none; branch_if_some; k; _} -> ( + | (ICons_none (_, k), _, _) -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + (accu, stack) + | ( IIf_none {branch_if_none; branch_if_some; k; _}, + (accu : _ option), + (stack : _ * _) ) -> ( match accu with | None -> let (accu, stack) = stack in @@ -516,29 +544,53 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) v stack) - | IOpt_map {body; k; kinfo = _} -> ( + | (IOpt_map {body; k; kinfo = _}, (accu : _ option), _) -> ( match accu with - | None -> (step [@ocaml.tailcall]) g gas k ks None stack + | None -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack | Some v -> - let ks' = KMap_head (Option.some, KCons (k, ks)) in + let ks' = + KMap_head ((Option.some [@coq_type_annotation]), KCons (k, ks)) + in (step [@ocaml.tailcall]) g gas body ks' v stack) (* pairs *) - | ICons_pair (_, k) -> + | (ICons_pair (_, k), _, (stack : _ * _)) -> let (b, stack) = stack in (step [@ocaml.tailcall]) g gas k ks (accu, b) stack - | IUnpair (_, k) -> + | (IUnpair (_, k), (accu : _ * _), _) -> let (a, b) = accu in (step [@ocaml.tailcall]) g gas k ks a (b, stack) - | ICar (_, k) -> + | (ICar (_, k), (accu : _ * _), _) -> let (a, _) = accu in (step [@ocaml.tailcall]) g gas k ks a stack - | ICdr (_, k) -> + | (ICdr (_, k), (accu : _ * _), _) -> let (_, b) = accu in (step [@ocaml.tailcall]) g gas k ks b stack (* unions *) - | ICons_left (_, k) -> (step [@ocaml.tailcall]) g gas k ks (L accu) stack - | ICons_right (_, k) -> (step [@ocaml.tailcall]) g gas k ks (R accu) stack - | IIf_left {branch_if_left; branch_if_right; k; _} -> ( + | (ICons_left (_, k), _, _) -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (L accu [@coq_type_annotation]) + stack + | (ICons_right (_, k), _, _) -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (R accu [@coq_type_annotation]) + stack + | (IIf_left {branch_if_left; branch_if_right; k; _}, (accu : _ union), _) + -> ( match accu with | L v -> (step [@ocaml.tailcall]) @@ -557,15 +609,23 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = v stack) (* lists *) - | ICons_list (_, k) -> + | (ICons_list (_, k), _, (stack : _ * _)) -> let (tl, stack) = stack in let accu = Script_list.cons accu tl in (step [@ocaml.tailcall]) g gas k ks accu stack - | INil (_, k) -> + | (INil (_, k), _, _) -> let stack = (accu, stack) in let accu = Script_list.empty in - (step [@ocaml.tailcall]) g gas k ks accu stack - | IIf_cons {branch_if_cons; branch_if_nil; k; _} -> ( + (step [@ocaml.tailcall]) + g + gas + k + ks + (accu [@coq_implicit "(E := __INil_'b)"]) + stack + | ( IIf_cons {branch_if_cons; branch_if_nil; k; _}, + (accu : _ boxed_list), + (stack : _ * _) ) -> ( match accu.elements with | [] -> let (accu, stack) = stack in @@ -585,88 +645,105 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) hd (tl, stack)) - | IList_map (_, body, k) -> - (ilist_map [@ocaml.tailcall]) id g gas (body, k) ks accu stack - | IList_size (_, k) -> + | (IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _)) -> + (ilist_map [@ocaml.tailcall] [@coq_implicit "(f := __IList_map_'b)"]) + id + g + gas + (body, k) + ks + accu + stack + | (IList_size (_, k), (accu : _ boxed_list), _) -> let list = accu in let len = Script_int.(abs (of_int list.length)) in (step [@ocaml.tailcall]) g gas k ks len stack - | IList_iter (_, body, k) -> + | (IList_iter (_, body, k), (accu : _ boxed_list), (stack : _ * _)) -> (ilist_iter [@ocaml.tailcall]) id g gas (body, k) ks accu stack (* sets *) - | IEmpty_set (_, ty, k) -> - let res = Script_set.empty ty in + | (IEmpty_set (_, ty, k), _, _) -> + let res = (Script_set.empty [@coq_type_annotation]) ty in let stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_iter (_, body, k) -> + | (ISet_iter (_, body, k), (accu : _ set), (stack : _ * _)) -> (iset_iter [@ocaml.tailcall]) id g gas (body, k) ks accu stack - | ISet_mem (_, k) -> + | (ISet_mem (_, k), _, (stack : _ * _)) -> let (set, stack) = stack in let res = Script_set.mem accu set in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_update (_, k) -> + | (ISet_update (_, k), _, (stack : _ * (_ * _))) -> let (presence, (set, stack)) = stack in let res = Script_set.update accu presence set in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_size (_, k) -> + | (ISet_size (_, k), (accu : _ set), _) -> let res = Script_set.size accu in (step [@ocaml.tailcall]) g gas k ks res stack (* maps *) - | IEmpty_map (_, ty, k) -> - let res = Script_map.empty ty and stack = (accu, stack) in + | (IEmpty_map (_, ty, k), _, _) -> + let stack = (accu, stack) in + let res = (Script_map.empty [@coq_type_annotation]) ty in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_map (_, body, k) -> - (imap_map [@ocaml.tailcall]) id g gas (body, k) ks accu stack - | IMap_iter (_, body, k) -> + | (IMap_map (_, body, k), (accu : _ map), (stack : _ * _)) -> + (imap_map [@ocaml.tailcall] [@coq_implicit "(g := __IMap_map_'c)"]) + id + g + gas + (body, k) + ks + accu + stack + | (IMap_iter (_, body, k), (accu : _ map), (stack : _ * _)) -> (imap_iter [@ocaml.tailcall]) id g gas (body, k) ks accu stack - | IMap_mem (_, k) -> + | (IMap_mem (_, k), _, (stack : _ * _)) -> let (map, stack) = stack in let res = Script_map.mem accu map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_get (_, k) -> + | (IMap_get (_, k), _, (stack : _ * _)) -> let (map, stack) = stack in let res = Script_map.get accu map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_update (_, k) -> + | (IMap_update (_, k), _, (stack : _ * (_ * _))) -> let (v, (map, stack)) = stack in let key = accu in let res = Script_map.update key v map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_get_and_update (_, k) -> + | (IMap_get_and_update (_, k), _, (stack : _ * (_ * _))) -> let key = accu in let (v, (map, rest)) = stack in let map' = Script_map.update key v map in let v' = Script_map.get key map in (step [@ocaml.tailcall]) g gas k ks v' (map', rest) - | IMap_size (_, k) -> + | (IMap_size (_, k), (accu : _ map), _) -> let res = Script_map.size accu in (step [@ocaml.tailcall]) g gas k ks res stack (* Big map operations *) - | IEmpty_big_map (_, tk, tv, k) -> - let ebm = Script_ir_translator.empty_big_map tk tv in + | (IEmpty_big_map (_, tk, tv, k), _, _) -> + let ebm = + (Script_ir_translator.empty_big_map [@coq_type_annotation]) tk tv + in (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack) - | IBig_map_mem (_, k) -> + | (IBig_map_mem (_, k), _, (stack : _ * _)) -> let (map, stack) = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.big_map_mem ctxt key map ) >>=? fun (res, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBig_map_get (_, k) -> + | (IBig_map_get (_, k), _, (stack : _ * _)) -> let (map, stack) = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.big_map_get ctxt key map ) >>=? fun (res, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBig_map_update (_, k) -> + | (IBig_map_update (_, k), _, (stack : _ * (_ * _))) -> let key = accu in let (maybe_value, (map, stack)) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.big_map_update ctxt key maybe_value map ) >>=? fun (big_map, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks big_map stack - | IBig_map_get_and_update (_, k) -> + | (IBig_map_get_and_update (_, k), _, (stack : _ * (_ * _))) -> let key = accu in let (v, (map, stack)) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> @@ -674,33 +751,41 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = >>=? fun ((v', map'), ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks v' (map', stack) (* timestamp operations *) - | IAdd_seconds_to_timestamp (_, k) -> + | ( IAdd_seconds_to_timestamp (_, k), + (accu : _ Script_int.num), + (stack : _ * _) ) -> let n = accu in let (t, stack) = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | IAdd_timestamp_to_seconds (_, k) -> + | ( IAdd_timestamp_to_seconds (_, k), + (accu : Script_timestamp.t), + (stack : _ * _) ) -> let t = accu in let (n, stack) = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | ISub_timestamp_seconds (_, k) -> + | ( ISub_timestamp_seconds (_, k), + (accu : Script_timestamp.t), + (stack : _ * _) ) -> let t = accu in let (s, stack) = stack in let result = Script_timestamp.sub_delta t s in (step [@ocaml.tailcall]) g gas k ks result stack - | IDiff_timestamps (_, k) -> + | (IDiff_timestamps (_, k), (accu : Script_timestamp.t), (stack : _ * _)) + -> let t1 = accu in let (t2, stack) = stack in let result = Script_timestamp.diff t1 t2 in (step [@ocaml.tailcall]) g gas k ks result stack (* string operations *) - | IConcat_string_pair (_, k) -> + | (IConcat_string_pair (_, k), (accu : Script_string.t), (stack : _ * _)) + -> let x = accu in let (y, stack) = stack in let s = Script_string.concat_pair x y in (step [@ocaml.tailcall]) g gas k ks s stack - | IConcat_string (_, k) -> + | (IConcat_string (_, k), (accu : _ boxed_list), _) -> let ss = accu in (* The cost for this fold_left has been paid upfront *) let total_length = @@ -712,7 +797,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = consume gas (Interp_costs.concat_string total_length) >>?= fun gas -> let s = Script_string.concat ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack - | ISlice_string (_, k) -> + | ( ISlice_string (_, k), + (accu : _ Script_int.num), + (stack : _ * (Script_string.t * _)) ) -> let offset = accu in let (length, (s, stack)) = stack in let s_length = Z.of_int (Script_string.length s) in @@ -722,18 +809,25 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Script_string.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks None stack - | IString_size (_, k) -> + else + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack + | (IString_size (_, k), (accu : Script_string.t), _) -> let s = accu in let result = Script_int.(abs (of_int (Script_string.length s))) in (step [@ocaml.tailcall]) g gas k ks result stack (* bytes operations *) - | IConcat_bytes_pair (_, k) -> + | (IConcat_bytes_pair (_, k), (accu : bytes), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let s = Bytes.cat x y in (step [@ocaml.tailcall]) g gas k ks s stack - | IConcat_bytes (_, k) -> + | (IConcat_bytes (_, k), (accu : _ boxed_list), _) -> let ss = accu in (* The cost for this fold_left has been paid upfront *) let total_length = @@ -745,7 +839,8 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = consume gas (Interp_costs.concat_string total_length) >>?= fun gas -> let s = Bytes.concat Bytes.empty ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack - | ISlice_bytes (_, k) -> + | (ISlice_bytes (_, k), (accu : _ Script_int.num), (stack : _ * (_ * _))) + -> let offset = accu in let (length, (s, stack)) = stack in let s_length = Z.of_int (Bytes.length s) in @@ -755,91 +850,100 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Bytes.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks None stack - | IBytes_size (_, k) -> + else + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack + | (IBytes_size (_, k), (accu : bytes), _) -> let s = accu in let result = Script_int.(abs (of_int (Bytes.length s))) in (step [@ocaml.tailcall]) g gas k ks result stack (* currency operations *) - | IAdd_tez (_, k) -> + | (IAdd_tez (_, k), (accu : Tez.t), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in Tez.(x +? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_tez (_, k) -> + | (ISub_tez (_, k), (accu : Tez.t), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Tez.sub_opt x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_tez_legacy (_, k) -> + | (ISub_tez_legacy (_, k), (accu : Tez.t), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in Tez.(x -? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_teznat (kinfo, k) -> + | (IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _)) + -> imul_teznat None g gas (kinfo, k) ks accu stack - | IMul_nattez (kinfo, k) -> + | (IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _)) + -> imul_nattez None g gas (kinfo, k) ks accu stack (* boolean operations *) - | IOr (_, k) -> + | (IOr (_, k), (accu : bool), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in (step [@ocaml.tailcall]) g gas k ks (x || y) stack - | IAnd (_, k) -> + | (IAnd (_, k), (accu : bool), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in (step [@ocaml.tailcall]) g gas k ks (x && y) stack - | IXor (_, k) -> + | (IXor (_, k), (accu : bool), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Compare.Bool.(x <> y) in (step [@ocaml.tailcall]) g gas k ks res stack - | INot (_, k) -> + | (INot (_, k), (accu : bool), _) -> let x = accu in (step [@ocaml.tailcall]) g gas k ks (not x) stack (* integer operations *) - | IIs_nat (_, k) -> + | (IIs_nat (_, k), (accu : _ Script_int.num), _) -> let x = accu in let res = Script_int.is_nat x in (step [@ocaml.tailcall]) g gas k ks res stack - | IAbs_int (_, k) -> + | (IAbs_int (_, k), (accu : _ Script_int.num), _) -> let x = accu in let res = Script_int.abs x in (step [@ocaml.tailcall]) g gas k ks res stack - | IInt_nat (_, k) -> + | (IInt_nat (_, k), (accu : _ Script_int.num), _) -> let x = accu in let res = Script_int.int x in (step [@ocaml.tailcall]) g gas k ks res stack - | INeg (_, k) -> + | (INeg (_, k), (accu : _ Script_int.num), _) -> let x = accu in let res = Script_int.neg x in (step [@ocaml.tailcall]) g gas k ks res stack - | IAdd_int (_, k) -> + | (IAdd_int (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Script_int.add x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAdd_nat (_, k) -> + | (IAdd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Script_int.add_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_int (_, k) -> + | (ISub_int (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Script_int.sub x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_int (_, k) -> + | (IMul_int (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Script_int.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_nat (_, k) -> + | (IMul_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Script_int.mul_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_teznat (_, k) -> + | (IEdiv_teznat (_, k), (accu : Tez.t), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let x = Script_int.of_int64 (Tez.to_mutez x) in @@ -857,7 +961,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | _ -> assert false) in (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_tez (_, k) -> + | (IEdiv_tez (_, k), (accu : Tez.t), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in @@ -874,44 +978,54 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = | Some r -> Some (q, r))) in (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_int (_, k) -> + | ( IEdiv_int (_, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> let x = accu in let (y, stack) = stack in let res = Script_int.ediv x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_nat (_, k) -> + | (IEdiv_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Script_int.ediv_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ILsl_nat (kinfo, k) -> ilsl_nat None g gas (kinfo, k) ks accu stack - | ILsr_nat (kinfo, k) -> ilsr_nat None g gas (kinfo, k) ks accu stack - | IOr_nat (_, k) -> + | ( ILsl_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> + ilsl_nat None g gas (kinfo, k) ks accu stack + | ( ILsr_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> + ilsr_nat None g gas (kinfo, k) ks accu stack + | (IOr_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Script_int.logor x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_nat (_, k) -> + | (IAnd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_int_nat (_, k) -> + | (IAnd_int_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IXor_nat (_, k) -> + | (IXor_nat (_, k), (accu : _ Script_int.num), (stack : _ * _)) -> let x = accu in let (y, stack) = stack in let res = Script_int.logxor x y in (step [@ocaml.tailcall]) g gas k ks res stack - | INot_int (_, k) -> + | (INot_int (_, k), (accu : _ Script_int.num), _) -> let x = accu in let res = Script_int.lognot x in (step [@ocaml.tailcall]) g gas k ks res stack (* control *) - | IIf {branch_if_true; branch_if_false; k; _} -> + | ( IIf {branch_if_true; branch_if_false; k; _}, + (accu : bool), + (stack : _ * _) ) -> let (res, stack) = stack in if accu then (step [@ocaml.tailcall]) @@ -929,30 +1043,31 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) res stack - | ILoop (_, body, k) -> + | (ILoop (_, body, k), _, _) -> let ks = KLoop_in (body, KCons (k, ks)) in (next [@ocaml.tailcall]) g gas ks accu stack - | ILoop_left (_, bl, br) -> + | (ILoop_left (_, bl, br), _, _) -> let ks = KLoop_in_left (bl, KCons (br, ks)) in (next [@ocaml.tailcall]) g gas ks accu stack - | IDip (_, b, k) -> + | (IDip (_, b, k), _, (stack : _ * _)) -> let ign = accu in let ks = KUndip (ign, KCons (k, ks)) in let (accu, stack) = stack in (step [@ocaml.tailcall]) g gas b ks accu stack - | IExec (_, k) -> iexec None g gas k ks accu stack - | IApply (_, capture_ty, k) -> + | (IExec (_, k), _, (stack : _ lambda * _)) -> + iexec None g gas k ks accu stack + | (IApply (_, capture_ty, k), _, (stack : _ lambda * _)) -> let capture = accu in let (lam, stack) = stack in apply ctxt gas capture_ty capture lam >>=? fun (lam', ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks lam' stack - | ILambda (_, lam, k) -> + | (ILambda (_, lam, k), _, _) -> (step [@ocaml.tailcall]) g gas k ks lam (accu, stack) - | IFailwith (_, kloc, tv) -> + | (IFailwith (_, kloc, tv), _, _) -> let {ifailwith} = ifailwith in ifailwith None g gas kloc tv accu (* comparison *) - | ICompare (_, ty, k) -> + | (ICompare (_, ty, k), _, (stack : _ * _)) -> let a = accu in let (b, stack) = stack in let r = @@ -960,53 +1075,53 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) g gas k ks r stack (* comparators *) - | IEq (_, k) -> + | (IEq (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a = 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | INeq (_, k) -> + | (INeq (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a <> 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | ILt (_, k) -> + | (ILt (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a < 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | ILe (_, k) -> + | (ILe (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a <= 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | IGt (_, k) -> + | (IGt (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a > 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | IGe (_, k) -> + | (IGe (_, k), (accu : _ Script_int.num), _) -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a >= 0) in (step [@ocaml.tailcall]) g gas k ks a stack (* packing *) - | IPack (_, ty, k) -> + | (IPack (_, ty, k), _, _) -> let value = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.pack_data ctxt ty value ) >>=? fun (bytes, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack - | IUnpack (_, ty, k) -> + | (IUnpack (_, ty, k), (accu : bytes), _) -> let bytes = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> - unpack ctxt ~ty ~bytes ) + (unpack [@coq_type_annotation]) ctxt ~ty ~bytes ) >>=? fun (opt, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks opt stack - | IAddress (_, k) -> + | (IAddress (_, k), (accu : _ Script_typed_ir.typed_contract), _) -> let (Typed_contract {address; _}) = accu in (step [@ocaml.tailcall]) g gas k ks address stack - | IContract (kinfo, t, entrypoint, k) -> ( + | (IContract (kinfo, t, entrypoint, k), (accu : address), _) -> ( let addr = accu in let entrypoint_opt = if Entrypoint.is_default addr.entrypoint then Some entrypoint @@ -1026,8 +1141,16 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in let accu = maybe_contract in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | ITransfer_tokens (kinfo, k) -> + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) + | (ITransfer_tokens (kinfo, k), _, (stack : _ * (_ typed_contract * _))) + -> let p = accu in let (amount, (Typed_contract {arg_ty; address}, stack)) = stack in let {destination; entrypoint} = address in @@ -1042,7 +1165,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = entrypoint >>=? fun (accu, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | IImplicit_account (_, k) -> + | (IImplicit_account (_, k), (accu : public_key_hash), _) -> let key = accu in let arg_ty = unit_t in let address = @@ -1053,7 +1176,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in let res = Typed_contract {arg_ty; address} in (step [@ocaml.tailcall]) g gas k ks res stack - | IView (_, View_signature {name; input_ty; output_ty}, k) -> ( + | ( IView (_, View_signature {name; input_ty; output_ty}, k), + _, + (stack : address * _) ) -> ( let input = accu in let (addr, stack) = stack in let c = addr.destination in @@ -1073,8 +1198,15 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = ~allow_forged_in_storage:true ctxt script - >>=? fun ( Ex_script (Script {storage; storage_type; views; _}), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_script + (Script + { + storage; + storage_type; + views; + _; + }), + ctxt ) -> Gas.consume ctxt (Interp_costs.view_get name views) >>?= fun ctxt -> match Script_map.get name views with @@ -1093,7 +1225,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (Micheline.strip_locations view.view_code, [])) view_result >>=? fun (Ex_view f, ctxt) -> - match f with + match[@coq_match_with_default] f with | Lam ( { kloc; @@ -1124,7 +1256,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (return_none [@ocaml.tailcall]) ctxt | Ok (Eq, Eq) -> ( let kkinfo = kinfo_of_kinstr k in - match kkinfo.kstack_ty with + match[@coq_match_with_default] + kkinfo.kstack_ty + with | Item_t (_, s) -> let kstack_ty = Item_t (output_ty, s) in let kkinfo = {kkinfo with kstack_ty} in @@ -1155,7 +1289,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = (input, storage) (EmptyCell, EmptyCell)))))) | Tx_rollup _ -> (return_none [@ocaml.tailcall]) ctxt) - | ICreate_contract {storage_type; code; k; kinfo = _} -> + | ( ICreate_contract {storage_type; code; k; kinfo = _}, + (accu : public_key_hash option), + (stack : _ * (_ * _)) ) -> (* Removed the instruction's arguments manager, spendable and delegatable *) let delegate = accu in let (credit, (init, stack)) = stack in @@ -1166,24 +1302,31 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = stack ) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | ISet_delegate (_, k) -> + | (ISet_delegate (_, k), (accu : public_key_hash option), _) -> let delegate = accu in let operation = Delegation delegate in let ctxt = update_context gas ctxt in fresh_internal_nonce ctxt >>?= fun (ctxt, nonce) -> let piop = Internal_operation {source = sc.self; operation; nonce} in - let res = {piop; lazy_storage_diff = None} in + let res = + { + piop; + lazy_storage_diff = + (None [@coq_type_annotation] : Lazy_storage.diffs option); + } + in let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBalance (_, k) -> + | (IBalance (_, k), _, _) -> let ctxt = update_context gas ctxt in let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks sc.balance (accu, stack) - | ILevel (_, k) -> + | (ILevel (_, k), _, _) -> (step [@ocaml.tailcall]) g gas k ks sc.level (accu, stack) - | INow (_, k) -> (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) - | IMin_block_time (_, k) -> + | (INow (_, k), _, _) -> + (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) + | (IMin_block_time (_, k), _, _) -> let ctxt = update_context gas ctxt in let min_block_time = Alpha_context.Constants.minimal_block_delay ctxt @@ -1193,48 +1336,49 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in let new_stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks min_block_time new_stack - | ICheck_signature (_, k) -> + | (ICheck_signature (_, k), (accu : public_key), (stack : _ * (_ * _))) -> let key = accu in let (signature, (message, stack)) = stack in let res = Script_signature.check key signature message in (step [@ocaml.tailcall]) g gas k ks res stack - | IHash_key (_, k) -> + | (IHash_key (_, k), (accu : public_key), _) -> let key = accu in let res = Signature.Public_key.hash key in (step [@ocaml.tailcall]) g gas k ks res stack - | IBlake2b (_, k) -> + | (IBlake2b (_, k), (accu : bytes), _) -> let bytes = accu in let hash = Raw_hashes.blake2b bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha256 (_, k) -> + | (ISha256 (_, k), (accu : bytes), _) -> let bytes = accu in let hash = Raw_hashes.sha256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha512 (_, k) -> + | (ISha512 (_, k), (accu : bytes), _) -> let bytes = accu in let hash = Raw_hashes.sha512 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISource (_, k) -> + | (ISource (_, k), _, _) -> let destination : Destination.t = Contract sc.payer in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISender (_, k) -> + | (ISender (_, k), _, _) -> let destination : Destination.t = Contract sc.source in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf (_, ty, entrypoint, k) -> + | (ISelf (_, ty, entrypoint, k), _, _) -> let destination : Destination.t = Contract sc.self in let address = {destination; entrypoint} in let res = Typed_contract {arg_ty = ty; address} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf_address (_, k) -> + | (ISelf_address (_, k), _, _) -> let destination : Destination.t = Contract sc.self in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | IAmount (_, k) -> - let accu = sc.amount and stack = (accu, stack) in + | (IAmount (_, k), _, _) -> + let stack = (accu, stack) in + let accu = sc.amount in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDig (_, _n, n', k) -> + | (IDig (_, _n, n', k), _, _) -> let ((accu, stack), x) = interp_stack_prefix_preserving_operation (fun v stack -> (stack, v)) @@ -1242,9 +1386,10 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = accu stack in - let accu = x and stack = (accu, stack) in + let stack = ((accu, stack) [@coq_type_annotation]) in + let accu = x in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDug (_, _n, n', k) -> + | (IDug (_, _n, n', k), _, (stack : _ * _)) -> let v = accu in let (accu, stack) = stack in let ((accu, stack), ()) = @@ -1254,34 +1399,44 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = accu stack in - (step [@ocaml.tailcall]) g gas k ks accu stack - | IDipn (_, _n, n', b, k) -> - let (accu, stack, restore_prefix) = kundip n' accu stack k in + (step [@ocaml.tailcall]) + g + gas + k + ks + (accu [@coq_type_annotation]) + (stack [@coq_type_annotation]) + | (IDipn (_, _n, n', b, k), _, _) -> + let (accu, stack, restore_prefix) = + (kundip [@coq_type_annotation]) n' accu stack k + in let ks = KCons (restore_prefix, ks) in (step [@ocaml.tailcall]) g gas b ks accu stack - | IDropn (_, _n, n', k) -> + | (IDropn (_, _n, n', k), _, _) -> let stack = - let rec aux : + let[@coq_struct "w_value"] rec aux : type a s b t. (b, t, b, t, a, s, a, s) stack_prefix_preservation_witness -> a -> s -> b * t = fun w accu stack -> - match w with - | KRest -> (accu, stack) - | KPrefix (_, w) -> + match[@coq_match_gadt] (w, accu, stack) with + | (KRest, (accu : b), (stack : t)) -> (accu, stack) + | (KPrefix (_, w), _, (stack : _ * _)) -> let (accu, stack) = stack in aux w accu stack in - aux n' accu stack + (aux [@coq_type_annotation]) n' accu stack in let (accu, stack) = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | ISapling_empty_state (_, memo_size, k) -> + | (ISapling_empty_state (_, memo_size, k), _, _) -> let state = Sapling.empty_state ~memo_size () in (step [@ocaml.tailcall]) g gas k ks state (accu, stack) - | ISapling_verify_update (_, k) -> ( + | ( ISapling_verify_update (_, k), + (accu : Sapling.transaction), + (stack : _ * _) ) -> ( let transaction = accu in let (state, stack) = stack in let address = Contract.to_b58check sc.self in @@ -1301,7 +1456,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | ISapling_verify_update_deprecated (_, k) -> ( + | ( ISapling_verify_update_deprecated (_, k), + (accu : Sapling_repr.legacy_transaction), + (stack : _ * _) ) -> ( let transaction = accu in let (state, stack) = stack in let address = Contract.to_b58check sc.self in @@ -1317,179 +1474,213 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = let state = Some (Script_int.of_int64 balance, state) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | IChainId (_, k) -> - let accu = Script_chain_id.make sc.chain_id - and stack = (accu, stack) in + | (IChainId (_, k), _, _) -> + let stack = (accu, stack) in + let accu = Script_chain_id.make sc.chain_id in (step [@ocaml.tailcall]) g gas k ks accu stack - | INever _ -> ( match accu with _ -> .) - | IVoting_power (_, k) -> + | (INever _, _, _) -> . + | (IVoting_power (_, k), (accu : public_key_hash), _) -> let key_hash = accu in let ctxt = update_context gas ctxt in Vote.get_voting_power ctxt key_hash >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks power stack - | ITotal_voting_power (_, k) -> + | (ITotal_voting_power (_, k), _, _) -> let ctxt = update_context gas ctxt in Vote.get_total_voting_power ctxt >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks power (accu, stack) - | IKeccak (_, k) -> + | (IKeccak (_, k), (accu : bytes), _) -> let bytes = accu in let hash = Raw_hashes.keccak256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha3 (_, k) -> + | (ISha3 (_, k), (accu : bytes), _) -> let bytes = accu in let hash = Raw_hashes.sha3_256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | IAdd_bls12_381_g1 (_, k) -> + | ( IAdd_bls12_381_g1 (_, k), + (accu : Script_bls.G1.t), + (stack : Script_bls.G1.t * _) ) -> let x = accu in let (y, stack) = stack in let accu = Script_bls.G1.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_g2 (_, k) -> + | ( IAdd_bls12_381_g2 (_, k), + (accu : Script_bls.G2.t), + (stack : Script_bls.G2.t * _) ) -> let x = accu in let (y, stack) = stack in let accu = Script_bls.G2.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_fr (_, k) -> + | ( IAdd_bls12_381_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : Script_bls.Fr.t * _) ) -> let x = accu in let (y, stack) = stack in let accu = Script_bls.Fr.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g1 (_, k) -> + | ( IMul_bls12_381_g1 (_, k), + (accu : Script_bls.G1.t), + (stack : Script_bls.Fr.t * _) ) -> let x = accu in let (y, stack) = stack in let accu = Script_bls.G1.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g2 (_, k) -> + | ( IMul_bls12_381_g2 (_, k), + (accu : Script_bls.G2.t), + (stack : Script_bls.Fr.t * _) ) -> let x = accu in let (y, stack) = stack in let accu = Script_bls.G2.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr (_, k) -> + | ( IMul_bls12_381_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : Script_bls.Fr.t * _) ) -> let x = accu in let (y, stack) = stack in let accu = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr_z (_, k) -> + | ( IMul_bls12_381_fr_z (_, k), + (accu : _ Script_int.num), + (stack : Script_bls.Fr.t * _) ) -> let x = accu in let (y, stack) = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_bls12_381_z_fr (_, k) -> + | ( IMul_bls12_381_z_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : _ Script_int.num * _) ) -> let y = accu in let (x, stack) = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IInt_bls12_381_fr (_, k) -> + | (IInt_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _) -> let x = accu in let res = Script_int.of_zint (Script_bls.Fr.to_z x) in (step [@ocaml.tailcall]) g gas k ks res stack - | INeg_bls12_381_g1 (_, k) -> + | (INeg_bls12_381_g1 (_, k), (accu : Script_bls.G1.t), _) -> let x = accu in let accu = Script_bls.G1.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | INeg_bls12_381_g2 (_, k) -> + | (INeg_bls12_381_g2 (_, k), (accu : Script_bls.G2.t), _) -> let x = accu in let accu = Script_bls.G2.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | INeg_bls12_381_fr (_, k) -> + | (INeg_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _) -> let x = accu in let accu = Script_bls.Fr.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | IPairing_check_bls12_381 (_, k) -> + | (IPairing_check_bls12_381 (_, k), (accu : _ boxed_list), _) -> let pairs = accu in let check = Script_bls.pairing_check pairs.elements in (step [@ocaml.tailcall]) g gas k ks check stack - | IComb (_, _, witness, k) -> - let rec aux : + | (IComb (_, _, witness, k), _, _) -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) comb_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | (Comb_one, stack) -> stack - | (Comb_succ witness', (a, tl)) -> - let (b, tl') = aux witness' tl in - ((a, b), tl') + match[@coq_match_gadt] (witness, stack) with + | (Comb_one, (stack : after)) -> stack + | (Comb_succ witness', (stack : _ * _)) -> + let (a, tl) = stack in + let (b, tl') = (aux [@coq_type_annotation]) witness' tl in + ((((a, b), tl') [@coq_cast]) : after) in - let stack = aux witness (accu, stack) in + let stack = (aux [@coq_type_annotation]) witness (accu, stack) in let (accu, stack) = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IUncomb (_, _, witness, k) -> - let rec aux : + | (IUncomb (_, _, witness, k), _, _) -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) uncomb_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | (Uncomb_one, stack) -> stack - | (Uncomb_succ witness', ((a, b), tl)) -> (a, aux witness' (b, tl)) + match[@coq_match_gadt] (witness, stack) with + | (Uncomb_one, (stack : after)) -> stack + | (Uncomb_succ witness', (stack : (_ * _) * _)) -> + let ((a, b), tl) = stack in + (((a, (aux [@coq_type_annotation]) witness' (b, tl)) + [@coq_cast]) + : after) in - let stack = aux witness (accu, stack) in + let stack = (aux [@coq_type_annotation]) witness (accu, stack) in let (accu, stack) = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IComb_get (_, _, witness, k) -> + | (IComb_get (_, _, witness, k), _, _) -> let comb = accu in - let rec aux : + let[@coq_struct "witness"] rec aux : type before after. (before, after) comb_get_gadt_witness -> before -> after = fun witness comb -> - match (witness, comb) with - | (Comb_get_zero, v) -> v - | (Comb_get_one, (a, _)) -> a - | (Comb_get_plus_two witness', (_, b)) -> aux witness' b + match[@coq_match_gadt] (witness, comb) with + | (Comb_get_zero, (v : after)) -> v + | (Comb_get_one, (comb : after * _)) -> + let (a, _) = comb in + a + | (Comb_get_plus_two witness', (comb : _ * _)) -> + let (_, b) = comb in + aux witness' b in - let accu = aux witness comb in + let accu = (aux [@coq_type_annotation]) witness comb in (step [@ocaml.tailcall]) g gas k ks accu stack - | IComb_set (_, _, witness, k) -> + | (IComb_set (_, _, witness, k), _, (stack : _ * _)) -> let value = accu in let (comb, stack) = stack in - let rec aux : + let[@coq_struct "witness"] rec aux : type value before after. (value, before, after) comb_set_gadt_witness -> value -> before -> after = fun witness value item -> - match (witness, item) with - | (Comb_set_zero, _) -> value - | (Comb_set_one, (_hd, tl)) -> (value, tl) - | (Comb_set_plus_two witness', (hd, tl)) -> - (hd, aux witness' value tl) + match[@coq_match_gadt] (witness, value, item) with + | (Comb_set_zero, (value : after), _) -> value + | (Comb_set_one, _, (item : _ * _)) -> + let (_hd, tl) = item in + (((value, tl) [@coq_cast]) : after) + | (Comb_set_plus_two witness', _, (item : _ * _)) -> + let (hd, tl) = item in + (((hd, (aux [@coq_type_annotation]) witness' value tl) + [@coq_cast]) + : after) in - let accu = aux witness value comb in + let accu = (aux [@coq_type_annotation]) witness value comb in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDup_n (_, _, witness, k) -> - let rec aux : + | (IDup_n (_, _, witness, k), _, _) -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) dup_n_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | (Dup_n_zero, (a, _)) -> a - | (Dup_n_succ witness', (_, tl)) -> aux witness' tl + match[@coq_match_gadt] (witness, stack) with + | (Dup_n_zero, (stack : after * _)) -> + let (a, _) = stack in + a + | (Dup_n_succ witness', (stack : _ * _)) -> + let (_, tl) = stack in + aux witness' tl in let stack = (accu, stack) in - let accu = aux witness stack in + let accu = (aux [@coq_type_annotation]) witness stack in (step [@ocaml.tailcall]) g gas k ks accu stack (* Tickets *) - | ITicket (_, k) -> + | (ITicket (_, k), _, (stack : _ * _)) -> let contents = accu in let (amount, stack) = stack in let ticketer = sc.self in let accu = {ticketer; contents; amount} in (step [@ocaml.tailcall]) g gas k ks accu stack - | IRead_ticket (_, k) -> + | (IRead_ticket (_, k), (accu : _ ticket), _) -> let {ticketer; contents; amount} = accu in let stack = (accu, stack) in let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in let accu = (addr, (contents, amount)) in (step [@ocaml.tailcall]) g gas k ks accu stack - | ISplit_ticket (_, k) -> + | (ISplit_ticket (_, k), (accu : _ ticket), (stack : (_ * _) * _)) -> let ticket = accu in let ((amount_a, amount_b), stack) = stack in let result = @@ -1503,7 +1694,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IJoin_tickets (_, contents_ty, k) -> + | (IJoin_tickets (_, contents_ty, k), (accu : _ ticket * _ ticket), _) -> let (ticket_a, ticket_b) = accu in let result = if @@ -1524,7 +1715,9 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IOpen_chest (_, k) -> + | ( IOpen_chest (_, k), + (accu : Script_timelock.chest_key), + (stack : Script_timelock.chest * (_ Script_int.num * _)) ) -> let open Timelock in let chest_key = accu in let (chest, (time_z, stack)) = stack in @@ -1566,7 +1759,7 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = that starts the evaluation. *) -and log : +and[@coq_struct "function_parameter"] log : type a s b t r f. logger * logging_event -> (a, s, b, t, r, f) step_type = fun (logger, event) ((ctxt, _) as g) gas k ks accu stack -> (match (k, event) with @@ -1575,44 +1768,62 @@ and log : | (_, LogExit prev_kinfo) -> log_exit logger ctxt gas prev_kinfo k accu stack) ; let k = log_next_kinstr logger k in let with_log k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match k with - | IList_map (_, body, k) -> - (ilist_map [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack - | IList_iter (_, body, k) -> + match[@coq_match_gadt] (k, accu, stack) with + | (IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _)) -> + (ilist_map [@ocaml.tailcall] [@coq_implicit "(f := __IList_map_'b2)"]) + with_log + g + gas + (body, k) + ks + accu + stack + | (IList_iter (_, body, k), (accu : _ boxed_list), (stack : _ * _)) -> (ilist_iter [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack - | ISet_iter (_, body, k) -> + | (ISet_iter (_, body, k), (accu : _ set), (stack : _ * _)) -> (iset_iter [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack - | IMap_map (_, body, k) -> - (imap_map [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack - | IMap_iter (_, body, k) -> + | (IMap_map (_, body, k), (accu : _ map), (stack : _ * _)) -> + (imap_map [@ocaml.tailcall] [@coq_implicit "(g := __IMap_map_'c2)"]) + with_log + g + gas + (body, k) + ks + accu + stack + | (IMap_iter (_, body, k), (accu : _ map), (stack : _ * _)) -> (imap_iter [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack - | ILoop (_, body, k) -> + | (ILoop (_, body, k), _, _) -> let ks = with_log (KLoop_in (body, KCons (k, ks))) in (next [@ocaml.tailcall]) g gas ks accu stack - | ILoop_left (_, bl, br) -> + | (ILoop_left (_, bl, br), _, _) -> let ks = with_log (KLoop_in_left (bl, KCons (br, ks))) in (next [@ocaml.tailcall]) g gas ks accu stack - | IMul_teznat (kinfo, k) -> + | (IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _)) -> let extra = (kinfo, k) in (imul_teznat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | IMul_nattez (kinfo, k) -> + | (IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _)) -> let extra = (kinfo, k) in (imul_nattez [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | ILsl_nat (kinfo, k) -> + | ( ILsl_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> let extra = (kinfo, k) in (ilsl_nat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | ILsr_nat (kinfo, k) -> + | ( ILsr_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> let extra = (kinfo, k) in (ilsr_nat [@ocaml.tailcall]) (Some logger) g gas extra ks accu stack - | IFailwith (_, kloc, tv) -> + | (IFailwith (_, kloc, tv), _, _) -> let {ifailwith} = ifailwith in (ifailwith [@ocaml.tailcall]) (Some logger) g gas kloc tv accu - | IExec (_, k) -> + | (IExec (_, k), _, (stack : _ lambda * _)) -> (iexec [@ocaml.tailcall]) (Some logger) g gas k ks accu stack | _ -> (step [@ocaml.tailcall]) g gas k (with_log ks) accu stack [@@inline] -and klog : +and[@coq_struct "gas"] klog : type a s r f. logger -> outdated_context * step_constants -> @@ -1626,51 +1837,52 @@ and klog : (match ks with KLog _ -> () | _ -> log_control logger ks) ; let enable_log ki = log_kinstr logger ki in let mk k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match ks with - | KCons (ki, ks') -> + match[@coq_match_gadt] (ks, accu, stack) with + | (KCons (ki, ks'), _, _) -> let log = enable_log ki in let ks = mk ks' in (step [@ocaml.tailcall]) g gas log ks accu stack - | KNil -> (next [@ocaml.tailcall]) g gas ks accu stack - | KLoop_in (ki, ks') -> + | (KNil, _, _) -> (next [@ocaml.tailcall]) g gas ks accu stack + | (KLoop_in (ki, ks'), (accu : bool), (stack : _ * _)) -> let ks' = mk ks' in let ki = enable_log ki in (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KReturn (stack', ks') -> + | (KReturn (stack', ks'), _, _) -> let ks' = mk ks' in let ks = KReturn (stack', ks') in (next [@ocaml.tailcall]) g gas ks accu stack - | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack - | KLoop_in_left (ki, ks') -> + | (KMap_head (f, ks), _, _) -> + (next [@ocaml.tailcall]) g gas ks (f accu) stack + | (KLoop_in_left (ki, ks'), (accu : _ union), _) -> let ks' = mk ks' in let ki = enable_log ki in (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KUndip (x, ks') -> + | (KUndip (x, ks'), _, _) -> let ks' = mk ks' in let ks = KUndip (x, ks') in (next [@ocaml.tailcall]) g gas ks accu stack - | KIter (body, xs, ks') -> + | (KIter (body, xs, ks'), _, _) -> let ks' = mk ks' in let body = enable_log body in (kiter [@ocaml.tailcall]) mk g gas (body, xs) ks' accu stack - | KList_enter_body (body, xs, ys, len, ks') -> + | (KList_enter_body (body, xs, ys, len, ks'), _, _) -> let ks' = mk ks' in let extra = (body, xs, ys, len) in (klist_enter [@ocaml.tailcall]) mk g gas extra ks' accu stack - | KList_exit_body (body, xs, ys, len, ks') -> + | (KList_exit_body (body, xs, ys, len, ks'), _, (stack : _ * _)) -> let ks' = mk ks' in let extra = (body, xs, ys, len) in (klist_exit [@ocaml.tailcall]) mk g gas extra ks' accu stack - | KMap_enter_body (body, xs, ys, ks') -> + | (KMap_enter_body (body, xs, ys, ks'), _, _) -> let ks' = mk ks' in (kmap_enter [@ocaml.tailcall]) mk g gas (body, xs, ys) ks' accu stack - | KMap_exit_body (body, xs, ys, yk, ks') -> + | (KMap_exit_body (body, xs, ys, yk, ks'), _, (stack : _ * _)) -> let ks' = mk ks' in (kmap_exit [@ocaml.tailcall]) mk g gas (body, xs, ys, yk) ks' accu stack - | KView_exit (orig_step_constants, ks') -> + | (KView_exit (orig_step_constants, ks'), _, _) -> let g = (fst g, orig_step_constants) in (next [@ocaml.tailcall]) g gas ks' accu stack - | KLog (_, _) -> + | (KLog (_, _), _, _) -> (* This case should never happen. *) (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] @@ -1715,7 +1927,7 @@ let kstep logger ctxt step_constants kinstr accu stack = let internal_step ctxt step_constants gas kinstr accu stack = step (ctxt, step_constants) gas kinstr KNil accu stack -let step logger ctxt step_constants descr stack = +let test_step logger ctxt step_constants descr stack = step_descr ~log_now:false logger (ctxt, step_constants) descr stack (* @@ -1769,18 +1981,18 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal ~legacy:true ~allow_forged_in_storage:true | Some ex_script -> return (ex_script, ctxt)) - >>=? fun ( Ex_script - (Script - { - code_size; - code; - arg_type; - storage = old_storage; - storage_type; - entrypoints; - views; - }), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_script + (Script + { + code_size; + code; + arg_type; + storage = old_storage; + storage_type; + entrypoints; + views; + }), + ctxt ) -> Gas_monad.run ctxt (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint) @@ -1811,7 +2023,7 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal >>=? fun (storage, lazy_storage_diff, ctxt) -> trace Cannot_serialize_storage - ( unparse_data ctxt mode storage_type storage + ( (unparse_data [@coq_type_annotation]) ctxt mode storage_type storage >>=? fun (unparsed_storage, ctxt) -> Lwt.return ( Gas.consume ctxt (Script.strip_locations_cost unparsed_storage) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli index c57869e469d08..3d23a61529efd 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/script_interpreter.mli @@ -70,7 +70,7 @@ type step_constants = Script_typed_ir.step_constants = { level : Script_int.n Script_int.num; } -val step : +val test_step : logger option -> context -> Script_typed_ir.step_constants -> diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index d627ad93e0ad5..cae340c916a23 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -441,42 +441,47 @@ let[@coq_struct "w_value"] rec kundip : formal argument to [v]. The type of [v] is represented by [ty]. *) let apply ctxt gas capture_ty capture lam = let (Lam (descr, expr)) = lam in - let[@coq_match_with_default] (Item_t (full_arg_ty, _)) = descr.kbef in - let ctxt = update_context gas ctxt in - unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> - let loc = Micheline.dummy_location in - unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> - match full_arg_ty with - | Pair_t (capture_ty, arg_ty, _, _) -> - let arg_stack_ty = Item_t (arg_ty, Bot_t) in - let full_descr = - { - kloc = descr.kloc; - kbef = arg_stack_ty; - kaft = descr.kaft; - kinstr = - (let kinfo_const = {iloc = descr.kloc; kstack_ty = arg_stack_ty} in - let kinfo_pair = - { - iloc = descr.kloc; - kstack_ty = Item_t (capture_ty, arg_stack_ty); - } - in - IConst (kinfo_const, capture, ICons_pair (kinfo_pair, descr.kinstr))); - } - in - let full_expr = - Micheline.Seq - ( loc, - [ - Prim (loc, I_PUSH, [ty_expr; const_expr], []); - Prim (loc, I_PAIR, [], []); - expr; - ] ) - in - let lam' = Lam (full_descr, full_expr) in - let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in - return (lam', ctxt, gas) + match[@coq_match_with_default] descr.kbef with + | Item_t (full_arg_ty, _) -> ( + let ctxt = update_context gas ctxt in + unparse_data ctxt Optimized capture_ty capture + >>=? fun (const_expr, ctxt) -> + let loc = Micheline.dummy_location in + unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> + match full_arg_ty with + | Pair_t (capture_ty, arg_ty, _, _) -> + let arg_stack_ty = Item_t (arg_ty, Bot_t) in + let full_descr = + { + kloc = descr.kloc; + kbef = arg_stack_ty; + kaft = descr.kaft; + kinstr = + (let kinfo_const = + {iloc = descr.kloc; kstack_ty = arg_stack_ty} + in + let kinfo_pair = + { + iloc = descr.kloc; + kstack_ty = Item_t (capture_ty, arg_stack_ty); + } + in + IConst + (kinfo_const, capture, ICons_pair (kinfo_pair, descr.kinstr))); + } + in + let full_expr = + Micheline.Seq + ( loc, + [ + Prim (loc, I_PUSH, [ty_expr; const_expr], []); + Prim (loc, I_PAIR, [], []); + expr; + ] ) + in + let lam' = Lam (full_descr, full_expr) in + let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in + return (lam', ctxt, gas)) (* [transfer (ctxt, sc) gas tez parameters_ty parameters destination entrypoint] creates an operation that transfers an amount of [tez] to diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml index 2736fa2f42acc..027f83b15edde 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml @@ -56,9 +56,9 @@ let logger = let run_step ctxt code accu stack = let open Script_interpreter in let open Contract_helpers in - step None ctxt default_step_constants code accu stack + test_step None ctxt default_step_constants code accu stack >>=? fun ((_, _, ctxt') as r) -> - step (Some logger) ctxt default_step_constants code accu stack + test_step (Some logger) ctxt default_step_constants code accu stack >>=? fun (_, _, ctxt'') -> if Gas.(remaining_operation_gas ctxt' <> remaining_operation_gas ctxt'') then Alcotest.failf "Logging should not have an impact on gas consumption." ; -- GitLab From 9d525488cbed79b1c822ee1a60cddfad6e275289 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 8 Dec 2021 16:06:22 +0100 Subject: [PATCH 024/105] Protocol: INTERNAL: use an explicit module to represent Raw_context --- src/proto_alpha/lib_protocol/apply.ml | 6 +- src/proto_alpha/lib_protocol/raw_context.ml | 69 ++++++++++++++++++++ src/proto_alpha/lib_protocol/raw_context.mli | 2 + src/proto_alpha/lib_protocol/storage.ml | 40 ++++++------ 4 files changed, 94 insertions(+), 23 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index fcfe067214356..3702a5d570918 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1574,12 +1574,12 @@ let apply_external_manager_operation_content : >>=? fun (ctxt, slashed) -> if slashed then let bid = Bond_id.Tx_rollup_bond_id tx_rollup in - Token.balance ctxt (`Frozen_bonds (committer, bid)) + Token.balance ctxt (Frozen_bonds (committer, bid)) >>=? fun (ctxt, burn) -> Token.transfer ctxt - (`Frozen_bonds (committer, bid)) - `Tx_rollup_rejection_punishments + (Source_container (Frozen_bonds (committer, bid))) + (Sink_infinite Tx_rollup_rejection_punishments) burn else return (ctxt, []) | None -> return (ctxt, [])) diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index 39b5024d6e7bb..e339cc68a1f14 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -1400,3 +1400,72 @@ module Sc_rollup_in_memory_inbox = struct let back = {ctxt.back with sc_rollup_current_messages} in {ctxt with back} end + +(** Explicit module to present this file as a record in Coq and reduce the size + of the generated Coq code. *) +module M : T with type t = root = struct + type t = root + + type error += Block_quota_exceeded = Block_quota_exceeded + + type error += Operation_quota_exceeded = Operation_quota_exceeded + + let mem = mem + + let mem_tree = mem_tree + + let get = get + + let get_tree = get_tree + + let find = find + + let find_tree = find_tree + + let list = list + + let init = init + + let init_tree = init_tree + + let update = update + + let update_tree = update_tree + + let add = add + + let add_tree = add_tree + + let remove = remove + + let remove_existing = remove_existing + + let remove_existing_tree = remove_existing_tree + + let add_or_remove = add_or_remove + + let add_or_remove_tree = add_or_remove_tree + + let fold = fold + + let config = config + + module Tree = Tree + module Proof = Proof + + let verify_tree_proof = verify_tree_proof + + let verify_stream_proof = verify_stream_proof + + let equal_config = equal_config + + let project : t -> root = project + + let absolute_key : t -> key -> key = absolute_key + + let consume_gas = consume_gas + + let check_enough_gas = check_enough_gas + + let description : t Storage_description.t = description +end diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli index c7e306e2b3ec4..21304c4d052fb 100644 --- a/src/proto_alpha/lib_protocol/raw_context.mli +++ b/src/proto_alpha/lib_protocol/raw_context.mli @@ -370,3 +370,5 @@ module Sc_rollup_in_memory_inbox : sig val set_current_messages : t -> Sc_rollup_repr.t -> Context.tree -> t end + +module M : T with type t = root diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 4df9084d801e4..1ffa92099e962 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -93,7 +93,7 @@ module type Simple_single_data_storage = sig end module Block_round : Simple_single_data_storage with type value = Round_repr.t = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["block_round"] end) @@ -101,7 +101,7 @@ module Block_round : Simple_single_data_storage with type value = Round_repr.t = module Tenderbake = struct module First_level_legacy = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["first_level_of_Tenderbake"] end) @@ -125,14 +125,14 @@ module Tenderbake = struct end module Endorsement_branch = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["endorsement_branch"] end) (Branch) module Grand_parent_branch = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["grand_parent_branch"] end) @@ -171,7 +171,7 @@ end module Contract = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["contracts"] end) @@ -397,7 +397,7 @@ module Global_constants = struct and type key = Script_expr_hash.t and type value = Script_repr.expr = Make_indexed_carbonated_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["global_constant"] end)) @@ -415,7 +415,7 @@ module Big_map = struct type id = Lazy_storage_kind.Big_map.Id.t module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["big_maps"] end) @@ -550,7 +550,7 @@ module Sapling = struct type id = Lazy_storage_kind.Sapling_state.Id.t module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["sapling"] end) @@ -906,7 +906,7 @@ end module Delegates = Make_data_set_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["delegates"] end)) @@ -932,7 +932,7 @@ end module Cycle = struct module Indexed_context = Make_indexed_subcontext - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["cycle"] end)) @@ -1047,7 +1047,7 @@ module Slashed_deposits = Cycle.Slashed_deposits module Stake = struct module Staking_balance = Make_indexed_data_snapshotable_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["staking_balance"] end)) @@ -1057,7 +1057,7 @@ module Stake = struct module Active_delegate_with_one_roll = Make_indexed_data_snapshotable_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["active_delegate_with_one_roll"] end)) @@ -1087,7 +1087,7 @@ module Stake = struct The ratio above (blocks_per_cycle / blocks_per_stake_snapshot) is checked in {!val:Constants_repr.check_constants} to fit in a UInt16. *) module Last_snapshot = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["last_snapshot"] end) @@ -1101,7 +1101,7 @@ module Delegate_sampler_state = Cycle.Delegate_sampler_state module Vote = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["votes"] end) @@ -1268,7 +1268,7 @@ end module Commitments = Make_indexed_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["commitments"] end)) @@ -1286,7 +1286,7 @@ module Ramp_up = struct module Rewards = Make_indexed_data_storage - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["ramp_up"; "rewards"] end)) @@ -1322,7 +1322,7 @@ end module Pending_migration = struct module Balance_updates = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["pending_migration_balance_updates"] end) @@ -1333,7 +1333,7 @@ module Pending_migration = struct end) module Operation_results = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["pending_migration_operation_results"] end) @@ -1368,7 +1368,7 @@ end module Liquidity_baking = struct module Toggle_ema = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct (* The old "escape" name is kept here to avoid migrating this. *) let name = ["liquidity_baking_escape_ema"] @@ -1376,7 +1376,7 @@ module Liquidity_baking = struct (Encoding.Int32) module Cpmm_address = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["liquidity_baking_cpmm_address"] end) -- GitLab From da56e62cc657bec5bee59cfae3a1f81303bccfc4 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 10 Dec 2021 08:51:45 +0100 Subject: [PATCH 025/105] Protocol: remove type abstractions for coq-of-ocaml --- src/proto_alpha/lib_protocol/alpha_context.mli | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index d71d67813a324..02d3a7c4a111d 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -101,9 +101,9 @@ module Slot : sig end module Tez : sig - type repr + type repr = Tez_repr.repr - type t = Tez_tag of repr [@@ocaml.unboxed] + type t = Tez_repr.t = Tez_tag of repr [@@ocaml.unboxed] include BASIC_DATA with type t := t -- GitLab From 6d3d63c6509073b684dcddeee3a104df7cfa5d1a Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 16 Dec 2021 18:50:46 +0100 Subject: [PATCH 026/105] Proto: WIP: current changes --- src/proto_alpha/lib_protocol/alpha_context.ml | 1 - src/proto_alpha/lib_protocol/gas_monad.ml | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 3e557667a5044..49737234ff1e7 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -150,7 +150,6 @@ end module Round = struct include Round_repr - module Durations = Durations type round_durations = Durations.t diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 1ab7a61495457..7f5c435abbe65 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -47,7 +47,7 @@ let ( >>?? ) m f = let bind m f gas = m gas >>?? fun (res, gas) -> - match res with Ok y -> f y gas | Error _ as err -> of_result err gas + match res with Ok y -> f y gas | Error err -> of_result (Error err) gas [@@ocaml.inline always] let map f m gas = -- GitLab From e7e65b84e82c71a793fafe9ba2a3abf5b5f866e8 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Mon, 20 Dec 2021 15:49:02 +0100 Subject: [PATCH 027/105] Proto: add annotations to remove GADT axioms in Coq --- src/proto_alpha/lib_protocol/apply_results.ml | 101 ++++++++++-------- .../lib_protocol/operation_repr.ml | 95 +++++++++------- 2 files changed, 114 insertions(+), 82 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index f1312a7b352fa..78841f12e641e 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -333,7 +333,7 @@ module Manager_result = struct in MCase {op_case; encoding; kind; select; proj; inj; t} - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = make ~op_case:Operation.Encoding.Manager_operations.reveal_case ~encoding: @@ -345,14 +345,14 @@ module Manager_result = struct | Successful_manager_result (Reveal_result _ as op) -> Some op | _ -> None) ~kind:Kind.Reveal_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Reveal_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)) ; Reveal_result {consumed_gas = consumed_milligas}) - let[@coq_axiom_with_reason "gadt"] transaction_contract_variant_cases = + let transaction_contract_variant_cases = union [ case @@ -451,7 +451,7 @@ module Manager_result = struct }); ] - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = make ~op_case:Operation.Encoding.Manager_operations.transaction_case ~encoding:transaction_contract_variant_cases @@ -459,10 +459,10 @@ module Manager_result = struct | Successful_manager_result (Transaction_result _ as op) -> Some op | _ -> None) ~kind:Kind.Transaction_manager_kind - ~proj:(function Transaction_result x -> x) + ~proj:(function[@coq_match_with_default] Transaction_result x -> x) ~inj:(fun x -> Transaction_result x) - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = make ~op_case:Operation.Encoding.Manager_operations.origination_case ~encoding: @@ -477,7 +477,7 @@ module Manager_result = struct ~select:(function | Successful_manager_result (Origination_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Origination_result { lazy_storage_diff; @@ -514,7 +514,7 @@ module Manager_result = struct paid_storage_size_diff; }) - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = make ~op_case: Operation.Encoding.Manager_operations.register_global_constant_case @@ -529,7 +529,7 @@ module Manager_result = struct | Successful_manager_result (Register_global_constant_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Register_global_constant_result {balance_updates; consumed_gas; size_of_constant; global_address} -> ( balance_updates, @@ -592,7 +592,7 @@ module Manager_result = struct assert (Gas.Arith.(equal (ceil consumed_milligas) consumed_gas)) ; Set_deposits_limit_result {consumed_gas = consumed_milligas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_origination_case ~encoding: @@ -607,7 +607,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_origination_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_origination_result {balance_updates; consumed_gas; originated_tx_rollup} -> ( balance_updates, @@ -1286,7 +1286,7 @@ module Encoding = struct (fun x -> match proj x with None -> None | Some x -> Some ((), x)) (fun ((), x) -> inj x) - let[@coq_axiom_with_reason "gadt"] preendorsement_case = + let preendorsement_case = Case { op_case = Operation.Encoding.preendorsement_case; @@ -1304,7 +1304,7 @@ module Encoding = struct | Contents_and_result ((Preendorsement _ as op), res) -> Some (op, res) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Preendorsement_result {balance_updates; delegate; preendorsement_power} -> (balance_updates, delegate, preendorsement_power)); @@ -1314,7 +1314,7 @@ module Encoding = struct {balance_updates; delegate; preendorsement_power}); } - let[@coq_axiom_with_reason "gadt"] endorsement_case = + let endorsement_case = Case { op_case = Operation.Encoding.endorsement_case; @@ -1331,7 +1331,7 @@ module Encoding = struct | Contents_and_result ((Endorsement _ as op), res) -> Some (op, res) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Endorsement_result {balance_updates; delegate; endorsement_power} -> (balance_updates, delegate, endorsement_power)); inj = @@ -1339,7 +1339,7 @@ module Encoding = struct Endorsement_result {balance_updates; delegate; endorsement_power}); } - let[@coq_axiom_with_reason "gadt"] seed_nonce_revelation_case = + let seed_nonce_revelation_case = Case { op_case = Operation.Encoding.seed_nonce_revelation_case; @@ -1354,11 +1354,13 @@ module Encoding = struct | Contents_and_result ((Seed_nonce_revelation _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Seed_nonce_revelation_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Seed_nonce_revelation_result bus) -> + bus); inj = (fun bus -> Seed_nonce_revelation_result bus); } - let[@coq_axiom_with_reason "gadt"] double_endorsement_evidence_case = + let double_endorsement_evidence_case = Case { op_case = Operation.Encoding.double_endorsement_evidence_case; @@ -1374,11 +1376,14 @@ module Encoding = struct | Contents_and_result ((Double_endorsement_evidence _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Double_endorsement_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_endorsement_evidence_result + bus) -> + bus); inj = (fun bus -> Double_endorsement_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] double_preendorsement_evidence_case = + let double_preendorsement_evidence_case = Case { op_case = Operation.Encoding.double_preendorsement_evidence_case; @@ -1395,11 +1400,14 @@ module Encoding = struct -> Some (op, res) | _ -> None); - proj = (fun (Double_preendorsement_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_preendorsement_evidence_result + bus) -> + bus); inj = (fun bus -> Double_preendorsement_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] double_baking_evidence_case = + let double_baking_evidence_case = Case { op_case = Operation.Encoding.double_baking_evidence_case; @@ -1414,11 +1422,13 @@ module Encoding = struct | Contents_and_result ((Double_baking_evidence _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Double_baking_evidence_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Double_baking_evidence_result bus) -> + bus); inj = (fun bus -> Double_baking_evidence_result bus); } - let[@coq_axiom_with_reason "gadt"] activate_account_case = + let activate_account_case = Case { op_case = Operation.Encoding.activate_account_case; @@ -1433,11 +1443,12 @@ module Encoding = struct | Contents_and_result ((Activate_account _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun (Activate_account_result bus) -> bus); + proj = + (fun [@coq_match_with_default] (Activate_account_result bus) -> bus); inj = (fun bus -> Activate_account_result bus); } - let[@coq_axiom_with_reason "gadt"] proposals_case = + let proposals_case = Case { op_case = Operation.Encoding.proposals_case; @@ -1449,11 +1460,11 @@ module Encoding = struct (function | Contents_and_result ((Proposals _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun Proposals_result -> ()); + proj = (fun [@coq_match_with_default] Proposals_result -> ()); inj = (fun () -> Proposals_result); } - let[@coq_axiom_with_reason "gadt"] ballot_case = + let ballot_case = Case { op_case = Operation.Encoding.ballot_case; @@ -1465,11 +1476,11 @@ module Encoding = struct (function | Contents_and_result ((Ballot _ as op), res) -> Some (op, res) | _ -> None); - proj = (fun Ballot_result -> ()); + proj = (fun [@coq_match_with_default] Ballot_result -> ()); inj = (fun () -> Ballot_result); } - let[@coq_axiom_with_reason "gadt"] make_manager_case (type kind) + let make_manager_case (type kind) (Operation.Encoding.Case op_case : kind Kind.manager Operation.Encoding.case) (Manager_result.MCase res_case : kind Manager_result.case) mselect = @@ -1533,12 +1544,12 @@ module Encoding = struct | Contents_result Proposals_result -> None); mselect; proj = - (fun (Manager_operation_result - { - balance_updates = bus; - operation_result = r; - internal_operation_results = rs; - }) -> + (fun [@coq_match_with_default] (Manager_operation_result + { + balance_updates = bus; + operation_result = r; + internal_operation_results = rs; + }) -> (bus, r, rs)); inj = (fun (bus, r, rs) -> @@ -1550,7 +1561,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = make_manager_case Operation.Encoding.reveal_case Manager_result.reveal_case @@ -1560,7 +1571,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = make_manager_case Operation.Encoding.transaction_case Manager_result.transaction_case @@ -1570,7 +1581,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = make_manager_case Operation.Encoding.origination_case Manager_result.origination_case @@ -1580,7 +1591,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] delegation_case = + let delegation_case = make_manager_case Operation.Encoding.delegation_case Manager_result.delegation_case @@ -1590,7 +1601,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = make_manager_case Operation.Encoding.register_global_constant_case Manager_result.register_global_constant_case @@ -1602,7 +1613,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] set_deposits_limit_case = + let set_deposits_limit_case = make_manager_case Operation.Encoding.set_deposits_limit_case Manager_result.set_deposits_limit_case @@ -1613,7 +1624,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = make_manager_case Operation.Encoding.tx_rollup_origination_case Manager_result.tx_rollup_origination_case @@ -2513,13 +2524,13 @@ let rec kind_equal_list : | Some Eq -> Some Eq)) | _ -> None -let[@coq_axiom_with_reason "gadt"] rec pack_contents_list : +let rec pack_contents_list : type kind. kind contents_list -> kind contents_result_list -> kind contents_and_result_list = fun contents res -> - match (contents, res) with + match[@coq_match_with_default] (contents, res) with | (Single op, Single_result res) -> Single_and_result (op, res) | (Cons (op, ops), Cons_result (res, ress)) -> Cons_and_result (op, res, pack_contents_list ops ress) diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index a64a9d41be519..04ba8dd318b23 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -42,6 +42,7 @@ module Kind = struct type 'a double_consensus_operation_evidence = | Double_consensus_operation_evidence + [@@coq_force_gadt] type double_endorsement_evidence = endorsement_consensus_kind double_consensus_operation_evidence @@ -507,20 +508,20 @@ module Encoding = struct -> 'kind case [@@coq_force_gadt] - let[@coq_axiom_with_reason "gadt"] reveal_case = + let reveal_case = MCase { tag = 0; name = "reveal"; encoding = obj1 (req "public_key" Signature.Public_key.encoding); select = (function Manager (Reveal _ as op) -> Some op | _ -> None); - proj = (function Reveal pkh -> pkh); + proj = (function[@coq_match_with_default] Reveal pkh -> pkh); inj = (fun pkh -> Reveal pkh); } let transaction_tag = 1 - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = MCase { tag = transaction_tag; @@ -537,7 +538,7 @@ module Encoding = struct select = (function Manager (Transaction _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transaction {amount; destination; parameters; entrypoint} -> let parameters = if @@ -559,7 +560,7 @@ module Encoding = struct let origination_tag = 2 - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = MCase { tag = origination_tag; @@ -572,7 +573,7 @@ module Encoding = struct select = (function Manager (Origination _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Origination {credit; delegate; script} -> (credit, delegate, script)); inj = @@ -582,7 +583,7 @@ module Encoding = struct let delegation_tag = 3 - let[@coq_axiom_with_reason "gadt"] delegation_case = + let delegation_case = MCase { tag = delegation_tag; @@ -590,11 +591,11 @@ module Encoding = struct encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding); select = (function Manager (Delegation _ as op) -> Some op | _ -> None); - proj = (function Delegation key -> key); + proj = (function[@coq_match_with_default] Delegation key -> key); inj = (fun key -> Delegation key); } - let[@coq_axiom_with_reason "gadt"] register_global_constant_case = + let register_global_constant_case = MCase { tag = 4; @@ -603,11 +604,13 @@ module Encoding = struct select = (function | Manager (Register_global_constant _ as op) -> Some op | _ -> None); - proj = (function Register_global_constant {value} -> value); + proj = + (function[@coq_match_with_default] + | Register_global_constant {value} -> value); inj = (fun value -> Register_global_constant {value}); } - let[@coq_axiom_with_reason "gadt"] set_deposits_limit_case = + let set_deposits_limit_case = MCase { tag = 5; @@ -616,11 +619,12 @@ module Encoding = struct select = (function | Manager (Set_deposits_limit _ as op) -> Some op | _ -> None); - proj = (function Set_deposits_limit key -> key); + proj = + (function[@coq_match_with_default] Set_deposits_limit key -> key); inj = (fun key -> Set_deposits_limit key); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_origination_case = + let tx_rollup_origination_case = MCase { tag = tx_rollup_operation_origination_tag; @@ -629,7 +633,8 @@ module Encoding = struct select = (function | Manager (Tx_rollup_origination as op) -> Some op | _ -> None); - proj = (function Tx_rollup_origination -> ()); + proj = + (function[@coq_match_with_default] Tx_rollup_origination -> ()); inj = (fun () -> Tx_rollup_origination); } @@ -990,10 +995,12 @@ module Encoding = struct } let preendorsement_encoding = - let make (Case {tag; name; encoding; select = _; proj; inj}) = + let make = + fun [@coq_match_gadt] (Case {tag; name; encoding; select = _; proj; inj}) -> case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) in - let to_list : Kind.preendorsement contents_list -> _ = function + let to_list : Kind.preendorsement contents_list -> _ = + function[@coq_match_with_default] | Single o -> o in let of_list : Kind.preendorsement contents -> _ = function @@ -1039,11 +1046,14 @@ module Encoding = struct Endorsement {slot; level; round; block_payload_hash}); } - let[@coq_axiom_with_reason "gadt"] endorsement_encoding = - let make (Case {tag; name; encoding; select = _; proj; inj}) = + let endorsement_encoding = + let make = + fun [@coq_match_gadt] (Case {tag; name; encoding; select = _; proj; inj}) -> case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) in - let to_list : Kind.endorsement contents_list -> _ = fun (Single o) -> o in + let to_list : Kind.endorsement contents_list -> _ = + fun [@coq_match_with_default] (Single o) -> o + in let of_list : Kind.endorsement contents -> _ = fun o -> Single o in def "inlined.endorsement" @@ conv @@ -1061,7 +1071,7 @@ module Encoding = struct @@ union [make endorsement_case])) (varopt "signature" Signature.encoding))) - let[@coq_axiom_with_reason "gadt"] seed_nonce_revelation_case = + let seed_nonce_revelation_case = Case { tag = 1; @@ -1073,11 +1083,13 @@ module Encoding = struct select = (function | Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None); - proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce)); + proj = + (fun [@coq_match_with_default] (Seed_nonce_revelation {level; nonce}) -> + (level, nonce)); inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce}); } - let[@coq_axiom_with_reason "gadt"] double_preendorsement_evidence_case : + let double_preendorsement_evidence_case : Kind.double_preendorsement_evidence case = Case { @@ -1091,12 +1103,14 @@ module Encoding = struct (function | Contents (Double_preendorsement_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_preendorsement_evidence {op1; op2}) -> (op1, op2)); + proj = + (fun [@coq_match_with_default] (Double_preendorsement_evidence + {op1; op2}) -> + (op1, op2)); inj = (fun (op1, op2) -> Double_preendorsement_evidence {op1; op2}); } - let[@coq_axiom_with_reason "gadt"] double_endorsement_evidence_case : - Kind.double_endorsement_evidence case = + let double_endorsement_evidence_case : Kind.double_endorsement_evidence case = Case { tag = 2; @@ -1109,11 +1123,14 @@ module Encoding = struct (function | Contents (Double_endorsement_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2)); + proj = + (fun [@coq_match_with_default] (Double_endorsement_evidence + {op1; op2}) -> + (op1, op2)); inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2}); } - let[@coq_axiom_with_reason "gadt"] double_baking_evidence_case = + let double_baking_evidence_case = Case { tag = 3; @@ -1125,11 +1142,13 @@ module Encoding = struct select = (function | Contents (Double_baking_evidence _ as op) -> Some op | _ -> None); - proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2)); + proj = + (fun [@coq_match_with_default] (Double_baking_evidence {bh1; bh2}) -> + (bh1, bh2)); inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2}); } - let[@coq_axiom_with_reason "gadt"] activate_account_case = + let activate_account_case = Case { tag = 4; @@ -1142,13 +1161,14 @@ module Encoding = struct (function | Contents (Activate_account _ as op) -> Some op | _ -> None); proj = - (fun (Activate_account {id; activation_code}) -> + (fun [@coq_match_with_default] (Activate_account + {id; activation_code}) -> (id, activation_code)); inj = (fun (id, activation_code) -> Activate_account {id; activation_code}); } - let[@coq_axiom_with_reason "gadt"] proposals_case = + let proposals_case = Case { tag = 5; @@ -1161,14 +1181,14 @@ module Encoding = struct select = (function Contents (Proposals _ as op) -> Some op | _ -> None); proj = - (fun (Proposals {source; period; proposals}) -> + (fun [@coq_match_with_default] (Proposals {source; period; proposals}) -> (source, period, proposals)); inj = (fun (source, period, proposals) -> Proposals {source; period; proposals}); } - let[@coq_axiom_with_reason "gadt"] ballot_case = + let ballot_case = Case { tag = 6; @@ -1181,7 +1201,7 @@ module Encoding = struct (req "ballot" Vote_repr.ballot_encoding); select = (function Contents (Ballot _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Ballot {source; period; proposal; ballot} -> (source, period, proposal, ballot)); inj = @@ -1220,8 +1240,9 @@ module Encoding = struct Manager_operation {source; fee; counter; gas_limit; storage_limit; operation} - let[@coq_axiom_with_reason "gadt"] make_manager_case tag (type kind) - (Manager_operations.MCase mcase : kind Manager_operations.case) = + let make_manager_case tag (type kind) = + fun [@coq_match_gadt] (Manager_operations.MCase mcase : + kind Manager_operations.case) -> Case { tag; @@ -1235,7 +1256,7 @@ module Encoding = struct | Some operation -> Some (Manager_operation {op with operation})) | _ -> None); proj = - (function + (function[@coq_match_with_default] | Manager_operation {operation; _} as op -> (extract op, mcase.proj operation)); inj = (fun (op, contents) -> rebuild op (mcase.inj contents)); -- GitLab From 590e5113382d19fefabec3d32ad999d5024a7483 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 22 Dec 2021 18:24:23 +0100 Subject: [PATCH 028/105] Proto: WIP: changes to compile in Coq --- src/proto_alpha/lib_protocol/sc_rollup_repr.ml | 6 ++++-- src/proto_alpha/lib_protocol/sc_rollup_repr.mli | 1 + src/proto_alpha/lib_protocol/storage.ml | 2 +- 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml index 82174159d3208..411a3f4bfb6c5 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml @@ -167,9 +167,11 @@ let () = (fun loc -> Invalid_sc_rollup_address loc) let of_b58check s = + let error () = Error (Format.sprintf "Invalid_sc_rollup_address %s" s) in match Base58.decode s with - | Some (Address.Data hash) -> ok hash - | _ -> Error (Format.sprintf "Invalid_sc_rollup_address %s" s) + | Some data -> ( + match data with Address.Data hash -> ok hash | _ -> error ()) + | _ -> error () let pp = Address.pp diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli index 72807ac004a54..ccfff22d95347 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli @@ -149,3 +149,4 @@ module Kind : sig val pp : Format.formatter -> t -> unit end +[@@coq_plain_module] diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 1ffa92099e962..66bdfdacd4a6d 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1486,7 +1486,7 @@ end module Sc_rollup = struct module Raw_context = - Make_subcontext (Registered) (Raw_context) + Make_subcontext (Registered) (Raw_context.M) (struct let name = ["sc_rollup"] end) -- GitLab From 4a18cbb151c4bba6780b8f7f0a92006a2c27b54f Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 30 Dec 2021 18:14:40 +0100 Subject: [PATCH 029/105] Proto: WIP: compile more files --- src/proto_alpha/lib_protocol/apply_results.ml | 56 ++--- .../lib_protocol/operation_repr.ml | 204 ++++++++-------- .../lib_protocol/operation_repr.mli | 222 +++++++++--------- 3 files changed, 245 insertions(+), 237 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 78841f12e641e..7719540b94b3a 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -627,7 +627,7 @@ module Manager_result = struct originated_tx_rollup; }) - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_submit_batch_case ~encoding: @@ -642,7 +642,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_submit_batch_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_submit_batch_result {balance_updates; consumed_gas; paid_storage_size_diff} -> ( balance_updates, @@ -662,7 +662,7 @@ module Manager_result = struct paid_storage_size_diff; }) - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_commit_case ~encoding: @@ -675,7 +675,7 @@ module Manager_result = struct | Successful_manager_result (Tx_rollup_commit_result _ as op) -> Some op | _ -> None) ~kind:Kind.Tx_rollup_commit_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_commit_result {balance_updates; consumed_gas} -> (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas, consumed_milligas) -> @@ -683,7 +683,7 @@ module Manager_result = struct Tx_rollup_commit_result {balance_updates; consumed_gas = consumed_milligas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_return_bond_case ~encoding: @@ -705,7 +705,7 @@ module Manager_result = struct Tx_rollup_return_bond_result {balance_updates; consumed_gas = consumed_milligas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_finalize_commitment_case @@ -731,7 +731,7 @@ module Manager_result = struct Tx_rollup_finalize_commitment_result {balance_updates; consumed_gas = consumed_milligas; level}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_remove_commitment_case @@ -757,7 +757,7 @@ module Manager_result = struct Tx_rollup_remove_commitment_result {balance_updates; consumed_gas = consumed_milligas; level}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = make ~op_case:Operation.Encoding.Manager_operations.tx_rollup_rejection_case ~encoding: @@ -779,7 +779,7 @@ module Manager_result = struct Tx_rollup_rejection_result {balance_updates; consumed_gas = consumed_milligas}) - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = make ~op_case: Operation.Encoding.Manager_operations.tx_rollup_dispatch_tickets_case @@ -796,7 +796,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_dispatch_tickets_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_dispatch_tickets_result {balance_updates; consumed_gas; paid_storage_size_diff} -> ( balance_updates, @@ -816,7 +816,7 @@ module Manager_result = struct paid_storage_size_diff; }) - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = make ~op_case:Operation.Encoding.Manager_operations.transfer_ticket_case ~encoding: @@ -850,7 +850,7 @@ module Manager_result = struct paid_storage_size_diff; }) - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = make ~op_case:Operation.Encoding.Manager_operations.sc_rollup_originate_case ~encoding: @@ -864,7 +864,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_originate_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_originate_result {balance_updates; address; consumed_gas; size} -> ( balance_updates, @@ -961,7 +961,7 @@ module Internal_result = struct -> 'kind case [@@coq_force_gadt] - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = MCase { tag = Operation.Encoding.Manager_operations.transaction_tag; @@ -1004,7 +1004,7 @@ module Internal_result = struct Transaction {amount; destination; parameters; entrypoint}); } - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = MCase { tag = Operation.Encoding.Manager_operations.origination_tag; @@ -1030,7 +1030,7 @@ module Internal_result = struct Origination {credit; delegate; script}); } - let[@coq_axiom_with_reason "gadt"] delegation_case = + let delegation_case = MCase { tag = Operation.Encoding.Manager_operations.delegation_tag; @@ -1635,7 +1635,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = make_manager_case Operation.Encoding.tx_rollup_submit_batch_case Manager_result.tx_rollup_submit_batch_case @@ -1646,7 +1646,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = make_manager_case Operation.Encoding.tx_rollup_commit_case Manager_result.tx_rollup_commit_case @@ -1657,7 +1657,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = make_manager_case Operation.Encoding.tx_rollup_return_bond_case Manager_result.tx_rollup_return_bond_case @@ -1668,7 +1668,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = make_manager_case Operation.Encoding.tx_rollup_finalize_commitment_case Manager_result.tx_rollup_finalize_commitment_case @@ -1680,7 +1680,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = make_manager_case Operation.Encoding.tx_rollup_remove_commitment_case Manager_result.tx_rollup_remove_commitment_case @@ -1692,7 +1692,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = make_manager_case Operation.Encoding.tx_rollup_rejection_case Manager_result.tx_rollup_rejection_case @@ -1703,7 +1703,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = make_manager_case Operation.Encoding.tx_rollup_dispatch_tickets_case Manager_result.tx_rollup_dispatch_tickets_case @@ -1715,7 +1715,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = make_manager_case Operation.Encoding.transfer_ticket_case Manager_result.transfer_ticket_case @@ -1726,7 +1726,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = make_manager_case Operation.Encoding.sc_rollup_originate_case Manager_result.sc_rollup_originate_case @@ -1737,7 +1737,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_add_messages_case = + let sc_rollup_add_messages_case = make_manager_case Operation.Encoding.sc_rollup_add_messages_case Manager_result.sc_rollup_add_messages_case @@ -1748,7 +1748,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_cement_case = + let sc_rollup_cement_case = make_manager_case Operation.Encoding.sc_rollup_cement_case Manager_result.sc_rollup_cement_case @@ -1759,7 +1759,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_publish_case = + let sc_rollup_publish_case = make_manager_case Operation.Encoding.sc_rollup_publish_case Manager_result.sc_rollup_publish_case diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 04ba8dd318b23..f2b2788214857 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -218,75 +218,7 @@ type origination = { credit : Tez_repr.tez; } -type 'kind operation = { - shell : Operation.shell_header; - protocol_data : 'kind protocol_data; -} - -and 'kind protocol_data = { - contents : 'kind contents_list; - signature : Signature.t option; -} - -and _ contents_list = - | Single : 'kind contents -> 'kind contents_list - | Cons : - 'kind Kind.manager contents * 'rest Kind.manager contents_list - -> ('kind * 'rest) Kind.manager contents_list - -and _ contents = - | Preendorsement : consensus_content -> Kind.preendorsement contents - | Endorsement : consensus_content -> Kind.endorsement contents - | Seed_nonce_revelation : { - level : Raw_level_repr.t; - nonce : Seed_repr.nonce; - } - -> Kind.seed_nonce_revelation contents - | Double_preendorsement_evidence : { - op1 : Kind.preendorsement operation; - op2 : Kind.preendorsement operation; - } - -> Kind.double_preendorsement_evidence contents - | Double_endorsement_evidence : { - op1 : Kind.endorsement operation; - op2 : Kind.endorsement operation; - } - -> Kind.double_endorsement_evidence contents - | Double_baking_evidence : { - bh1 : Block_header_repr.t; - bh2 : Block_header_repr.t; - } - -> Kind.double_baking_evidence contents - | Activate_account : { - id : Ed25519.Public_key_hash.t; - activation_code : Blinded_public_key_hash.activation_code; - } - -> Kind.activate_account contents - | Proposals : { - source : Signature.Public_key_hash.t; - period : int32; - proposals : Protocol_hash.t list; - } - -> Kind.proposals contents - | Ballot : { - source : Signature.Public_key_hash.t; - period : int32; - proposal : Protocol_hash.t; - ballot : Vote_repr.ballot; - } - -> Kind.ballot contents - | Failing_noop : string -> Kind.failing_noop contents - | Manager_operation : { - source : Signature.public_key_hash; - fee : Tez_repr.tez; - counter : counter; - operation : 'kind manager_operation; - gas_limit : Gas_limit_repr.Arith.integral; - storage_limit : Z.t; - } - -> 'kind Kind.manager contents - -and _ manager_operation = +type _ manager_operation = | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation | Transaction : transaction -> Kind.transaction manager_operation | Origination : origination -> Kind.origination manager_operation @@ -376,7 +308,75 @@ and _ manager_operation = } -> Kind.sc_rollup_publish manager_operation -and counter = Z.t +type counter = Z.t + +type 'kind operation = { + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; +} + +and 'kind protocol_data = { + contents : 'kind contents_list; + signature : Signature.t option; +} + +and _ contents_list = + | Single : 'kind contents -> 'kind contents_list + | Cons : + 'kind Kind.manager contents * 'rest Kind.manager contents_list + -> ('kind * 'rest) Kind.manager contents_list + +and _ contents = + | Preendorsement : consensus_content -> Kind.preendorsement contents + | Endorsement : consensus_content -> Kind.endorsement contents + | Seed_nonce_revelation : { + level : Raw_level_repr.t; + nonce : Seed_repr.nonce; + } + -> Kind.seed_nonce_revelation contents + | Double_preendorsement_evidence : { + op1 : Kind.preendorsement operation; + op2 : Kind.preendorsement operation; + } + -> Kind.double_preendorsement_evidence contents + | Double_endorsement_evidence : { + op1 : Kind.endorsement operation; + op2 : Kind.endorsement operation; + } + -> Kind.double_endorsement_evidence contents + | Double_baking_evidence : { + bh1 : Block_header_repr.t; + bh2 : Block_header_repr.t; + } + -> Kind.double_baking_evidence contents + | Activate_account : { + id : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + } + -> Kind.activate_account contents + | Proposals : { + source : Signature.Public_key_hash.t; + period : int32; + proposals : Protocol_hash.t list; + } + -> Kind.proposals contents + | Ballot : { + source : Signature.Public_key_hash.t; + period : int32; + proposal : Protocol_hash.t; + ballot : Vote_repr.ballot; + } + -> Kind.ballot contents + | Failing_noop : string -> Kind.failing_noop contents + | Manager_operation : { + source : Signature.public_key_hash; + fee : Tez_repr.tez; + counter : counter; + operation : 'kind manager_operation; + gas_limit : Gas_limit_repr.Arith.integral; + storage_limit : Z.t; + } + -> 'kind Kind.manager contents let manager_kind : type kind. kind manager_operation -> kind Kind.manager = function @@ -644,7 +644,7 @@ module Encoding = struct encoding which is in hexadecimal for JSON. *) conv Bytes.of_string Bytes.to_string bytes - let[@coq_axiom_with_reason "gadt"] tx_rollup_submit_batch_case = + let tx_rollup_submit_batch_case = MCase { tag = tx_rollup_operation_submit_batch_tag; @@ -658,7 +658,7 @@ module Encoding = struct (function | Manager (Tx_rollup_submit_batch _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_submit_batch {tx_rollup; content; burn_limit} -> (tx_rollup, content, burn_limit)); inj = @@ -666,7 +666,7 @@ module Encoding = struct Tx_rollup_submit_batch {tx_rollup; content; burn_limit}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_commit_case = + let tx_rollup_commit_case = MCase { tag = tx_rollup_operation_commit_tag; @@ -679,14 +679,14 @@ module Encoding = struct (function | Manager (Tx_rollup_commit _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_commit {tx_rollup; commitment} -> (tx_rollup, commitment)); inj = (fun (tx_rollup, commitment) -> Tx_rollup_commit {tx_rollup; commitment}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_return_bond_case = + let tx_rollup_return_bond_case = MCase { tag = tx_rollup_operation_return_bond_tag; @@ -695,11 +695,13 @@ module Encoding = struct select = (function | Manager (Tx_rollup_return_bond _ as op) -> Some op | _ -> None); - proj = (function Tx_rollup_return_bond {tx_rollup} -> tx_rollup); + proj = + (function[@coq_match_with_default] + | Tx_rollup_return_bond {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_return_bond {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_finalize_commitment_case = + let tx_rollup_finalize_commitment_case = MCase { tag = tx_rollup_operation_finalize_commitment_tag; @@ -710,11 +712,12 @@ module Encoding = struct | Manager (Tx_rollup_finalize_commitment _ as op) -> Some op | _ -> None); proj = - (function Tx_rollup_finalize_commitment {tx_rollup} -> tx_rollup); + (function[@coq_match_with_default] + | Tx_rollup_finalize_commitment {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_finalize_commitment {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_remove_commitment_case = + let tx_rollup_remove_commitment_case = MCase { tag = tx_rollup_operation_remove_commitment_tag; @@ -725,11 +728,12 @@ module Encoding = struct | Manager (Tx_rollup_remove_commitment _ as op) -> Some op | _ -> None); proj = - (function Tx_rollup_remove_commitment {tx_rollup} -> tx_rollup); + (function[@coq_match_with_default] + | Tx_rollup_remove_commitment {tx_rollup} -> tx_rollup); inj = (fun tx_rollup -> Tx_rollup_remove_commitment {tx_rollup}); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_rejection_case = + let tx_rollup_rejection_case = MCase { tag = tx_rollup_operation_rejection_tag; @@ -758,7 +762,7 @@ module Encoding = struct (function | Manager (Tx_rollup_rejection _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_rejection { tx_rollup; @@ -808,7 +812,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] tx_rollup_dispatch_tickets_case = + let tx_rollup_dispatch_tickets_case = MCase { tag = tx_rollup_operation_dispatch_tickets_tag; @@ -830,7 +834,7 @@ module Encoding = struct | Manager (Tx_rollup_dispatch_tickets _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Tx_rollup_dispatch_tickets { tx_rollup; @@ -864,7 +868,7 @@ module Encoding = struct }); } - let[@coq_axiom_with_reason "gadt"] transfer_ticket_case = + let transfer_ticket_case = MCase { tag = transfer_ticket_tag; @@ -881,7 +885,7 @@ module Encoding = struct (function | Manager (Transfer_ticket _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transfer_ticket {contents; ty; ticketer; amount; destination; entrypoint} -> (contents, ty, ticketer, amount, destination, entrypoint)); @@ -891,7 +895,7 @@ module Encoding = struct {contents; ty; ticketer; amount; destination; entrypoint}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = MCase { tag = sc_rollup_operation_origination_tag; @@ -904,13 +908,13 @@ module Encoding = struct (function | Manager (Sc_rollup_originate _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_originate {kind; boot_sector} -> (kind, boot_sector)); inj = (fun (kind, boot_sector) -> Sc_rollup_originate {kind; boot_sector}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_add_messages_case = + let sc_rollup_add_messages_case = MCase { tag = sc_rollup_operation_add_message_tag; @@ -923,14 +927,14 @@ module Encoding = struct (function | Manager (Sc_rollup_add_messages _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_add_messages {rollup; messages} -> (rollup, messages)); inj = (fun (rollup, messages) -> Sc_rollup_add_messages {rollup; messages}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_cement_case = + let sc_rollup_cement_case = MCase { tag = sc_rollup_operation_cement_tag; @@ -943,13 +947,13 @@ module Encoding = struct (function | Manager (Sc_rollup_cement _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_cement {rollup; commitment} -> (rollup, commitment)); inj = (fun (rollup, commitment) -> Sc_rollup_cement {rollup; commitment}); } - let[@coq_axiom_with_reason "gadt"] sc_rollup_publish_case = + let sc_rollup_publish_case = MCase { tag = sc_rollup_operation_publish_tag; @@ -962,7 +966,7 @@ module Encoding = struct (function | Manager (Sc_rollup_publish _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Sc_rollup_publish {rollup; commitment} -> (rollup, commitment)); inj = (fun (rollup, commitment) -> Sc_rollup_publish {rollup; commitment}); @@ -996,7 +1000,9 @@ module Encoding = struct let preendorsement_encoding = let make = - fun [@coq_match_gadt] (Case {tag; name; encoding; select = _; proj; inj}) -> + fun [@coq_grab_existentials] (Case + {tag; name; encoding; select = _; proj; inj}) + -> case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) in let to_list : Kind.preendorsement contents_list -> _ = @@ -1048,7 +1054,9 @@ module Encoding = struct let endorsement_encoding = let make = - fun [@coq_match_gadt] (Case {tag; name; encoding; select = _; proj; inj}) -> + fun [@coq_grab_existentials] (Case + {tag; name; encoding; select = _; proj; inj}) + -> case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x) in let to_list : Kind.endorsement contents_list -> _ = @@ -1241,8 +1249,8 @@ module Encoding = struct {source; fee; counter; gas_limit; storage_limit; operation} let make_manager_case tag (type kind) = - fun [@coq_match_gadt] (Manager_operations.MCase mcase : - kind Manager_operations.case) -> + fun [@coq_grab_existentials] (Manager_operations.MCase mcase : + kind Manager_operations.case) -> Case { tag; diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index c2ade0f5e2661..e90801b6314f7 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -199,118 +199,9 @@ type origination = { credit : Tez_repr.tez; } -(** An [operation] contains the operation header information in [shell] - and all data related to the operation itself in [protocol_data]. *) -type 'kind operation = { - shell : Operation.shell_header; - protocol_data : 'kind protocol_data; -} - -(** A [protocol_data] wraps together a signature for the operation and - the contents of the operation itself. *) -and 'kind protocol_data = { - contents : 'kind contents_list; - signature : Signature.t option; -} - -(** A [contents_list] is a list of contents, the GADT guarantees two - invariants: - - the list is not empty, and - - if the list has several elements then it only contains manager - operations. *) -and _ contents_list = - | Single : 'kind contents -> 'kind contents_list - | Cons : - 'kind Kind.manager contents * 'rest Kind.manager contents_list - -> ('kind * 'rest) Kind.manager contents_list - -(** A value of type [contents] an operation related to whether - consensus, governance or contract management. *) -and _ contents = - (* Preendorsement: About consensus, preendorsement of a block held by a - validator (specific to Tenderbake). *) - | Preendorsement : consensus_content -> Kind.preendorsement contents - (* Endorsement: About consensus, endorsement of a block held by a - validator. *) - | Endorsement : consensus_content -> Kind.endorsement contents - (* Seed_nonce_revelation: Nonces are created by bakers and are - combined to create pseudo-random seeds. Bakers are urged to reveal their - nonces after a given number of cycles to keep their block rewards - from being forfeited. *) - | Seed_nonce_revelation : { - level : Raw_level_repr.t; - nonce : Seed_repr.nonce; - } - -> Kind.seed_nonce_revelation contents - (* Double_preendorsement_evidence: Double-preendorsement is a - kind of malicious attack where a byzantine attempts to fork - the chain by preendorsing blocks with different - contents (at the same level and same round) - twice. This behavior may be reported and the byzantine will have - its security deposit forfeited. *) - | Double_preendorsement_evidence : { - op1 : Kind.preendorsement operation; - op2 : Kind.preendorsement operation; - } - -> Kind.double_preendorsement_evidence contents - (* Double_endorsement_evidence: Similar to double-preendorsement but - for endorsements. *) - | Double_endorsement_evidence : { - op1 : Kind.endorsement operation; - op2 : Kind.endorsement operation; - } - -> Kind.double_endorsement_evidence contents - (* Double_baking_evidence: Similarly to double-endorsement but the - byzantine attempts to fork by signing two different blocks at the - same level. *) - | Double_baking_evidence : { - bh1 : Block_header_repr.t; - bh2 : Block_header_repr.t; - } - -> Kind.double_baking_evidence contents - (* Activate_account: Account activation allows to register a public - key hash on the blockchain. *) - | Activate_account : { - id : Ed25519.Public_key_hash.t; - activation_code : Blinded_public_key_hash.activation_code; - } - -> Kind.activate_account contents - (* Proposals: A candidate protocol can be proposed for voting. *) - | Proposals : { - source : Signature.Public_key_hash.t; - period : int32; - proposals : Protocol_hash.t list; - } - -> Kind.proposals contents - (* Ballot: The validators of the chain will then vote on proposals. *) - | Ballot : { - source : Signature.Public_key_hash.t; - period : int32; - proposal : Protocol_hash.t; - ballot : Vote_repr.ballot; - } - -> Kind.ballot contents - (* Failing_noop: An operation never considered by the state machine - and which will always fail at [apply]. This allows end-users to - sign arbitrary messages which have no computational semantics. *) - | Failing_noop : string -> Kind.failing_noop contents - (* Manager_operation: Operations, emitted and signed by - a (revealed) implicit account, that describe management and - interactions between contracts (whether implicit or - smart). *) - | Manager_operation : { - source : Signature.Public_key_hash.t; - fee : Tez_repr.tez; - counter : counter; - operation : 'kind manager_operation; - gas_limit : Gas_limit_repr.Arith.integral; - storage_limit : Z.t; - } - -> 'kind Kind.manager contents - (** A [manager_operation] describes management and interactions between contracts (whether implicit or smart). *) -and _ manager_operation = +type _ manager_operation = (* [Reveal] for the revelation of a public key, a one-time prerequisite to any signed operation, in order to be able to check the sender’s signature. *) @@ -449,7 +340,116 @@ and _ manager_operation = each manager operation declares a value for the counter. When a manager operation is applied, the value of the counter of its manager is checked and incremented. *) -and counter = Z.t +type counter = Z.t + +(** An [operation] contains the operation header information in [shell] + and all data related to the operation itself in [protocol_data]. *) +type 'kind operation = { + shell : Operation.shell_header; + protocol_data : 'kind protocol_data; +} + +(** A [protocol_data] wraps together a signature for the operation and + the contents of the operation itself. *) +and 'kind protocol_data = { + contents : 'kind contents_list; + signature : Signature.t option; +} + +(** A [contents_list] is a list of contents, the GADT guarantees two + invariants: + - the list is not empty, and + - if the list has several elements then it only contains manager + operations. *) +and _ contents_list = + | Single : 'kind contents -> 'kind contents_list + | Cons : + 'kind Kind.manager contents * 'rest Kind.manager contents_list + -> ('kind * 'rest) Kind.manager contents_list + +(** A value of type [contents] an operation related to whether + consensus, governance or contract management. *) +and _ contents = + (* Preendorsement: About consensus, preendorsement of a block held by a + validator (specific to Tenderbake). *) + | Preendorsement : consensus_content -> Kind.preendorsement contents + (* Endorsement: About consensus, endorsement of a block held by a + validator. *) + | Endorsement : consensus_content -> Kind.endorsement contents + (* Seed_nonce_revelation: Nonces are created by bakers and are + combined to create pseudo-random seeds. Bakers are urged to reveal their + nonces after a given number of cycles to keep their block rewards + from being forfeited. *) + | Seed_nonce_revelation : { + level : Raw_level_repr.t; + nonce : Seed_repr.nonce; + } + -> Kind.seed_nonce_revelation contents + (* Double_preendorsement_evidence: Double-preendorsement is a + kind of malicious attack where a byzantine attempts to fork + the chain by preendorsing blocks with different + contents (at the same level and same round) + twice. This behavior may be reported and the byzantine will have + its security deposit forfeited. *) + | Double_preendorsement_evidence : { + op1 : Kind.preendorsement operation; + op2 : Kind.preendorsement operation; + } + -> Kind.double_preendorsement_evidence contents + (* Double_endorsement_evidence: Similar to double-preendorsement but + for endorsements. *) + | Double_endorsement_evidence : { + op1 : Kind.endorsement operation; + op2 : Kind.endorsement operation; + } + -> Kind.double_endorsement_evidence contents + (* Double_baking_evidence: Similarly to double-endorsement but the + byzantine attempts to fork by signing two different blocks at the + same level. *) + | Double_baking_evidence : { + bh1 : Block_header_repr.t; + bh2 : Block_header_repr.t; + } + -> Kind.double_baking_evidence contents + (* Activate_account: Account activation allows to register a public + key hash on the blockchain. *) + | Activate_account : { + id : Ed25519.Public_key_hash.t; + activation_code : Blinded_public_key_hash.activation_code; + } + -> Kind.activate_account contents + (* Proposals: A candidate protocol can be proposed for voting. *) + | Proposals : { + source : Signature.Public_key_hash.t; + period : int32; + proposals : Protocol_hash.t list; + } + -> Kind.proposals contents + (* Ballot: The validators of the chain will then vote on proposals. *) + | Ballot : { + source : Signature.Public_key_hash.t; + period : int32; + proposal : Protocol_hash.t; + ballot : Vote_repr.ballot; + } + -> Kind.ballot contents + (* Failing_noop: An operation never considered by the state machine + and which will always fail at [apply]. This allows end-users to + sign arbitrary messages which have no computational semantics. *) + | Failing_noop : string -> Kind.failing_noop contents + (* Manager_operation: Operations, emitted and signed by + a (revealed) implicit account, that describe management and + interactions between contracts (whether implicit or + smart). *) + | Manager_operation : { + source : Signature.Public_key_hash.t; + fee : Tez_repr.tez; + counter : counter; + operation : 'kind manager_operation; + gas_limit : Gas_limit_repr.Arith.integral; + storage_limit : Z.t; + } + -> 'kind Kind.manager contents type packed_manager_operation = | Manager : 'kind manager_operation -> packed_manager_operation -- GitLab From 958ff80046715507b8b9b1cb9af2114f2a1b92d0 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 5 Jan 2022 14:40:11 +0100 Subject: [PATCH 030/105] Proto: WIP more annotations --- src/proto_alpha/lib_protocol/gas_monad.ml | 16 ++++++++-------- src/proto_alpha/lib_protocol/script_typed_ir.ml | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 7f5c435abbe65..f71b026b7f321 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -83,16 +83,16 @@ let run ctxt m = | None -> error Gas.Operation_quota_exceeded) let record_trace_eval : - type error_trace. + type a error_trace. error_details:error_trace Script_tc_errors.error_details -> (unit -> error) -> - ('a, error_trace) t -> - ('a, error_trace) t = - fun ~error_details -> - match error_details with - | Fast -> fun _f m -> m - | Informative -> - fun f m gas -> + (a, error_trace) t -> + (a, error_trace) t = + fun ~error_details f m -> + match[@coq_match_gadt_with_result] (error_details, m) with + | (Fast, _) -> m + | (Informative, (m : (_, _ trace) t)) -> + fun gas -> m gas >>?? fun (x, gas) -> of_result (record_trace_eval f x) gas let fail e = of_result (Error e) [@@ocaml.inline always] diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 7dc9ec48bb08e..614b878f950db 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -296,7 +296,7 @@ module Type_size : TYPE_SIZE = struct if Compare.Int.(x = y) then Result.return_unit else Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> Inconsistent_types_fast | Informative -> trace_of_error @@ Script_tc_errors.Inconsistent_type_sizes (x, y)) -- GitLab From 5e9386432bedc775c7c0b99ce4eb0a90d32df781 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 7 Jan 2022 11:43:18 +0100 Subject: [PATCH 031/105] Proto: CODE SWAP: move non-mutually recursive definition --- .../lib_protocol/script_interpreter.ml | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 1d78daf85fe75..88dce0786b0e3 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -234,6 +234,18 @@ let () = *) +let ifailwith : ifailwith_type = + { + ifailwith = + (fun logger (ctxt, _) gas kloc tv accu -> + let v = accu in + let ctxt = update_context gas ctxt in + trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) + >>=? fun (v, _ctxt) -> + let v = Micheline.strip_locations v in + get_log logger >>=? fun log -> fail (Reject (kloc, v, log))); + } + (* Evaluation of continuations @@ -465,18 +477,6 @@ and[@coq_struct "gas"] ilsr_nat : | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack -and[@coq_struct "function_parameter"] ifailwith : ifailwith_type = - { - ifailwith = - (fun logger (ctxt, _) gas kloc tv accu -> - let v = accu in - let ctxt = update_context gas ctxt in - trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) - >>=? fun (v, _ctxt) -> - let v = Micheline.strip_locations v in - get_log logger >>=? fun log -> fail (Reject (kloc, v, log))); - } - and[@coq_struct "gas"] iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = fun logger g gas k ks accu stack -> -- GitLab From b827ede47d22f9c778759a7c78d0a829101e2bad Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 11 Jan 2022 14:06:30 +0100 Subject: [PATCH 032/105] Proto: translate script_typed_ir_size.ml in Coq --- .../lib_protocol/script_typed_ir_size.ml | 52 +++++++++++-------- 1 file changed, 29 insertions(+), 23 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 62ecde31e7b03..f46201049b840 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -234,7 +234,7 @@ let kinfo_size {iloc = _; kstack_ty = _} = h2w tail-recursive and the only recursive call that is not a tailcall cannot be nested. (See [big_map_size].) For this reason, these functions should not trigger stack overflows. *) -let rec value_size : +let[@coq_struct "ty"] rec value_size_aux : type a ac. count_lambda_nodes:bool -> nodes_and_size -> @@ -244,7 +244,7 @@ let rec value_size : fun ~count_lambda_nodes accu ty x -> let apply : type a ac. nodes_and_size -> (a, ac) ty -> a -> nodes_and_size = fun accu ty x -> - match ty with + match[@coq_match_gadt] [@coq_match_with_default] ty with | Unit_t -> ret_succ accu | Int_t -> ret_succ_adding accu (script_int_size x) | Nat_t -> ret_succ_adding accu (script_nat_size x) @@ -262,7 +262,10 @@ let rec value_size : | Pair_t (_, _, _, _) -> ret_succ_adding accu h2w | Union_t (_, _, _, _) -> ret_succ_adding accu h1w | Lambda_t (_, _, _) -> - (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) x + (lambda_size_aux [@ocaml.tailcall]) + ~count_lambda_nodes + (ret_succ accu) + x | Option_t (_, _, _) -> ret_succ_adding accu (option_size (fun _ -> !!0) x) | List_t (_, _) -> ret_succ_adding accu (h2w +! (h2w *? x.length)) | Set_t (_, _) -> @@ -274,7 +277,7 @@ let rec value_size : let boxing_space = !!696 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h5w *? M.size)) | Big_map_t (cty, ty', _) -> - (big_map_size [@ocaml.tailcall]) + (big_map_size_aux [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) cty @@ -302,7 +305,7 @@ let rec value_size : let apply_comparable : type a. nodes_and_size -> a comparable_ty -> a -> nodes_and_size = fun accu ty x -> - match ty with + match[@coq_match_gadt] [@coq_match_with_default] ty with | Unit_t -> ret_succ accu | Int_t -> ret_succ_adding accu (script_int_size x) | Nat_t -> ret_succ_adding accu (script_nat_size x) @@ -325,9 +328,8 @@ let rec value_size : | Never_t -> ( match x with _ -> .) in value_traverse ty x accu {apply; apply_comparable} - [@@coq_axiom_with_reason "unreachable expressions '.' not handled for now"] -and big_map_size : +and[@coq_mutual_as_notation] big_map_size_aux : type a b bc. count_lambda_nodes:bool -> nodes_and_size -> @@ -347,12 +349,12 @@ and big_map_size : (* The following recursive call cannot introduce a stack overflow because this would require a key of type big_map while big_map is not comparable. *) - let accu = value_size ~count_lambda_nodes accu (R cty) key in + let accu = value_size_aux ~count_lambda_nodes accu (R cty) key in match value with | None -> accu | Some value -> let accu = ret_succ_adding accu h1w in - (value_size [@ocaml.tailcall]) + (value_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu (L ty') @@ -368,7 +370,7 @@ and big_map_size : (comparable_ty_size key_type ++ ty_size value_type ++ diff_size) (h4w +! id_size) -and lambda_size : +and[@coq_struct "function_parameter"] lambda_size_aux : type i o. count_lambda_nodes:bool -> nodes_and_size -> (i, o) lambda -> nodes_and_size = @@ -378,9 +380,9 @@ and lambda_size : let accu = ret_adding (accu ++ if count_lambda_nodes then node_size node else zero) h2w in - (kdescr_size [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr + (kdescr_size_aux [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr -and kdescr_size : +and[@coq_mutual_as_notation] kdescr_size_aux : type a s r f. count_lambda_nodes:bool -> nodes_and_size -> @@ -390,9 +392,9 @@ and kdescr_size : let accu = ret_adding (accu ++ stack_ty_size kbef ++ stack_ty_size kaft) h4w in - (kinstr_size [@ocaml.tailcall]) ~count_lambda_nodes accu kinstr + (kinstr_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu kinstr -and kinstr_size : +and[@coq_struct "t_value"] kinstr_size_aux : type a s r f. count_lambda_nodes:bool -> nodes_and_size -> @@ -410,7 +412,7 @@ and kinstr_size : | IConst (kinfo, x, k) -> let accu = ret_succ_adding accu (base kinfo +! word_size) in let (Ty_ex_c top_ty) = stack_top_ty (kinfo_of_kinstr k).kstack_ty in - (value_size [@ocaml.tailcall]) ~count_lambda_nodes accu (L top_ty) x + (value_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu (L top_ty) x | ICons_pair (kinfo, _) -> ret_succ_adding accu (base kinfo) | ICar (kinfo, _) -> ret_succ_adding accu (base kinfo) | ICdr (kinfo, _) -> ret_succ_adding accu (base kinfo) @@ -505,7 +507,7 @@ and kinstr_size : ret_succ_adding (accu ++ ty_size ty) (base kinfo +! word_size) | ILambda (kinfo, lambda, _) -> let accu = ret_succ_adding accu (base kinfo +! word_size) in - (lambda_size [@ocaml.tailcall]) ~count_lambda_nodes accu lambda + (lambda_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu lambda | IFailwith (kinfo, _, ty) -> ret_succ_adding (accu ++ ty_size ty) (base kinfo +! word_size) | ICompare (kinfo, cty, _) -> @@ -658,20 +660,24 @@ let rec kinstr_extra_size : type a s r f. (a, s, r, f) kinstr -> nodes_and_size [ty_of_comparable_ty] to create a type that is embedded in the IR. *) | ITicket (_, k) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr k in - match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) + match[@coq_match_with_default] kinfo.kstack_ty with + | Item_t (ty, _) -> ty_size ty) | IRead_ticket (_, k) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr k in match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) | ICompare (_, ty, _) -> comparable_ty_size ty | ISet_iter (_, body, _) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr body in - match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) + match[@coq_match_with_default] kinfo.kstack_ty with + | Item_t (ty, _) -> ty_size ty) | IMap_map (_, body, _) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr body in - match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) + match[@coq_match_with_default] kinfo.kstack_ty with + | Item_t (ty, _) -> ty_size ty) | IMap_iter (_, body, _) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr body in - match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) + match[@coq_match_with_default] kinfo.kstack_ty with + | Item_t (ty, _) -> ty_size ty) | ILambda (_, lambda, _) -> lambda_extra_size lambda | _ -> zero in @@ -690,7 +696,7 @@ let lambda_size lam = *) let (lambda_nodes, lambda_size) = - lambda_size ~count_lambda_nodes:true zero lam + lambda_size_aux ~count_lambda_nodes:true zero lam in let (lambda_extra_size_nodes, lambda_extra_size) = lambda_extra_size lam in let size = (lambda_size *? 157 /? 100) +! (lambda_extra_size *? 18 /? 100) in @@ -699,12 +705,12 @@ let lambda_size lam = let kinstr_size kinstr = let (kinstr_extra_size_nodes, kinstr_extra_size) = kinstr_extra_size kinstr in let (kinstr_nodes, kinstr_size) = - kinstr_size ~count_lambda_nodes:true zero kinstr + kinstr_size_aux ~count_lambda_nodes:true zero kinstr in let size = (kinstr_size *? 157 /? 100) +! (kinstr_extra_size *? 18 /? 100) in (Nodes.add kinstr_nodes kinstr_extra_size_nodes, size) -let value_size ty x = value_size ~count_lambda_nodes:true zero (L ty) x +let value_size ty x = value_size_aux ~count_lambda_nodes:true zero (L ty) x module Internal_for_tests = struct let ty_size = ty_size -- GitLab From bc9de4589ffe30c9e7cb414bcf49c81524c7b0bf Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 11 Jan 2022 19:08:51 +0100 Subject: [PATCH 033/105] Proto: compile the ticker_scanner --- .../lib_protocol/carbonated_map.ml | 2 +- .../lib_protocol/ticket_lazy_storage_diff.ml | 28 +++++++++++++------ .../lib_protocol/ticket_scanner.ml | 4 +-- .../lib_protocol/ticket_scanner.mli | 2 +- 4 files changed, 23 insertions(+), 13 deletions(-) diff --git a/src/proto_alpha/lib_protocol/carbonated_map.ml b/src/proto_alpha/lib_protocol/carbonated_map.ml index ceda9cd2c8537..0a50804c93c37 100644 --- a/src/proto_alpha/lib_protocol/carbonated_map.ml +++ b/src/proto_alpha/lib_protocol/carbonated_map.ml @@ -80,7 +80,7 @@ module type COMPARABLE = sig val compare_cost : t -> Gas.cost end -module Make (C : COMPARABLE) = struct +module Make (C : COMPARABLE) : S with type key := C.t = struct module M = Map.Make (C) type 'a t = {map : 'a M.t; size : int} diff --git a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml index eb19db16ab7eb..cd81d13147bec 100644 --- a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml @@ -76,7 +76,7 @@ let parse_value_type ctxt value_type = removing a value containing tickets. *) let collect_token_diffs_of_node ctxt has_tickets node ~get_token_and_amount acc = - Ticket_scanner.tickets_of_node + (Ticket_scanner.tickets_of_node [@coq_implicit "(a := a)"]) ctxt (* It's currently not possible to have nested lazy structures, but this is for future proofing. *) @@ -111,7 +111,7 @@ let collect_token_diffs_of_big_map_update ctxt ~big_map_id has_tickets = match expr_opt with | Some expr -> - collect_token_diffs_of_node + (collect_token_diffs_of_node [@coq_implicit "(a := a)"]) ctxt has_tickets expr @@ -165,12 +165,13 @@ let collect_token_diffs_of_big_map_updates ctxt big_map_id ~value_type updates We should have the non-serialized version of the value type. *) parse_value_type ctxt value_type - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Script_ir_translator.Ex_ty value_type, ctxt) -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> List.fold_left_es (fun (acc, already_updated, ctxt) update -> - collect_token_diffs_of_big_map_update + (collect_token_diffs_of_big_map_update + [@coq_implicit "(a := __Ex_ty_'a)"]) ctxt ~big_map_id has_tickets @@ -195,7 +196,8 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = type. It would be more efficient if the value preserved. *) parse_value_type ctxt value_ty - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun [@coq_match_gadt] (Script_ir_translator.Ex_ty value_type, ctxt) + -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> (* Iterate over big-map items. *) @@ -207,7 +209,7 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = Big_map.list_values ctxt big_map_id >>=? fun (ctxt, exprs) -> List.fold_left_es (fun (acc, ctxt) node -> - collect_token_diffs_of_node + (collect_token_diffs_of_node [@coq_implicit "(a := __Ex_ty_'a)"]) ctxt has_tickets node @@ -238,15 +240,23 @@ let collect_token_diffs_of_big_map_and_updates ctxt big_map_id updates acc = let collect_token_diffs_of_big_map_diff ctxt diff_item acc = Gas.consume ctxt Ticket_costs.Constants.cost_collect_tickets_step >>?= fun ctxt -> - match diff_item with - | Lazy_storage.Item (Lazy_storage_kind.Big_map, big_map_id, Remove) -> + match[@coq_match_gadt] diff_item with + | Lazy_storage.Item + (Lazy_storage_kind.Big_map, (big_map_id : Big_map.Id.t), Remove) -> (* Collect all removed tokens from the big-map. *) collect_token_diffs_of_big_map ctxt ~get_token_and_amount:neg_token_and_amount big_map_id acc - | Item (Lazy_storage_kind.Big_map, big_map_id, Update {init; updates}) -> ( + | Item + ( Lazy_storage_kind.Big_map, + (big_map_id : Big_map.Id.t), + (Update {init; updates} : + ( Big_map.Id.t, + Lazy_storage_kind.Big_map.alloc, + Lazy_storage_kind.Big_map.updates ) + Lazy_storage.diff) ) -> ( match init with | Lazy_storage.Existing -> (* Collect token diffs from the updates to the big-map. *) diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index 77096a85b495e..80880cc211128 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -532,8 +532,8 @@ let tickets_of_node ctxt ~include_lazy has_tickets expr = let (Has_tickets (ht, ty)) = has_tickets in match ht with | Ticket_inspection.False_ht -> return ([], ctxt) - | _ -> - Script_ir_translator.parse_data + | (_ : _ Ticket_inspection.has_tickets) -> + (Script_ir_translator.parse_data [@coq_implicit "(a := a)"]) ctxt ~legacy:true ~allow_forged:true diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.mli b/src/proto_alpha/lib_protocol/ticket_scanner.mli index 209c633ab74ab..c732b79842a88 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.mli +++ b/src/proto_alpha/lib_protocol/ticket_scanner.mli @@ -39,7 +39,7 @@ type ex_ticket = (** A type-witness that contains information about which branches of a type ['a] include tickets. This value is used for traversing only the relevant branches of values when scanning for tickets. *) -type 'a has_tickets +type 'a has_tickets [@@coq_phantom] (** [type_has_tickets ctxt ty] returns a [has_tickets] witness of the given shape [ty]. -- GitLab From 1016da9441264f86e57f75bdf946b919042e5df6 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 12 Jan 2022 10:45:04 +0100 Subject: [PATCH 034/105] Proto: put list conversions at top-level --- src/proto_alpha/lib_protocol/apply_results.ml | 97 ++++++++++--------- .../lib_protocol/apply_results.mli | 3 +- .../operations/test_combined_operations.ml | 9 +- 3 files changed, 61 insertions(+), 48 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 7719540b94b3a..240a0ea8c2253 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -1892,27 +1892,34 @@ type packed_contents_result_list = 'kind contents_result_list -> packed_contents_result_list +let rec contents_result_list_to_list : type kind. kind contents_result_list -> _ + = function + | Single_result o -> [Contents_result o] + | Cons_result (o, os) -> Contents_result o :: contents_result_list_to_list os + +let packed_contents_result_list_to_list = function + | Contents_result_list l -> contents_result_list_to_list l + +let rec packed_contents_result_list_of_list = function + | [] -> Error "cannot decode empty operation result" + | [Contents_result o] -> Ok (Contents_result_list (Single_result o)) + | Contents_result o :: os -> ( + packed_contents_result_list_of_list os + >>? fun (Contents_result_list os) -> + match (o, os) with + | (Manager_operation_result _, Single_result (Manager_operation_result _)) + -> + Ok (Contents_result_list (Cons_result (o, os))) + | (Manager_operation_result _, Cons_result _) -> + Ok (Contents_result_list (Cons_result (o, os))) + | _ -> Error "cannot decode ill-formed operation result") + let contents_result_list_encoding = - let rec to_list = function - | Contents_result_list (Single_result o) -> [Contents_result o] - | Contents_result_list (Cons_result (o, os)) -> - Contents_result o :: to_list (Contents_result_list os) - in - let rec of_list = function - | [] -> Error "cannot decode empty operation result" - | [Contents_result o] -> Ok (Contents_result_list (Single_result o)) - | Contents_result o :: os -> ( - of_list os >>? fun (Contents_result_list os) -> - match (o, os) with - | ( Manager_operation_result _, - Single_result (Manager_operation_result _) ) -> - Ok (Contents_result_list (Cons_result (o, os))) - | (Manager_operation_result _, Cons_result _) -> - Ok (Contents_result_list (Cons_result (o, os))) - | _ -> Error "cannot decode ill-formed operation result") - in def "operation.alpha.contents_list_result" - @@ conv_with_guard to_list of_list (list contents_result_encoding) + @@ conv_with_guard + packed_contents_result_list_to_list + packed_contents_result_list_of_list + (list contents_result_encoding) type 'kind contents_and_result_list = | Single_and_result : @@ -1929,27 +1936,34 @@ type packed_contents_and_result_list = 'kind contents_and_result_list -> packed_contents_and_result_list +let rec contents_and_result_list_to_list : + type kind. kind contents_and_result_list -> _ = function + | Single_and_result (op, res) -> [Contents_and_result (op, res)] + | Cons_and_result (op, res, rest) -> + Contents_and_result (op, res) :: contents_and_result_list_to_list rest + +let packed_contents_and_result_list_to_list = function + | Contents_and_result_list l -> contents_and_result_list_to_list l + +let rec packed_contents_and_result_list_of_list = function + | [] -> Error "cannot decode empty combined operation result" + | [Contents_and_result (op, res)] -> + Ok (Contents_and_result_list (Single_and_result (op, res))) + | Contents_and_result (op, res) :: rest -> ( + packed_contents_and_result_list_of_list rest + >>? fun (Contents_and_result_list rest) -> + match (op, rest) with + | (Manager_operation _, Single_and_result (Manager_operation _, _)) -> + Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) + | (Manager_operation _, Cons_and_result (_, _, _)) -> + Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) + | _ -> Error "cannot decode ill-formed combined operation result") + let contents_and_result_list_encoding = - let rec to_list = function - | Contents_and_result_list (Single_and_result (op, res)) -> - [Contents_and_result (op, res)] - | Contents_and_result_list (Cons_and_result (op, res, rest)) -> - Contents_and_result (op, res) :: to_list (Contents_and_result_list rest) - in - let rec of_list = function - | [] -> Error "cannot decode empty combined operation result" - | [Contents_and_result (op, res)] -> - Ok (Contents_and_result_list (Single_and_result (op, res))) - | Contents_and_result (op, res) :: rest -> ( - of_list rest >>? fun (Contents_and_result_list rest) -> - match (op, rest) with - | (Manager_operation _, Single_and_result (Manager_operation _, _)) -> - Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | (Manager_operation _, Cons_and_result (_, _, _)) -> - Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | _ -> Error "cannot decode ill-formed combined operation result") - in - conv_with_guard to_list of_list (Variable.list contents_and_result_encoding) + conv_with_guard + packed_contents_and_result_list_to_list + packed_contents_and_result_list_of_list + (Variable.list contents_and_result_encoding) type 'kind operation_metadata = {contents : 'kind contents_result_list} @@ -2564,11 +2578,6 @@ let rec unpack_contents_list : let (ops, ress) = unpack_contents_list rest in (Cons (op, ops), Cons_result (res, ress)) -let rec to_list = function - | Contents_result_list (Single_result o) -> [Contents_result o] - | Contents_result_list (Cons_result (o, os)) -> - Contents_result o :: to_list (Contents_result_list os) - let operation_data_and_metadata_encoding = def "operation.alpha.operation_with_metadata" @@ union diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index cea567bab6349..8b4b0e87f3904 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -329,7 +329,8 @@ val unpack_contents_list : 'kind contents_and_result_list -> 'kind contents_list * 'kind contents_result_list -val to_list : packed_contents_result_list -> packed_contents_result list +val packed_contents_result_list_to_list : + packed_contents_result_list -> packed_contents_result list type ('a, 'b) eq = Eq : ('a, 'a) eq diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml index 43fc555cde62a..224792bc63d78 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_combined_operations.ml @@ -124,7 +124,8 @@ let test_multiple_origination_and_delegation () = (fun acc -> function | No_operation_metadata -> assert false | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) + packed_contents_result_list_to_list (Contents_result_list contents) + @ acc) [] tickets |> List.rev @@ -193,7 +194,8 @@ let test_failing_operation_in_the_middle () = (fun acc -> function | No_operation_metadata -> assert false | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) + packed_contents_result_list_to_list (Contents_result_list contents) + @ acc) [] tickets in @@ -241,7 +243,8 @@ let test_failing_operation_in_the_middle_with_fees () = (fun acc -> function | No_operation_metadata -> assert false | Operation_metadata {contents} -> - to_list (Contents_result_list contents) @ acc) + packed_contents_result_list_to_list (Contents_result_list contents) + @ acc) [] tickets in -- GitLab From f5fb4119222f41c73f3705d168982046c832810c Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 12 Jan 2022 13:41:30 +0100 Subject: [PATCH 035/105] Proto: TEMP: simplify fitness_repr.ml code --- src/proto_alpha/lib_protocol/fitness_repr.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/fitness_repr.ml b/src/proto_alpha/lib_protocol/fitness_repr.ml index 0a1c3bd7fa8af..5f9b73b1f605d 100644 --- a/src/proto_alpha/lib_protocol/fitness_repr.ml +++ b/src/proto_alpha/lib_protocol/fitness_repr.ml @@ -167,10 +167,10 @@ let locked_round_to_bytes = function | Some locked_round -> int32_to_bytes (Round_repr.to_int32 locked_round) let locked_round_of_bytes b = - match Bytes.length b with - | 0 -> ok None - | 4 -> Round_repr.of_int32 (TzEndian.get_int32 b 0) >>? fun r -> ok (Some r) - | _ -> error Invalid_fitness + if Compare.Int.(Bytes.length b = 0) then ok None + else if Compare.Int.(Bytes.length b = 4) then + Round_repr.of_int32 (TzEndian.get_int32 b 0) >>? fun r -> ok (Some r) + else error Invalid_fitness let predecessor_round_of_bytes neg_predecessor_round = int32_of_bytes neg_predecessor_round >>? fun neg_predecessor_round -> -- GitLab From d375d4f6cc6c55006e729f78381938aa2e62a99f Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 13 Jan 2022 00:15:20 +0100 Subject: [PATCH 036/105] Proto: changes to help convert the translator to Coq --- .../lib_protocol/alpha_context.mli | 11 +++++++---- .../lib_protocol/script_ir_translator.ml | 19 ++++++++++++------- 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 02d3a7c4a111d..afe5eab0aa835 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1271,7 +1271,7 @@ module Big_map : sig Id.t -> (context * Script.expr list) tzresult Lwt.t - type update = { + type update = Lazy_storage_kind.Big_map.update = { key : Script_repr.expr; key_hash : Script_expr_hash.t; value : Script_repr.expr option; @@ -1279,7 +1279,10 @@ module Big_map : sig type updates = update list - type alloc = {key_type : Script_repr.expr; value_type : Script_repr.expr} + type alloc = Lazy_storage_kind.Big_map.alloc = { + key_type : Script_repr.expr; + value_type : Script_repr.expr; + } end module Sapling : sig @@ -1306,7 +1309,7 @@ module Sapling : sig val diff_encoding : diff Data_encoding.t module Memo_size : sig - type t + type t = Sapling_repr.Memo_size.t val encoding : t Data_encoding.t @@ -1359,7 +1362,7 @@ module Sapling : sig string -> (context * (Int64.t * state) option) tzresult Lwt.t - type alloc = {memo_size : Memo_size.t} + type alloc = Lazy_storage_kind.Sapling_state.alloc = {memo_size : Memo_size.t} type updates = diff diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index ef520d06b763b..11f19fcd852f8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -852,7 +852,7 @@ let memo_size_eq : if Sapling.Memo_size.equal ms1 ms2 then Result.return_unit else Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> Inconsistent_types_fast | Informative -> trace_of_error @@ Inconsistent_memo_sizes (ms1, ms2)) @@ -1047,6 +1047,7 @@ type ('a, 's) judgement = descr : 'b 'u. ('b, 'u) stack_ty -> ('a, 's, 'b, 'u) descr; } -> ('a, 's) judgement +[@@coq_force_gadt] (* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*) @@ -1819,6 +1820,7 @@ type 'storage ex_view = | Ex_view : ('input * 'storage, 'output) Script_typed_ir.lambda -> 'storage ex_view +[@@coq_force_gadt] type (_, _) dig_proof_argument = | Dig_proof_argument : @@ -1861,16 +1863,19 @@ type 'before comb_get_proof_argument = | Comb_get_proof_argument : ('before, 'after) comb_get_gadt_witness * ('after, _) ty -> 'before comb_get_proof_argument +[@@coq_force_gadt] type ('rest, 'before) comb_set_proof_argument = | Comb_set_proof_argument : ('rest, 'before, 'after) comb_set_gadt_witness * ('after, _) ty -> ('rest, 'before) comb_set_proof_argument +[@@coq_force_gadt] type 'before dup_n_proof_argument = | Dup_n_proof_argument : ('before, 'a) dup_n_gadt_witness * ('a, _) ty -> 'before dup_n_proof_argument +[@@coq_force_gadt] let rec make_dug_proof_argument : type a s x xc. @@ -1981,7 +1986,7 @@ let find_entrypoint (type full fullc error_trace) else Gas_monad.of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative -> trace_of_error @@ No_such_entrypoint entrypoint) @@ -2952,7 +2957,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | (Chest_t, expr) -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) -and parse_view_returning : +and[@coq_struct "ctxt"] parse_view_returning : type storage storagec. ?type_logger:type_logger -> context -> @@ -3012,7 +3017,7 @@ and parse_view_returning : eq >|? fun Eq -> (Ex_view (Lam (close_descr descr, view_code)), ctxt) | _ -> error (ill_type_view loc aft ())) -and typecheck_views : +and[@coq_struct "ctxt"] typecheck_views : type storage storagec. ?type_logger:type_logger -> context -> @@ -5187,8 +5192,8 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra @@ Tx_rollup_bad_deposit_parameter (loc, serialize_ty_for_error arg) else fail (No_such_entrypoint entrypoint) -and parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = - function +and[@coq_struct "ctxt"] parse_view_name ctxt : + Script.node -> (Script_string.t * context) tzresult = function | String (loc, v) as expr -> (* The limitation of length of string is same as entrypoint *) if Compare.Int.(String.length v > 31) then error (View_name_too_long v) @@ -5209,7 +5214,7 @@ and parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = Script_string.of_string v >|? fun s -> (s, ctxt) ) | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr) -and parse_toplevel : +and[@coq_struct "ctxt"] parse_toplevel : context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult = fun ctxt ~legacy toplevel -> record_trace (Ill_typed_contract (toplevel, [])) -- GitLab From 867c576a6bb07cad96fdd5d0b17f5e45304f0251 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 13 Jan 2022 00:29:15 +0100 Subject: [PATCH 037/105] Proto: avoid top-level name collisions for Coq in the translator --- .../lib_protocol/script_ir_translator.ml | 218 +++++++++--------- 1 file changed, 110 insertions(+), 108 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 11f19fcd852f8..c49c9274f3856 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -605,13 +605,13 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : a -> (loc Script.michelson_node * context) tzresult Lwt.t = fun ~loc ctxt mode ty a -> - (* No need for stack_depth here. Unlike [unparse_data], - [unparse_comparable_data] doesn't call [unparse_code]. + (* No need for stack_depth here. Unlike [unparse_data_aux], + [unparse_comparable_data] doesn't call [unparse_code_aux]. The stack depth is bounded by the type depth, currently bounded by 1000 (michelson_maximum_type_size). *) Gas.consume ctxt Unparse_costs.unparse_data_cycle (* We could have a smaller cost but let's keep it consistent with - [unparse_data] for now. *) + [unparse_data_aux] for now. *) >>?= fun ctxt -> match (ty, a) with @@ -1100,7 +1100,7 @@ let parse_memo_size (n : (location, _) Micheline.node) : type ex_comparable_ty = | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty -let[@coq_struct "ty"] rec parse_comparable_ty : +let[@coq_struct "ty"] rec parse_comparable_ty_aux : stack_depth:int -> context -> Script.node -> @@ -1172,25 +1172,25 @@ let[@coq_struct "ty"] rec parse_comparable_ty : (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) ok (Prim (loc, T_pair, right, []))) >>? fun right -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt right + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt right >>? fun (Ex_comparable_ty right, ctxt) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt left + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt left >>? fun (Ex_comparable_ty left, ctxt) -> pair_key loc left right >|? fun ty -> (Ex_comparable_ty ty, ctxt) | Prim (loc, T_or, [left; right], annot) -> check_type_annot loc annot >>? fun () -> remove_field_annot left >>? fun left -> remove_field_annot right >>? fun right -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt right + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt right >>? fun (Ex_comparable_ty right, ctxt) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt left + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt left >>? fun (Ex_comparable_ty left, ctxt) -> union_key loc left right >|? fun ty -> (Ex_comparable_ty ty, ctxt) | Prim (loc, ((T_pair | T_or) as prim), l, _) -> error (Invalid_arity (loc, prim, 2, List.length l)) | Prim (loc, T_option, [t], annot) -> check_type_annot loc annot >>? fun () -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t >>? fun (Ex_comparable_ty t, ctxt) -> option_key loc t >|? fun ty -> (Ex_comparable_ty ty, ctxt) | Prim (loc, T_option, l, _) -> @@ -1236,21 +1236,21 @@ type ex_parameter_ty_and_entrypoints_node = } -> ex_parameter_ty_and_entrypoints_node -(** [parse_ty] can be used to parse regular types as well as parameter types +(** [parse_ty_aux] can be used to parse regular types as well as parameter types together with their entrypoints. - In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty] will + In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty_aux] will return an [ex_ty]. - In the second case, use [~ret:Parse_entrypoints], [parse_ty] will return - an [ex_parameter_ty_and_entrypoints_node]. + In the second case, use [~ret:Parse_entrypoints], [parse_ty_aux] will return + an [ex_parameter_ty_and_entrypoints]. *) type ('ret, 'name) parse_ty_ret = | Don't_parse_entrypoints : (ex_ty, unit) parse_ty_ret | Parse_entrypoints : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret -let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty : +let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty_aux : type ret name. context -> stack_depth:int -> @@ -1343,7 +1343,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_type_annot loc annot >|? fun () -> return ctxt bls12_381_fr_t | Prim (loc, T_contract, [utl], annot) -> if allow_contract then - parse_passable_ty + parse_passable_ty_aux_with_ret ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1355,7 +1355,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty else error (Unexpected_contract loc) | Prim (loc, T_pair, utl :: utr, annot) -> remove_field_annot utl >>? fun utl -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1372,7 +1372,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) ok (Prim (loc, T_pair, utr, []))) >>? fun utr -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1392,7 +1392,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty remove_field_annot utr >|? fun utr -> (utl, utr) | Parse_entrypoints -> ok (utl, utr)) >>? fun (utl, utr) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1403,7 +1403,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty ~ret utl >>? fun (parsed_l, ctxt) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1439,9 +1439,9 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt) ) | Prim (loc, T_lambda, [uta; utr], annot) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy uta + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy uta >>? fun (Ex_ty ta, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy utr >>? fun (Ex_ty tr, ctxt) -> check_type_annot loc annot >>? fun () -> lambda_t loc ta tr >|? fun ty -> return ctxt ty @@ -1452,7 +1452,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_composed_type_annot loc annot >>? fun () -> ok ut else check_type_annot loc annot >>? fun () -> ok ut) >>? fun ut -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1465,7 +1465,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty >>? fun (Ex_ty t, ctxt) -> option_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_list, [ut], annot) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1480,20 +1480,20 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty list_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_ticket, [ut], annot) -> if allow_ticket then - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> ticket_t loc t >|? fun ty -> return ctxt ty else error (Unexpected_ticket loc) | Prim (loc, T_set, [ut], annot) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> set_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_map, [uta; utr], annot) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1590,7 +1590,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty T_tx_rollup_l2_address; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty : +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty_aux_with_ret : type ret name. context -> stack_depth:int -> @@ -1599,7 +1599,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab Script.node -> (ret * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1608,7 +1608,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab ~allow_contract:true ~allow_ticket:true -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty_aux : context -> stack_depth:int -> @@ -1616,7 +1616,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty Script.node -> (ex_ty * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1631,9 +1631,9 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt -> match args with | [key_ty; value_ty] -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt key_ty + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt key_ty >>? fun (Ex_comparable_ty key_ty, ctxt) -> - parse_big_map_value_ty + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1644,9 +1644,9 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty_aux ctxt ~stack_depth ~legacy value_ty = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1657,8 +1657,8 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma ~ret:Don't_parse_entrypoints value_ty -let parse_packable_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) +let parse_packable_ty_aux ctxt ~stack_depth ~legacy node = + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1673,7 +1673,7 @@ let parse_packable_ty ctxt ~stack_depth ~legacy node = node let parse_view_input_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1685,7 +1685,7 @@ let parse_view_input_ty ctxt ~stack_depth ~legacy node = node let parse_view_output_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1697,7 +1697,7 @@ let parse_view_output_ty ctxt ~stack_depth ~legacy node = node let parse_normal_storage_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -2080,7 +2080,7 @@ let parse_parameter_ty_and_entrypoints : Script.node -> (ex_parameter_ty_and_entrypoints * context) tzresult = fun ctxt ~stack_depth ~legacy node -> - parse_passable_ty + parse_passable_ty_aux_with_ret ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -2094,7 +2094,8 @@ let parse_parameter_ty_and_entrypoints : let entrypoints = {root = entrypoints; original_type_expr = node} in (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -let parse_passable_ty = parse_passable_ty ~ret:Don't_parse_entrypoints +let parse_passable_ty_aux = + parse_passable_ty_aux_with_ret ~ret:Don't_parse_entrypoints let parse_uint ~nb_bits = assert (Compare.Int.(nb_bits >= 0 && nb_bits <= 30)) ; @@ -2441,7 +2442,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_comparable_data : Script.node -> (a * context) tzresult Lwt.t = fun ?type_logger ctxt ty script_data -> - (* No need for stack_depth here. Unlike [parse_data], + (* No need for stack_depth here. Unlike [parse_data_aux], [parse_comparable_data] doesn't call [parse_returning]. The stack depth is bounded by the type depth, bounded by 1024. *) let parse_data_error () = @@ -2452,7 +2453,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_comparable_data : let traced body = trace_eval parse_data_error body in Gas.consume ctxt Typecheck_costs.parse_data_cycle (* We could have a smaller cost but let's keep it consistent with - [parse_data] for now. *) + [parse_data_aux] for now. *) >>?= fun ctxt -> let legacy = false in @@ -2503,7 +2504,7 @@ let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness = (* Some values, such as operations, tickets, or big map ids, are used only internally and are not allowed to be forged by users. - In [parse_data], [allow_forged] should be [false] for: + In [parse_data_aux], [allow_forged] should be [false] for: - PUSH - UNPACK - user-provided script parameters @@ -2513,7 +2514,7 @@ let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness = - storage after origination *) -let[@coq_axiom_with_reason "gadt"] rec parse_data : +let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : type a ac. ?type_logger:type_logger -> stack_depth:int -> @@ -2529,7 +2530,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : if Compare.Int.(stack_depth > 10_000) then fail Typechecking_too_many_recursive_calls else - parse_data + parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -2688,7 +2689,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : traced ( parse_address ctxt expr >>?= fun (address, ctxt) -> let loc = location expr in - parse_contract + parse_contract_aux ~stack_depth:(stack_depth + 1) ctxt loc @@ -2825,12 +2826,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | (_, None) -> traced_fail (Invalid_big_map (loc, id)) | (ctxt, Some (btk, btv)) -> Lwt.return - ( parse_comparable_ty + ( parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt (Micheline.root btk) >>? fun (Ex_comparable_ty btk, ctxt) -> - parse_big_map_value_ty + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -2981,7 +2982,7 @@ and[@coq_struct "ctxt"] parse_view_returning : (parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty) >>?= fun (Ex_ty output_ty', ctxt) -> pair_t input_ty_loc input_ty' storage_type >>?= fun (Ty_ex_c pair_ty) -> - parse_instr + parse_instr_aux ?type_logger ~stack_depth:0 Tc_context.view @@ -3044,7 +3045,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : Script.node -> ((arg, ret) lambda * context) tzresult Lwt.t = fun ?type_logger ~stack_depth tc_context ctxt ~legacy arg ret script_instr -> - parse_instr + parse_instr_aux ?type_logger tc_context ctxt @@ -3074,7 +3075,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : : (arg, ret) lambda), ctxt ) -and[@coq_axiom_with_reason "gadt"] parse_instr : +and[@coq_axiom_with_reason "gadt"] parse_instr_aux : type a s. ?type_logger:type_logger -> stack_depth:int -> @@ -3120,7 +3121,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : if Compare.Int.(stack_depth > 10000) then fail Typechecking_too_many_recursive_calls else - parse_instr + parse_instr_aux ?type_logger tc_context ctxt @@ -3252,9 +3253,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc swap stack_ty | (Prim (loc, I_PUSH, [t; d], annot), stack) -> check_var_annot loc annot >>?= fun () -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> - parse_data + parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -3275,7 +3276,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let cons_some = {apply = (fun kinfo k -> ICons_some (kinfo, k))} in option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest)) | (Prim (loc, I_NONE, [t], annot), stack) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let cons_none = {apply = (fun kinfo k -> ICons_none (kinfo, k))} in @@ -3440,7 +3441,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc cdr (Item_t (b, rest)) (* unions *) | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest)) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tr >>?= fun (Ex_ty tr, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_left = {apply = (fun kinfo k -> ICons_left (kinfo, k))} in @@ -3448,7 +3449,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack_ty = Item_t (ty, rest) in typed ctxt loc cons_left stack_ty | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest)) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tl >>?= fun (Ex_ty tl, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_right = {apply = (fun kinfo k -> ICons_right (kinfo, k))} in @@ -3493,7 +3494,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Lwt.return @@ merge_branches ctxt loc btr bfr {branch} (* lists *) | (Prim (loc, I_NIL, [t], annot), stack) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let nil = {apply = (fun kinfo k -> INil (kinfo, k))} in @@ -3614,7 +3615,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ) (* sets *) | (Prim (loc, I_EMPTY_SET, [t], annot), rest) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t >>?= fun (Ex_comparable_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_set (kinfo, t, k))} in @@ -3677,9 +3678,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* maps *) | (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_map (kinfo, tk, k))} in @@ -3810,9 +3811,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* big_map *) | (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = @@ -4053,9 +4054,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (tr, rest) in typed_no_lwt ctxt loc instr stack) | (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy arg >>?= fun (Ex_ty arg, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ret >>?= fun (Ex_ty ret, ctxt) -> check_kind [Seq_kind] code >>?= fun () -> check_var_annot loc annot >>?= fun () -> @@ -4502,7 +4503,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : (* annotations *) | (Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack)) -> check_var_annot loc annot >>?= fun () -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t >>?= fun (Ex_ty cast_t, ctxt) -> Gas_monad.run ctxt @@ ty_eq ~error_details:Informative loc cast_t t >>?= fun (eq, ctxt) -> @@ -4527,7 +4528,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest)) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> option_t loc t >>?= fun res_ty -> @@ -4541,7 +4542,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (address_t, rest) in typed ctxt loc instr stack | (Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest)) -> - parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_passable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> contract_t loc t >>?= fun contract_ty -> option_t loc contract_ty >>?= fun res_ty -> @@ -4600,7 +4601,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : contracts but then we throw away the typed version, except for the storage type which is kept for efficiency in the ticket scanner. *) let canonical_code = Micheline.strip_locations code in - parse_toplevel ctxt ~legacy canonical_code + parse_toplevel_aux ctxt ~legacy canonical_code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> record_trace (Ill_formed_type (Some "parameter", canonical_code, location arg_type)) @@ -5115,7 +5116,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : I_OPEN_CHEST; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract : +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract_aux : type arg argc. stack_depth:int -> context -> @@ -5155,7 +5156,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra code >>? fun (code, ctxt) -> (* can only fail because of gas *) - parse_toplevel ctxt ~legacy:true code + parse_toplevel_aux ctxt ~legacy:true code >>? fun ({arg_type; _}, ctxt) -> parse_parameter_ty_and_entrypoints ctxt @@ -5214,7 +5215,7 @@ and[@coq_struct "ctxt"] parse_view_name ctxt : Script_string.of_string v >|? fun s -> (s, ctxt) ) | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr) -and[@coq_struct "ctxt"] parse_toplevel : +and[@coq_struct "ctxt"] parse_toplevel_aux : context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult = fun ctxt ~legacy toplevel -> record_trace (Ill_typed_contract (toplevel, [])) @@ -5306,7 +5307,7 @@ and[@coq_struct "ctxt"] parse_toplevel : Script_ir_annot.error_unexpected_annot sloc sannot >|? fun () -> ({code_field = c; arg_type; views; storage_type = s}, ctxt)) -(* Same as [parse_contract], but does not fail when the contact is missing or +(* Same as [parse_contract_aux], but does not fail when the contact is missing or if the expected type doesn't match the actual one. In that case None is returned and some overapproximation of the typechecking gas is consumed. This can still fail on gas exhaustion. *) @@ -5356,7 +5357,7 @@ let parse_contract_for_script : code >>? fun (code, ctxt) -> (* can only fail because of gas *) - match parse_toplevel ctxt ~legacy:true code with + match parse_toplevel_aux ctxt ~legacy:true code with | Error _ -> error (Invalid_contract (loc, contract)) | Ok ({arg_type; _}, ctxt) -> ( match @@ -5435,7 +5436,7 @@ let parse_code : code >>?= fun (code, ctxt) -> Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code + parse_toplevel_aux ctxt ~legacy code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> let arg_type_loc = location arg_type in record_trace @@ -5488,7 +5489,7 @@ let parse_storage : (fun () -> let storage_type = serialize_ty_for_error storage_type in Ill_typed_data (None, storage, storage_type)) - (parse_data + (parse_data_aux ?type_logger ~stack_depth:0 ctxt @@ -5540,9 +5541,9 @@ let typecheck_code : Script.expr -> (typechecked_code_internal * context) tzresult Lwt.t = fun ~legacy ~show_types ctxt code -> - (* Constants need to be expanded or [parse_toplevel] may fail. *) + (* Constants need to be expanded or [parse_toplevel_aux] may fail. *) Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code >>?= fun (toplevel, ctxt) -> + parse_toplevel_aux ctxt ~legacy code >>?= fun (toplevel, ctxt) -> let {arg_type; storage_type; code_field; views} = toplevel in let type_map = ref [] in let arg_type_loc = location arg_type in @@ -5644,7 +5645,7 @@ let comb_witness2 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_axiom_with_reason "gadt"] rec unparse_data : +let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : type a ac. context -> stack_depth:int -> @@ -5657,7 +5658,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : let non_terminal_recursion ctxt mode ty a = if Compare.Int.(stack_depth > 10_000) then fail Unparsing_too_many_recursive_calls - else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a + else unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode ty a in let loc = Micheline.dummy_location in match (ty, a) with @@ -5710,7 +5711,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : let t = ty_of_comparable_ty opened_ticket_ty in let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in - (unparse_data [@tailcall]) + (unparse_data_aux [@tailcall]) ctxt ~stack_depth mode @@ -5773,7 +5774,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) | (Lambda_t _, Lam (_, original_code)) -> - unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code + unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code | (Never_t, _) -> . | (Sapling_transaction_t _, s) -> Lwt.return @@ -5844,22 +5845,23 @@ and unparse_items : (fun (l, ctxt) (k, v) -> let loc = Micheline.dummy_location in unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v + unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode vt v >|=? fun (value, ctxt) -> (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) ([], ctxt) items -and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = +and[@coq_axiom_with_reason "gadt"] unparse_code_aux ctxt ~stack_depth mode code + = let legacy = true in Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> let non_terminal_recursion ctxt mode code = if Compare.Int.(stack_depth > 10_000) then fail Unparsing_too_many_recursive_calls - else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code + else unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode code in match code with | Prim (loc, I_PUSH, [ty; data], annot) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> let allow_forged = false @@ -5868,7 +5870,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = from APPLYing a non-forgeable but this cannot happen either as long as all packable values are also forgeable. *) in - parse_data + parse_data_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -5876,7 +5878,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = t data >>=? fun (data, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data + unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode t data >>=? fun (data, ctxt) -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) | Seq (loc, items) -> @@ -5929,8 +5931,8 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage storage_type ~storage >>=? fun (storage, ctxt) -> - unparse_code ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> - unparse_data ctxt ~stack_depth:0 mode storage_type storage + unparse_code_aux ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> + unparse_data_aux ctxt ~stack_depth:0 mode storage_type storage >>=? fun (storage, ctxt) -> Lwt.return (let loc = Micheline.dummy_location in @@ -5975,7 +5977,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage ctxt )) let pack_data_with_mode ctxt ty data ~mode = - unparse_data ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> + unparse_data_aux ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> Lwt.return @@ pack_node unparsed ctxt let hash_data ctxt ty data = @@ -6013,7 +6015,7 @@ let big_map_get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = Alpha_context.Big_map.get_opt ctxt id key >>=? function | (ctxt, None) -> return (None, ctxt) | (ctxt, Some value) -> - parse_data + parse_data_aux ~stack_depth:0 ctxt ~legacy:true @@ -6100,7 +6102,7 @@ let diff_of_big_map ctxt mode ~temporary ~ids_to_copy (match value with | None -> return (None, ctxt) | Some x -> - unparse_data ~stack_depth:0 ctxt mode value_type x + unparse_data_aux ~stack_depth:0 ctxt mode value_type x >>=? fun (node, ctxt) -> Lwt.return ( Gas.consume ctxt (Script.strip_locations_cost node) >|? fun ctxt -> @@ -6424,7 +6426,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode let list_of_big_map_ids ids = Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids [] -let parse_data = parse_data ~stack_depth:0 +let parse_data = parse_data_aux ~stack_depth:0 let parse_instr : type a s. @@ -6436,7 +6438,7 @@ let parse_instr : (a, s) stack_ty -> ((a, s) judgement * context) tzresult Lwt.t = fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty -> - parse_instr + parse_instr_aux ~stack_depth:0 ?type_logger tc_context @@ -6445,31 +6447,31 @@ let parse_instr : script_instr stack_ty -let unparse_data = unparse_data ~stack_depth:0 +let unparse_data = unparse_data_aux ~stack_depth:0 let unparse_code ctxt mode code = - (* Constants need to be expanded or [unparse_code] may fail. *) + (* Constants need to be expanded or [unparse_code_aux] may fail. *) Global_constants_storage.expand ctxt (strip_locations code) - >>=? fun (ctxt, code) -> unparse_code ~stack_depth:0 ctxt mode (root code) + >>=? fun (ctxt, code) -> unparse_code_aux ~stack_depth:0 ctxt mode (root code) let parse_contract context loc arg_ty contract ~entrypoint = - parse_contract ~stack_depth:0 context loc arg_ty contract ~entrypoint + parse_contract_aux ~stack_depth:0 context loc arg_ty contract ~entrypoint let parse_toplevel ctxt ~legacy toplevel = Global_constants_storage.expand ctxt toplevel >>=? fun (ctxt, toplevel) -> - Lwt.return @@ parse_toplevel ctxt ~legacy toplevel + Lwt.return @@ parse_toplevel_aux ctxt ~legacy toplevel -let parse_comparable_ty = parse_comparable_ty ~stack_depth:0 +let parse_comparable_ty = parse_comparable_ty_aux ~stack_depth:0 -let parse_big_map_value_ty = parse_big_map_value_ty ~stack_depth:0 +let parse_big_map_value_ty = parse_big_map_value_ty_aux ~stack_depth:0 -let parse_packable_ty = parse_packable_ty ~stack_depth:0 +let parse_packable_ty = parse_packable_ty_aux ~stack_depth:0 -let parse_passable_ty = parse_passable_ty ~stack_depth:0 +let parse_passable_ty = parse_passable_ty_aux ~stack_depth:0 -let parse_any_ty = parse_any_ty ~stack_depth:0 +let parse_any_ty = parse_any_ty_aux ~stack_depth:0 -let parse_ty = parse_ty ~stack_depth:0 ~ret:Don't_parse_entrypoints +let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints let parse_parameter_ty_and_entrypoints = parse_parameter_ty_and_entrypoints ~stack_depth:0 -- GitLab From 24d4e981db81ca6a1f97c207522fdf89114cadc8 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 13 Jan 2022 00:29:32 +0100 Subject: [PATCH 038/105] Proto: changes to help compile the translator to Coq --- src/proto_alpha/lib_protocol/script_ir_translator.mli | 1 + src/proto_alpha/lib_protocol/ticket_scanner.ml | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index a2504a6d7128d..6f47224b86a32 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -118,6 +118,7 @@ type 'storage ex_view = | Ex_view : ('input * 'storage, 'output) Script_typed_ir.lambda -> 'storage ex_view +[@@coq_force_gadt] type ('a, 's, 'b, 'u) cinstr = { apply : diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index 80880cc211128..88de29a45e3a3 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -533,7 +533,7 @@ let tickets_of_node ctxt ~include_lazy has_tickets expr = match ht with | Ticket_inspection.False_ht -> return ([], ctxt) | (_ : _ Ticket_inspection.has_tickets) -> - (Script_ir_translator.parse_data [@coq_implicit "(a := a)"]) + (Script_ir_translator.parse_data [@coq_implicit "(A := a)"]) ctxt ~legacy:true ~allow_forged:true -- GitLab From 1d9d856ec6bf8bde4f52c778a9e94a22cfcdbe98 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 13 Jan 2022 12:03:39 +0100 Subject: [PATCH 039/105] Proto: convert more of the translator --- .../lib_protocol/script_ir_translator.ml | 93 ++++++++++++------- 1 file changed, 60 insertions(+), 33 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index c49c9274f3856..aa465bb21a4e8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -6331,7 +6331,7 @@ end (** Prematurely abort if [f] generates an error. Use this function without the [unit] type for [error] if you are in a case where errors are impossible. *) -let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : +let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : type a ac error. f:('acc, error) Fold_lazy_storage.result Lazy_storage.IdSet.fold_f -> init:'acc -> @@ -6342,33 +6342,53 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : (('acc, error) Fold_lazy_storage.result * context) tzresult = fun ~f ~init ctxt ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - match (has_lazy_storage, ty, x) with - | (Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _}) -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) - | (Sapling_state_f, Sapling_state_t _, {id = Some id; _}) -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) + match[@coq_match_gadt] (has_lazy_storage, ty, x) with + | (Big_map_f, Big_map_t (_, _, _), (x : _ big_map)) -> ( + match x with + | Big_map {id = Some id; _} -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> + ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) + | Big_map {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) + | (Sapling_state_f, Sapling_state_t _, (x : Alpha_context.Sapling.state)) -> ( + match x with + | {id = Some id; _} -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> + ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) + | {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) | (False_f, _, _) -> ok (Fold_lazy_storage.Ok init, ctxt) - | (Big_map_f, Big_map_t (_, _, _), Big_map {id = None; _}) -> - ok (Fold_lazy_storage.Ok init, ctxt) - | (Sapling_state_f, Sapling_state_t _, {id = None; _}) -> - ok (Fold_lazy_storage.Ok init, ctxt) - | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr)) -> ( + | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ * _)) -> ( + let (xl, xr) = x in fold_lazy_storage ~f ~init ctxt tyl xl ~has_lazy_storage:hl >>? fun (init, ctxt) -> match init with | Fold_lazy_storage.Ok init -> fold_lazy_storage ~f ~init ctxt tyr xr ~has_lazy_storage:hr | Fold_lazy_storage.Error -> ok (init, ctxt)) - | (Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x) -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | (Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x) -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | (_, Option_t (_, _, _), None) -> ok (Fold_lazy_storage.Ok init, ctxt) - | (Option_f has_lazy_storage, Option_t (ty, _, _), Some x) -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | (List_f has_lazy_storage, List_t (ty, _), l) -> + | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), + Union_t (tyl, tyr, _, _), + (x : _ union) ) -> ( + match x with + | L x -> + fold_lazy_storage + ~f + ~init + ctxt + tyl + x + ~has_lazy_storage:has_lazy_storage_l + | R x -> + fold_lazy_storage + ~f + ~init + ctxt + tyr + x + ~has_lazy_storage:has_lazy_storage_r) + | (Option_f has_lazy_storage, Option_t (ty, _, _), (o : _ option)) -> ( + match o with + | None -> ok (Fold_lazy_storage.Ok init, ctxt) + | Some x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage) + | (List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list)) -> List.fold_left_e (fun ((init, ctxt) : ('acc, error) Fold_lazy_storage.result * context) x -> match init with @@ -6377,7 +6397,7 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : | Fold_lazy_storage.Error -> ok (init, ctxt)) (Fold_lazy_storage.Ok init, ctxt) l.elements - | (Map_f has_lazy_storage, Map_t (_, ty, _), m) -> + | (Map_f has_lazy_storage, Map_t (_, ty, _), (m : _ map)) -> Script_map.fold (fun _ v @@ -6390,18 +6410,21 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : m (ok (Fold_lazy_storage.Ok init, ctxt)) -let[@coq_axiom_with_reason "gadt"] collect_lazy_storage ctxt ty x = +let collect_lazy_storage ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f kind id (acc : (_, never) Fold_lazy_storage.result) = - let acc = match acc with Fold_lazy_storage.Ok acc -> acc in + let acc = + match[@coq_match_with_default] acc with Fold_lazy_storage.Ok acc -> acc + in Fold_lazy_storage.Ok (Lazy_storage.IdSet.add kind id acc) in fold_lazy_storage ~f:{f} ~init:no_lazy_storage_id ctxt ty x ~has_lazy_storage >>? fun (ids, ctxt) -> - match ids with Fold_lazy_storage.Ok ids -> ok (ids, ctxt) + match[@coq_match_with_default] ids with + | Fold_lazy_storage.Ok ids -> ok (ids, ctxt) -let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode - ~temporary ~to_duplicate ~to_update ty v = +let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v + = (* Basically [to_duplicate] are ids from the argument and [to_update] are ids from the storage before execution (i.e. it is safe to reuse them since they @@ -6414,10 +6437,14 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode if temporary then diffs else let dead = Lazy_storage.IdSet.diff to_update alive in - Lazy_storage.IdSet.fold_all - {f = (fun kind id acc -> Lazy_storage.make kind id Remove :: acc)} - dead - diffs + let f kind id acc = + (Lazy_storage.make [@coq_implicit "(a := unit) (u := unit)"]) + kind + id + Remove + :: acc + in + Lazy_storage.IdSet.fold_all {f} dead diffs in match diffs with | [] -> (v, None, ctxt) @@ -6480,8 +6507,8 @@ let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i) single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result = - match kind with - | Lazy_storage.Kind.Sapling_state -> ( + match[@coq_match_gadt] (kind, id) with + | (Lazy_storage.Kind.Sapling_state, (id : Alpha_context.Sapling.Id.t)) -> ( match single_id_opt with | Fold_lazy_storage.Ok None -> Fold_lazy_storage.Ok (Some id) | Fold_lazy_storage.Ok (Some _) -> -- GitLab From 52cff33cc1e475936c52a9d2b4ccc283c565564d Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 13 Jan 2022 13:35:15 +0100 Subject: [PATCH 040/105] Proto: convert more of the translator --- .../lib_protocol/script_ir_translator.ml | 305 ++++++++++-------- 1 file changed, 178 insertions(+), 127 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index aa465bb21a4e8..f6c7a5dffe913 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -334,7 +334,7 @@ let serialize_ty_for_error ty = *) unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations -let[@coq_axiom_with_reason "gadt"] rec comparable_ty_of_ty : +let rec comparable_ty_of_ty : type a ac. context -> Script.location -> @@ -596,7 +596,7 @@ let comparable_comb_witness2 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : +let[@coq_struct "ty"] rec unparse_comparable_data : type a loc. loc:loc -> context -> @@ -614,33 +614,38 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : [unparse_data_aux] for now. *) >>?= fun ctxt -> - match (ty, a) with - | (Unit_t, v) -> Lwt.return @@ unparse_unit ~loc ctxt v - | (Int_t, v) -> Lwt.return @@ unparse_int ~loc ctxt v - | (Nat_t, v) -> Lwt.return @@ unparse_nat ~loc ctxt v - | (String_t, s) -> Lwt.return @@ unparse_string ~loc ctxt s - | (Bytes_t, s) -> Lwt.return @@ unparse_bytes ~loc ctxt s - | (Bool_t, b) -> Lwt.return @@ unparse_bool ~loc ctxt b - | (Timestamp_t, t) -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | (Address_t, address) -> Lwt.return @@ unparse_address ~loc ctxt mode address - | (Tx_rollup_l2_address_t, address) -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + | (Unit_t, (v : unit)) -> Lwt.return @@ unparse_unit ~loc ctxt v + | (Int_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_int ~loc ctxt v + | (Nat_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_nat ~loc ctxt v + | (String_t, (s : Script_string.t)) -> + Lwt.return @@ unparse_string ~loc ctxt s + | (Bytes_t, (s : bytes)) -> Lwt.return @@ unparse_bytes ~loc ctxt s + | (Bool_t, (b : bool)) -> Lwt.return @@ unparse_bool ~loc ctxt b + | (Timestamp_t, (t : Script_timestamp.t)) -> + Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | (Address_t, (address : address)) -> + Lwt.return @@ unparse_address ~loc ctxt mode address + | (Tx_rollup_l2_address_t, (address : tx_rollup_l2_address)) -> Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | (Signature_t, s) -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | (Mutez_t, v) -> Lwt.return @@ unparse_mutez ~loc ctxt v - | (Key_t, k) -> Lwt.return @@ unparse_key ~loc ctxt mode k - | (Key_hash_t, k) -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | (Chain_id_t, chain_id) -> + | (Signature_t, (s : signature)) -> + Lwt.return @@ unparse_signature ~loc ctxt mode s + | (Mutez_t, (v : Tez_repr.t)) -> Lwt.return @@ unparse_mutez ~loc ctxt v + | (Key_t, (k : public_key)) -> Lwt.return @@ unparse_key ~loc ctxt mode k + | (Key_hash_t, (k : public_key_hash)) -> + Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | (Chain_id_t, (chain_id : Script_chain_id.t)) -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | (Pair_t (tl, tr, _, YesYes), pair) -> + | (Pair_t (tl, tr, _, YesYes), (pair : _ * _)) -> let r_witness = comparable_comb_witness2 tr in let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | (Union_t (tl, tr, _, YesYes), v) -> + | (Union_t (tl, tr, _, YesYes), (v : _ union)) -> let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v - | (Option_t (t, _, Yes), v) -> + | (Option_t (t, _, Yes), (v : _ option)) -> let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in unparse_option ~loc unparse_v ctxt v | (Never_t, _) -> . @@ -1644,8 +1649,8 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty_aux - ctxt ~stack_depth ~legacy value_ty = +and[@coq_mutual_as_notation] parse_big_map_value_ty_aux ctxt ~stack_depth + ~legacy value_ty = (parse_ty_aux [@tailcall]) ctxt ~stack_depth @@ -2434,7 +2439,7 @@ let comparable_comb_witness1 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_axiom_with_reason "gadt"] rec parse_comparable_data : +let[@coq_struct "ty"] rec parse_comparable_data : type a. ?type_logger:type_logger -> context -> @@ -2457,7 +2462,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_comparable_data : >>?= fun ctxt -> let legacy = false in - match (ty, script_data) with + match[@coq_match_gadt_with_result] (ty, script_data) with | (Unit_t, expr) -> Lwt.return @@ traced_no_lwt @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) @@ -5645,7 +5650,7 @@ let comb_witness2 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : +let[@coq_struct "ctxt"] rec unparse_data_aux : type a ac. context -> stack_depth:int -> @@ -5661,43 +5666,51 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : else unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode ty a in let loc = Micheline.dummy_location in - match (ty, a) with - | (Unit_t, v) -> Lwt.return @@ unparse_unit ~loc ctxt v - | (Int_t, v) -> Lwt.return @@ unparse_int ~loc ctxt v - | (Nat_t, v) -> Lwt.return @@ unparse_nat ~loc ctxt v - | (String_t, s) -> Lwt.return @@ unparse_string ~loc ctxt s - | (Bytes_t, s) -> Lwt.return @@ unparse_bytes ~loc ctxt s - | (Bool_t, b) -> Lwt.return @@ unparse_bool ~loc ctxt b - | (Timestamp_t, t) -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | (Address_t, address) -> Lwt.return @@ unparse_address ~loc ctxt mode address - | (Tx_rollup_l2_address_t, address) -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + | (Unit_t, (v : unit)) -> Lwt.return @@ unparse_unit ~loc ctxt v + | (Int_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_int ~loc ctxt v + | (Nat_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_nat ~loc ctxt v + | (String_t, (s : Script_string.t)) -> + Lwt.return @@ unparse_string ~loc ctxt s + | (Bytes_t, (s : bytes)) -> Lwt.return @@ unparse_bytes ~loc ctxt s + | (Bool_t, (b : bool)) -> Lwt.return @@ unparse_bool ~loc ctxt b + | (Timestamp_t, (t : Script_timestamp.t)) -> + Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | (Address_t, (address : address)) -> + Lwt.return @@ unparse_address ~loc ctxt mode address + | (Tx_rollup_l2_address_t, (address : tx_rollup_l2_address)) -> Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | (Contract_t _, contract) -> + | (Contract_t _, (contract : _ typed_contract)) -> Lwt.return @@ unparse_contract ~loc ctxt mode contract - | (Signature_t, s) -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | (Mutez_t, v) -> Lwt.return @@ unparse_mutez ~loc ctxt v - | (Key_t, k) -> Lwt.return @@ unparse_key ~loc ctxt mode k - | (Key_hash_t, k) -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | (Operation_t, operation) -> + | (Signature_t, (s : signature)) -> + Lwt.return @@ unparse_signature ~loc ctxt mode s + | (Mutez_t, (v : Tez_repr.t)) -> Lwt.return @@ unparse_mutez ~loc ctxt v + | (Key_t, (k : public_key)) -> Lwt.return @@ unparse_key ~loc ctxt mode k + | (Key_hash_t, (k : public_key_hash)) -> + Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | (Operation_t, (operation : operation)) -> Lwt.return @@ unparse_operation ~loc ctxt operation - | (Chain_id_t, chain_id) -> + | (Chain_id_t, (chain_id : Script_chain_id.t)) -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | (Bls12_381_g1_t, x) -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x - | (Bls12_381_g2_t, x) -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x - | (Bls12_381_fr_t, x) -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x - | (Pair_t (tl, tr, _, _), pair) -> + | (Bls12_381_g1_t, (x : Script_bls.G1.t)) -> + Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x + | (Bls12_381_g2_t, (x : Script_bls.G2.t)) -> + Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x + | (Bls12_381_fr_t, (x : Script_bls.Fr.t)) -> + Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x + | (Pair_t (tl, tr, _, _), (pair : _ * _)) -> let r_witness = comb_witness2 tr in let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | (Union_t (tl, tr, _, _), v) -> + | (Union_t (tl, tr, _, _), (v : _ union)) -> let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v - | (Option_t (t, _, _), v) -> + | (Option_t (t, _, _), (v : _ option)) -> let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in unparse_option ~loc unparse_v ctxt v - | (List_t (t, _), items) -> + | (List_t (t, _), (items : _ boxed_list)) -> List.fold_left_es (fun (l, ctxt) element -> non_terminal_recursion ctxt mode t element @@ -5705,7 +5718,8 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : ([], ctxt) items.elements >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) - | (Ticket_t (t, _), {ticketer; contents; amount}) -> + | (Ticket_t (t, _), (x : _ ticket)) -> + let {ticketer; contents; amount} = x in (* ideally we would like to allow a little overhead here because it is only used for unparsing *) opened_ticket_type loc t >>?= fun opened_ticket_ty -> let t = ty_of_comparable_ty opened_ticket_ty in @@ -5717,7 +5731,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : mode t (addr, (contents, amount)) - | (Set_t (t, _), set) -> + | (Set_t (t, _), (set : _ set)) -> List.fold_left_es (fun (l, ctxt) item -> unparse_comparable_data ~loc ctxt mode t item >|=? fun (item, ctxt) -> @@ -5725,58 +5739,63 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : ([], ctxt) (Script_set.fold (fun e acc -> e :: acc) set []) >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | (Map_t (kt, vt, _), map) -> + | (Map_t (kt, vt, _), (map : _ map)) -> let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | (Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _}) - when Compare.Int.( = ) size 0 -> - return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) - | (Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _}) -> - let items = - Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] - in - let items = - (* Sort the items in Michelson comparison order and not in key - hash order. This code path is only exercised for tracing, - so we don't bother carbonating this sort operation - precisely. Also, the sort uses a reverse compare because - [unparse_items] will reverse the result. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - (* this can't fail if the original type is well-formed - because [option vt] is always strictly smaller than [big_map kt vt] *) - option_t loc vt >>?= fun vt -> - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> - ( Micheline.Prim - ( loc, - D_Pair, - [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], - [] ), - ctxt ) - | (Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _}) -> - let items = - Big_map_overlay.fold - (fun _ (k, v) acc -> - match v with None -> acc | Some v -> (k, v) :: acc) - map - [] - in - let items = - (* See note above. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | (Lambda_t _, Lam (_, original_code)) -> + | (Big_map_t (kt, vt, _), (x : _ big_map)) -> ( + let (Big_map {id; diff = {map; size; _}; _}) = x in + match id with + | Some id -> + if Compare.Int.( = ) size 0 then + return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) + else + let items = + Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] + in + let items = + (* Sort the items in Michelson comparison order and not in key + hash order. This code path is only exercised for tracing, + so we don't bother carbonating this sort operation + precisely. Also, the sort uses a reverse compare because + [unparse_items] will reverse the result. *) + List.sort + (fun (a, _) (b, _) -> + Script_comparable.compare_comparable kt b a) + items + in + (* this can't fail if the original type is well-formed + because [option vt] is always strictly smaller than [big_map kt vt] *) + option_t loc vt >>?= fun vt -> + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> + ( Micheline.Prim + ( loc, + D_Pair, + [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], + [] ), + ctxt ) + | None -> + let items = + Big_map_overlay.fold + (fun _ (k, v) acc -> + match v with None -> acc | Some v -> (k, v) :: acc) + map + [] + in + let items = + (* See note above. *) + List.sort + (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) + items + in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)) + | (Lambda_t _, (x : _ lambda)) -> + let (Lam (_, original_code)) = x in unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code | (Never_t, _) -> . - | (Sapling_transaction_t _, s) -> + | (Sapling_transaction_t _, (s : Sapling.transaction)) -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) >|? fun ctxt -> let bytes = @@ -5793,7 +5812,8 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : s in (Bytes (loc, bytes), ctxt) ) - | (Sapling_state_t _, {id; diff; _}) -> + | (Sapling_state_t _, (x : Sapling.state)) -> + let {Sapling.id; diff; _} = x in Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> ( (match diff with @@ -5815,14 +5835,14 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : Micheline.Prim (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), ctxt ) ) - | (Chest_key_t, s) -> + | (Chest_key_t, (s : Script_timelock.chest_key)) -> unparse_with_data_encoding ~loc ctxt s Unparse_costs.chest_key Script_timelock.chest_key_encoding - | (Chest_t, s) -> + | (Chest_t, (s : Script_timelock.chest)) -> unparse_with_data_encoding ~loc ctxt @@ -5831,7 +5851,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : ~plaintext_size:(Script_timelock.get_plaintext_size s)) Script_timelock.chest_encoding -and unparse_items : +and[@coq_mutual_as_notation] unparse_items : type k v vc. context -> stack_depth:int -> @@ -5850,8 +5870,7 @@ and unparse_items : ([], ctxt) items -and[@coq_axiom_with_reason "gadt"] unparse_code_aux ctxt ~stack_depth mode code - = +and[@coq_struct "ctxt"] unparse_code_aux ctxt ~stack_depth mode code = let legacy = true in Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> let non_terminal_recursion ctxt mode code = @@ -5862,7 +5881,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code_aux ctxt ~stack_depth mode code match code with | Prim (loc, I_PUSH, [ty; data], annot) -> parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty - >>?= fun (Ex_ty t, ctxt) -> + >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> let allow_forged = false (* Forgeable in PUSH data are already forbidden at parsing, @@ -5878,7 +5897,12 @@ and[@coq_axiom_with_reason "gadt"] unparse_code_aux ctxt ~stack_depth mode code t data >>=? fun (data, ctxt) -> - unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode t data + unparse_data_aux + ctxt + ~stack_depth:(stack_depth + 1) + mode + t + (data [@coq_type_annotation]) >>=? fun (data, ctxt) -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) | Seq (loc, items) -> @@ -6219,9 +6243,9 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = storage diff to show on the receipt and apply on the storage. *) -let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode +let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = - let rec aux : + let[@coq_struct "ctxt"] rec aux : type a ac. context -> unparsing_mode -> @@ -6234,9 +6258,10 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t = fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - match (has_lazy_storage, ty, x) with - | (False_f, _, _) -> return (ctxt, x, ids_to_copy, acc) - | (Big_map_f, Big_map_t (_, _, _), map) -> + match[@coq_match_gadt_with_result] (has_lazy_storage, ty, x) with + | (False_f, _, _) -> + return (ctxt, x, ids_to_copy, acc) [@coq_type_annotation] + | (Big_map_f, Big_map_t (_, _, _), (map : _ big_map)) -> diff_of_big_map ctxt mode ~temporary ~ids_to_copy map >|=? fun (diff, id, ctxt) -> let map = @@ -6251,7 +6276,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode let diff = Lazy_storage.make Big_map id diff in let ids_to_copy = Lazy_storage.IdSet.add Big_map id ids_to_copy in (ctxt, map, ids_to_copy, diff :: acc) - | (Sapling_state_f, Sapling_state_t _, sapling_state) -> + | (Sapling_state_f, Sapling_state_t _, (sapling_state : Sapling.state)) -> diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state >|=? fun (diff, id, ctxt) -> let sapling_state = @@ -6260,22 +6285,48 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode let diff = Lazy_storage.make Sapling_state id diff in let ids_to_copy = Lazy_storage.IdSet.add Sapling_state id ids_to_copy in (ctxt, sapling_state, ids_to_copy, diff :: acc) - | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr)) -> + | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ * _)) -> + let (xl, xr) = x in aux ctxt mode ~temporary ids_to_copy acc tyl xl ~has_lazy_storage:hl >>=? fun (ctxt, xl, ids_to_copy, acc) -> aux ctxt mode ~temporary ids_to_copy acc tyr xr ~has_lazy_storage:hr >|=? fun (ctxt, xr, ids_to_copy, acc) -> (ctxt, (xl, xr), ids_to_copy, acc) - | (Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x) -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) - | (Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x) -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) - | (Option_f has_lazy_storage, Option_t (ty, _, _), Some x) -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, Some x, ids_to_copy, acc) - | (List_f has_lazy_storage, List_t (ty, _), l) -> + | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), + Union_t (tyl, tyr, _, _), + (x : _ union) ) -> ( + match x with + | L x -> + aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyl + x + ~has_lazy_storage:has_lazy_storage_l + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) + | R x -> + aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyr + x + ~has_lazy_storage:has_lazy_storage_r + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) + ) + | (Option_f has_lazy_storage, Option_t (ty, _, _), (x : _ option)) -> ( + match x with + | Some x -> + aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> + (ctxt, Some x, ids_to_copy, acc) + | None -> return (ctxt, None, ids_to_copy, acc)) + | (List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list)) -> List.fold_left_es (fun (ctxt, l, ids_to_copy, acc) x -> aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage @@ -6286,7 +6337,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode >|=? fun (ctxt, l, ids_to_copy, acc) -> let reversed = {length = l.length; elements = List.rev l.elements} in (ctxt, reversed, ids_to_copy, acc) - | (Map_f has_lazy_storage, Map_t (_, ty, _), map) -> + | (Map_f has_lazy_storage, Map_t (_, ty, _), (map : _ map)) -> let (module M) = Script_map.get_module map in let bindings m = M.OPS.fold (fun k v bs -> (k, v) :: bs) m [] in List.fold_left_es @@ -6297,7 +6348,8 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode (ctxt, M.OPS.empty, ids_to_copy, acc) (bindings M.boxed) >|=? fun (ctxt, m, ids_to_copy, acc) -> - let module M = struct + let module M : + Boxed_map with type key = M.key and type value = M.value = struct module OPS = M.OPS type key = M.key @@ -6315,7 +6367,6 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode and type value = M.value), ids_to_copy, acc ) - | (_, Option_t (_, _, _), None) -> return (ctxt, None, ids_to_copy, acc) in let has_lazy_storage = has_lazy_storage ty in aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage @@ -6508,7 +6559,7 @@ let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i) single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result = match[@coq_match_gadt] (kind, id) with - | (Lazy_storage.Kind.Sapling_state, (id : Alpha_context.Sapling.Id.t)) -> ( + | (Lazy_storage.Kind.Sapling_state, (id : Sapling.Id.t)) -> ( match single_id_opt with | Fold_lazy_storage.Ok None -> Fold_lazy_storage.Ok (Some id) | Fold_lazy_storage.Ok (Some _) -> -- GitLab From a0e01c22f5fa30ded9425e5c73dc1e425ef50719 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 13 Jan 2022 14:49:55 +0100 Subject: [PATCH 041/105] Proto: more conversion of the translator --- .../lib_protocol/script_ir_translator.ml | 32 +++++++++++++------ 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index f6c7a5dffe913..ba48b7a74637e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5121,7 +5121,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : I_OPEN_CHEST; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract_aux : +and[@coq_mutual_as_notation] parse_contract_aux : type arg argc. stack_depth:int -> context -> @@ -5503,7 +5503,7 @@ let parse_storage : storage_type (root storage)) -let[@coq_axiom_with_reason "gadt"] parse_script : +let parse_script : ?type_logger:type_logger -> context -> legacy:bool -> @@ -5512,10 +5512,17 @@ let[@coq_axiom_with_reason "gadt"] parse_script : (ex_script * context) tzresult Lwt.t = fun ?type_logger ctxt ~legacy ~allow_forged_in_storage {code; storage} -> parse_code ~legacy ctxt ?type_logger ~code - >>=? fun ( Ex_code - (Code - {code; arg_type; storage_type; views; entrypoints; code_size}), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_code + (Code + { + code; + arg_type; + storage_type; + views; + entrypoints; + code_size; + }), + ctxt ) -> parse_storage ?type_logger ctxt @@ -5526,7 +5533,15 @@ let[@coq_axiom_with_reason "gadt"] parse_script : >|=? fun (storage, ctxt) -> ( Ex_script (Script - {code_size; code; arg_type; storage; storage_type; views; entrypoints}), + { + code_size; + code; + arg_type; + storage = storage [@coq_type_annotation]; + storage_type; + views; + entrypoints; + }), ctxt ) type typechecked_code_internal = @@ -6243,8 +6258,7 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = storage diff to show on the receipt and apply on the storage. *) -let extract_lazy_storage_updates ctxt mode - ~temporary ids_to_copy acc ty x = +let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = let[@coq_struct "ctxt"] rec aux : type a ac. context -> -- GitLab From 352fdbdb6bf2086b49e438539369a09d02528c70 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 13 Jan 2022 15:46:13 +0100 Subject: [PATCH 042/105] Proto: FIX: add missing order type --- src/lib_protocol_environment/environment_context_intf.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/lib_protocol_environment/environment_context_intf.ml b/src/lib_protocol_environment/environment_context_intf.ml index 3746891bc17cf..04498b15a483f 100644 --- a/src/lib_protocol_environment/environment_context_intf.ml +++ b/src/lib_protocol_environment/environment_context_intf.ml @@ -208,6 +208,8 @@ module V3 = V2 module V4 = struct type depth = V3.depth + type order = [`Sorted | `Undefined] + module type VIEW = sig include V3.VIEW -- GitLab From 13c90ca78c8fb986db0f6c71dae930eaec4e980f Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 13 Jan 2022 17:48:59 +0100 Subject: [PATCH 043/105] Proto: convert the parse_instr_aux function to Coq --- .../lib_protocol/script_ir_translator.ml | 29 ++++++++++++------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index ba48b7a74637e..35e1e7148ab18 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -3038,7 +3038,7 @@ and[@coq_struct "ctxt"] typecheck_views : in Script_map.fold_es aux views ctxt -and[@coq_axiom_with_reason "gadt"] parse_returning : +and[@coq_mutual_as_notation] parse_returning : type arg argc ret retc. ?type_logger:type_logger -> stack_depth:int -> @@ -3080,7 +3080,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : : (arg, ret) lambda), ctxt ) -and[@coq_axiom_with_reason "gadt"] parse_instr_aux : +and[@coq_struct "ctxt"] parse_instr_aux : type a s. ?type_logger:type_logger -> stack_depth:int -> @@ -3259,7 +3259,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : | (Prim (loc, I_PUSH, [t; d], annot), stack) -> check_var_annot loc annot >>?= fun () -> parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t - >>?= fun (Ex_ty t, ctxt) -> + >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) @@ -3269,7 +3269,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : t d >>=? fun (v, ctxt) -> - let const = {apply = (fun kinfo k -> IConst (kinfo, v, k))} in + let const = + {apply = (fun kinfo k -> IConst (kinfo, (v [@coq_type_annotation]), k))} + in typed ctxt loc const (Item_t (t, stack)) | (Prim (loc, I_UNIT, [], annot), stack) -> check_var_type_annot loc annot >>?= fun () -> @@ -3365,8 +3367,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : ok (Comb_proof_argument (Comb_one, Item_t (a_ty, tl_ty))) | (n, Item_t (a_ty, tl_ty)) -> make_proof_argument (n - 1) tl_ty - >>? fun (Comb_proof_argument (comb_witness, Item_t (b_ty, tl_ty'))) - -> + >>? fun [@coq_match_with_default] (Comb_proof_argument + ( comb_witness, + Item_t (b_ty, tl_ty') )) -> pair_t loc a_ty b_ty >|? fun (Ty_ex_c pair_t) -> Comb_proof_argument (Comb_succ comb_witness, Item_t (pair_t, tl_ty')) | _ -> @@ -3383,7 +3386,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : typed ctxt loc comb after_ty | (Prim (loc, I_UNPAIR, [n], annot), stack_ty) -> error_unexpected_annot loc annot >>?= fun () -> - let rec make_proof_argument : + let[@coq_struct "n_value"] rec make_proof_argument : type a s. int -> (a, s) stack_ty -> (a * s) uncomb_proof_argument tzresult = fun n stack_ty -> @@ -4639,10 +4642,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : arg_type_full ret_type_full code_field) - >>=? fun ( Lam - ( {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, - _ ), - ctxt ) -> + >>=? fun [@coq_match_with_default] ( Lam + ( { + kbef = Item_t (arg, Bot_t); + kaft = Item_t (ret, Bot_t); + _; + }, + _ ), + ctxt ) -> let views_result = typecheck_views ctxt ?type_logger ~legacy storage_type views in -- GitLab From 06b0acc05e035a8fa2623050d56a44fa326c7708 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 13 Jan 2022 19:08:44 +0100 Subject: [PATCH 044/105] Proto: end of the conversion of the translator to Coq --- .../lib_protocol/script_ir_translator.ml | 53 +++++++++++++------ 1 file changed, 37 insertions(+), 16 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 35e1e7148ab18..6965216ac4697 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2519,7 +2519,7 @@ let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness = - storage after origination *) -let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : +let[@coq_struct "ctxt"] rec parse_data_aux : type a ac. ?type_logger:type_logger -> stack_depth:int -> @@ -2663,7 +2663,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : |> traced >|=? fun (_, map, ctxt) -> (map, ctxt) in - match (ty, script_data) with + match[@coq_match_gadt_with_result] (ty, script_data) with | (Unit_t, expr) -> Lwt.return @@ traced_no_lwt @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) @@ -2734,7 +2734,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : tr script_instr | (Lambda_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) | (Option_t (t, _, _), expr) -> let parse_v ctxt v = @@ -2751,7 +2752,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : items (Script_list.empty, ctxt) | (List_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Tickets *) | (Ticket_t (t, _ty_name), expr) -> if allow_forged then @@ -2794,12 +2796,22 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : vs >|=? fun (_, set, ctxt) -> (set, ctxt) | (Set_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Maps *) | (Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr)) -> - parse_items ?type_logger ctxt expr tk tv vs (fun x -> x) + ((parse_items [@coq_type_annotation]) + ?type_logger + ctxt + expr + tk + tv + vs + (fun x -> x) + : (_ map * _) tzresult Lwt.t) | (Map_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) | (Big_map_t (tk, tv, _ty_name), expr) -> (match expr with | Int (loc, id) -> @@ -2862,14 +2874,16 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | (Bls12_381_g1_t, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Bls12_381_g2_t, Bytes (_, bs)) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt -> match Script_bls.G2.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | (Bls12_381_g2_t, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Bls12_381_fr_t, Bytes (_, bs)) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> match Script_bls.Fr.of_bytes_opt bs with @@ -2879,7 +2893,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> return (Script_bls.Fr.of_z v, ctxt) | (Bls12_381_fr_t, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) (* /!\ When adding new lazy storage kinds, you may want to guard the parsing of identifiers with [allow_forged]. @@ -2901,7 +2916,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | (Sapling_transaction_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes)) -> ( match Data_encoding.Binary.of_bytes_opt @@ -2920,7 +2936,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | (Sapling_transaction_deprecated_t _, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Sapling_state_t memo_size, Int (loc, id)) -> if allow_forged then let id = Sapling.Id.parse_z id in @@ -2934,11 +2951,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : >|? fun () -> (state, ctxt) ) else traced_fail (Unexpected_forged_value loc) | (Sapling_state_t memo_size, Seq (_, [])) -> - return (Sapling.empty_state ~memo_size (), ctxt) + ((return [@coq_type_annotation]) (Sapling.empty_state ~memo_size (), ctxt) + : (Sapling.state * _) tzresult Lwt.t) | (Sapling_state_t _, expr) -> (* Do not allow to input diffs as they are untrusted and may not be the result of a verify_update. *) - traced_fail + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) | (Chest_key_t, Bytes (_, bytes)) -> ( @@ -2951,7 +2969,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : | Some chest_key -> return (chest_key, ctxt) | None -> fail_parse_data ()) | (Chest_key_t, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Chest_t, Bytes (_, bytes)) -> ( Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) >>?= fun ctxt -> @@ -2961,7 +2980,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : | Some chest -> return (chest, ctxt) | None -> fail_parse_data ()) | (Chest_t, expr) -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) and[@coq_struct "ctxt"] parse_view_returning : type storage storagec. @@ -5659,6 +5679,7 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) | Some {name; original_type_expr} -> (Entrypoint.Map.singleton name (Ex_ty full, original_type_expr), true) in + fold_tree full entrypoints.root [] reachable ([], init) [@@coq_axiom_with_reason "unsupported syntax"] -- GitLab From a469261e3c6c029eb5d3e16988eb1e33025b06f2 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 14 Jan 2022 15:58:57 +0100 Subject: [PATCH 045/105] Proto: changes to compile rollup_inbox changes to Coq --- src/proto_alpha/lib_protocol/apply_results.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 240a0ea8c2253..d687b35ed15c4 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -891,7 +891,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_add_messages_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_add_messages_result {consumed_gas; inbox_after} -> (Gas.Arith.ceil consumed_gas, consumed_gas, inbox_after)) ~kind:Kind.Sc_rollup_add_messages_manager_kind -- GitLab From 85e6c76eb1ea8233bfaae27540096203a40097db Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 21 Jan 2022 17:45:35 +0100 Subject: [PATCH 046/105] Proto: various changes for the latest protocol updates --- src/proto_alpha/lib_protocol/script_int_repr.ml | 2 +- src/proto_alpha/lib_protocol/script_int_repr.mli | 2 +- src/proto_alpha/lib_protocol/script_interpreter.ml | 9 ++++++++- src/proto_alpha/lib_protocol/script_interpreter_defs.ml | 2 +- src/proto_alpha/lib_protocol/script_ir_translator.ml | 8 ++++++-- src/proto_alpha/lib_protocol/ticket_hash_repr.ml | 4 +++- 6 files changed, 20 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_int_repr.ml b/src/proto_alpha/lib_protocol/script_int_repr.ml index fba40417adb4d..9b74fcf18e1d6 100644 --- a/src/proto_alpha/lib_protocol/script_int_repr.ml +++ b/src/proto_alpha/lib_protocol/script_int_repr.ml @@ -35,7 +35,7 @@ type z = Integer_tag having to deconstruct to and reconstruct from `Z.t`. *) type 't repr = Z.t -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] let compare (Num_tag x) (Num_tag y) = Z.compare x y diff --git a/src/proto_alpha/lib_protocol/script_int_repr.mli b/src/proto_alpha/lib_protocol/script_int_repr.mli index 1dbb5425330dc..7abe7e93c5697 100644 --- a/src/proto_alpha/lib_protocol/script_int_repr.mli +++ b/src/proto_alpha/lib_protocol/script_int_repr.mli @@ -34,7 +34,7 @@ type 't repr [@@coq_phantom] (** [num] is made algebraic in order to distinguish it from the other type parameters of [Script_typed_ir.ty]. *) -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] (** Flag for natural numbers. *) type n = Natural_tag diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 88dce0786b0e3..25c3ba98c054a 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1473,7 +1473,14 @@ and[@coq_struct "function_parameter"] step : | Some (balance, state) -> let state = Some (Script_int.of_int64 balance, state) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) | (IChainId (_, k), _, _) -> let stack = (accu, stack) in let accu = Script_chain_id.make sc.chain_id in diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index cae340c916a23..1f872b956f2a5 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -448,7 +448,7 @@ let apply ctxt gas capture_ty capture lam = >>=? fun (const_expr, ctxt) -> let loc = Micheline.dummy_location in unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> - match full_arg_ty with + match[@coq_match_with_default] full_arg_ty with | Pair_t (capture_ty, arg_ty, _, _) -> let arg_stack_ty = Item_t (arg_ty, Bot_t) in let full_descr = diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 6965216ac4697..ac549fba55623 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -6300,7 +6300,9 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t = fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - match[@coq_match_gadt_with_result] (has_lazy_storage, ty, x) with + match[@coq_match_gadt_with_result] [@coq_match_with_default] + (has_lazy_storage, ty, x) + with | (False_f, _, _) -> return (ctxt, x, ids_to_copy, acc) [@coq_type_annotation] | (Big_map_f, Big_map_t (_, _, _), (map : _ big_map)) -> @@ -6435,7 +6437,9 @@ let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : (('acc, error) Fold_lazy_storage.result * context) tzresult = fun ~f ~init ctxt ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - match[@coq_match_gadt] (has_lazy_storage, ty, x) with + match[@coq_match_gadt] [@coq_match_with_default] + (has_lazy_storage, ty, x) + with | (Big_map_f, Big_map_t (_, _, _), (x : _ big_map)) -> ( match x with | Big_map {id = Some id; _} -> diff --git a/src/proto_alpha/lib_protocol/ticket_hash_repr.ml b/src/proto_alpha/lib_protocol/ticket_hash_repr.ml index 21c1869114041..36465bcf1245d 100644 --- a/src/proto_alpha/lib_protocol/ticket_hash_repr.ml +++ b/src/proto_alpha/lib_protocol/ticket_hash_repr.ml @@ -35,4 +35,6 @@ include Compare.Make (struct let compare = compare end) -module Index = Script_expr_hash +module Index : Storage_description.INDEX with type t = t = struct + include Script_expr_hash +end -- GitLab From 6d6e41e02c581501ab57f9565de24f97e85bd45f Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 25 Jan 2022 12:01:26 +0100 Subject: [PATCH 047/105] Proto: translate pack/unpack to Coq --- .../lib_protocol/storage_description.ml | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/storage_description.ml b/src/proto_alpha/lib_protocol/storage_description.ml index 7bac72c5a9690..aee0ea463cd9a 100644 --- a/src/proto_alpha/lib_protocol/storage_description.ml +++ b/src/proto_alpha/lib_protocol/storage_description.ml @@ -124,26 +124,28 @@ type (_, _, _) args = ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args -> ('key, 'a * 'b, 'sub_key) args -let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function +let[@coq_struct "function_parameter"] rec unpack : + type a b c. (a, b, c) args -> c -> a * b = + function[@coq_match_gadt_with_result] | One _ -> fun x -> x | Pair (l, r) -> - let unpack_l = unpack l in - let unpack_r = unpack r in + let unpack_l = (unpack [@coq_type_annotation]) l in + let unpack_r = (unpack [@coq_type_annotation]) r in fun x -> let (c, d) = unpack_r x in let (b, a) = unpack_l c in (b, (a, d)) - [@@coq_axiom_with_reason "gadt"] -let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function +let[@coq_struct "function_parameter"] rec pack : + type a b c. (a, b, c) args -> a -> b -> c = + function[@coq_match_gadt_with_result] | One _ -> fun b a -> (b, a) | Pair (l, r) -> - let pack_l = pack l in - let pack_r = pack r in + let pack_l = (pack [@coq_type_annotation]) l in + let pack_r = (pack [@coq_type_annotation]) r in fun b (a, d) -> let c = pack_l b a in pack_r c d - [@@coq_axiom_with_reason "gadt"] let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function | One {compare; _} -> compare -- GitLab From e7c1a3741edd2f29842ba5e763f1c9a905c7952e Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Mon, 31 Jan 2022 17:49:25 +0100 Subject: [PATCH 048/105] Proto: compile tx_rollup_l2_address.ml to Coq --- .../tx_rollup_commitments_storage.ml | 94 +++++++++++++++++++ 1 file changed, 94 insertions(+) create mode 100644 src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml new file mode 100644 index 0000000000000..e414e422f789a --- /dev/null +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml @@ -0,0 +1,94 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 Marigold *) +(* Copyright (c) 2021 Nomadic Labs *) +(* Copyright (c) 2021 Oxhead Alpha *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +let just_ctxt (ctxt, _, _) = ctxt + +open Tx_rollup_commitments_repr + +(** Return commitments in the order that they were submitted *) +let get_or_empty_commitments : + Raw_context.t -> + Raw_level_repr.t * Tx_rollup_repr.t -> + (Raw_context.t * Tx_rollup_commitments_repr.t) tzresult Lwt.t = + fun ctxt key -> + Storage.Tx_rollup.Commitment_list.find ctxt key >|=? fun (ctxt, commitment) -> + Option.fold + commitment + ~none:(ctxt, Tx_rollup_commitments_repr.empty) + ~some:(fun l -> (ctxt, List.rev l)) + +let get_prev_level ctxt tx_rollup level = + Tx_rollup_inbox_storage.get_adjacent_levels ctxt level tx_rollup + >|=? fun (ctxt, predecessor_level, _) -> (ctxt, predecessor_level) + +let check_commitment_predecessor_hash ctxt tx_rollup (commitment : Commitment.t) + = + let level = commitment.level in + (* Check that level has the correct predecessor *) + get_prev_level ctxt tx_rollup level >>=? fun (ctxt, predecessor_level) -> + match (predecessor_level, commitment.predecessor) with + | (None, None) -> return ctxt + | (Some _, None) | (None, Some _) -> fail Wrong_commitment_predecessor_level + | (Some predecessor_level, Some hash) -> + (* The predecessor level must include this commitment*) + get_or_empty_commitments ctxt (predecessor_level, tx_rollup) + >>=? fun (ctxt, predecesor_commitments) -> + fail_unless + (Tx_rollup_commitments_repr.commitment_exists + predecesor_commitments + hash) + Missing_commitment_predecessor + >>=? fun () -> return ctxt + +let add_commitment ctxt tx_rollup contract (commitment : Commitment.t) = + let key = (commitment.level, tx_rollup) in + get_or_empty_commitments ctxt key >>=? fun (ctxt, pending) -> + Tx_rollup_inbox_storage.get ctxt ~level:(Level commitment.level) tx_rollup + >>=? fun (ctxt, inbox) -> + let expected_len = List.length inbox.contents in + let actual_len = List.length commitment.batches in + fail_unless Compare.Int.(expected_len = actual_len) Wrong_batch_count + >>=? fun () -> + check_commitment_predecessor_hash ctxt tx_rollup commitment >>=? fun ctxt -> + Tx_rollup_commitments_repr.append + pending + contract + commitment + (Raw_context.current_level ctxt).level + >>?= fun new_pending -> + Storage.Tx_rollup.Commitment_list.add ctxt key new_pending >|=? just_ctxt + +let get_commitments : + Raw_context.t -> + Tx_rollup_repr.t -> + Raw_level_repr.t -> + (Raw_context.t * Tx_rollup_commitments_repr.t) tzresult Lwt.t = + fun ctxt tx_rollup level -> + Storage.Tx_rollup.State.find ctxt tx_rollup >>=? fun (ctxt, state) -> + match state with + | None -> fail @@ Tx_rollup_state_storage.Tx_rollup_does_not_exist tx_rollup + | Some _ -> get_or_empty_commitments ctxt (level, tx_rollup) -- GitLab From d723205cd142d70e92f770b444a6ae82a9270a28 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 1 Feb 2022 17:26:57 +0100 Subject: [PATCH 049/105] Proto: fix compilation of ticket_operations_diff.ml to Coq --- src/proto_alpha/lib_protocol/ticket_operations_diff.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index 60837e56e1724..a508530f3078a 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -187,9 +187,9 @@ let tickets_of_transaction ctxt ~destination ~entrypoint ~location match script_opt with | None -> fail (Failed_to_get_script destination) | Some script -> return (script, ctxt)) - >>=? fun ( Script_ir_translator.Ex_script - (Script {arg_type; entrypoints; _}), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Script_ir_translator.Ex_script + (Script {arg_type; entrypoints; _}), + ctxt ) -> (* Find the entrypoint type for the given entrypoint. *) Gas_monad.run ctxt -- GitLab From fb4dc0ef0a5d334a77d2c14a55935ea058b1c0a2 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 3 Feb 2022 13:01:27 +0100 Subject: [PATCH 050/105] Proto: compile changes of 2022-02-03 to Coq --- src/lib_protocol_environment/sigs/v5/bounded.mli | 2 +- src/lib_protocol_environment/sigs/v5/context.mli | 1 + src/proto_alpha/lib_protocol/sc_rollup_repr.ml | 3 ++- src/proto_alpha/lib_protocol/sc_rollup_repr.mli | 2 +- src/proto_alpha/lib_protocol/tx_rollup_repr.ml | 4 +++- 5 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/lib_protocol_environment/sigs/v5/bounded.mli b/src/lib_protocol_environment/sigs/v5/bounded.mli index 46539808d0884..f2a037d48a7b1 100644 --- a/src/lib_protocol_environment/sigs/v5/bounded.mli +++ b/src/lib_protocol_environment/sigs/v5/bounded.mli @@ -66,5 +66,5 @@ module Int32 : sig allow future compatiblity with larger bounds, at the price of addding 1-3 redundant bytes to each message. *) - module Make (_ : BOUNDS) : S + module Make (B : BOUNDS) : S end diff --git a/src/lib_protocol_environment/sigs/v5/context.mli b/src/lib_protocol_environment/sigs/v5/context.mli index 4d7ccd466b731..068eedd5add5f 100644 --- a/src/lib_protocol_environment/sigs/v5/context.mli +++ b/src/lib_protocol_environment/sigs/v5/context.mli @@ -139,6 +139,7 @@ end module Kind : sig type t = [`Value | `Tree] end +[@@coq_plain_module] module type TREE = sig (** [Tree] provides immutable, in-memory partial mirror of the diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml index 411a3f4bfb6c5..f26031dbc110b 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml @@ -219,7 +219,8 @@ module Index = struct let compare = Address.compare end -module Commitment_hash_index = struct +module Commitment_hash_index : + Storage_description.INDEX with type t = Commitment_hash.t = struct include Commitment_hash end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli index ccfff22d95347..decea0652e935 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli @@ -56,7 +56,7 @@ module Internal_for_tests : sig val originated_sc_rollup : Origination_nonce.t -> Address.t end -module Commitment_hash : S.HASH +module Commitment_hash : S.HASH [@@coq_plain_module] module State_hash : S.HASH diff --git a/src/proto_alpha/lib_protocol/tx_rollup_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_repr.ml index 2623a090fe3ec..8782ee21d6068 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_repr.ml @@ -83,7 +83,9 @@ let in_memory_size _ = let to_b58check rollup = Hash.to_b58check rollup let of_b58check_opt s = - match Base58.decode s with Some (Hash.Data hash) -> Some hash | _ -> None + match Base58.decode s with + | Some data -> ( match data with Hash.Data hash -> Some hash | _ -> None) + | _ -> None let of_b58check s = match of_b58check_opt s with -- GitLab From bbb63164cb67ff4ff8ff66a4b0055058fc471eed Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 4 Feb 2022 16:00:02 +0100 Subject: [PATCH 051/105] Proto: fix compilation of ticket_hash_builder.ml in Coq --- src/proto_alpha/lib_protocol/ticket_hash_builder.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/proto_alpha/lib_protocol/ticket_hash_builder.ml b/src/proto_alpha/lib_protocol/ticket_hash_builder.ml index fc7f79181e183..1fdc9e9245dc1 100644 --- a/src/proto_alpha/lib_protocol/ticket_hash_builder.ml +++ b/src/proto_alpha/lib_protocol/ticket_hash_builder.ml @@ -41,11 +41,11 @@ let () = (fun () -> Failed_to_hash_node) let hash_bytes_cost bytes = - let module S = Saturation_repr in - let ( + ) = S.add in - let v0 = S.safe_int @@ Bytes.length bytes in - let ( lsr ) = S.shift_right in - S.safe_int 200 + (v0 + (v0 lsr 2)) |> Gas_limit_repr.atomic_step_cost + let ( + ) = Saturation_repr.add in + let v0 = Saturation_repr.safe_int @@ Bytes.length bytes in + let ( lsr ) = Saturation_repr.shift_right in + Saturation_repr.safe_int 200 + (v0 + (v0 lsr 2)) + |> Gas_limit_repr.atomic_step_cost let hash_of_node ctxt node = Raw_context.consume_gas ctxt (Script_repr.strip_locations_cost node) -- GitLab From 80580d342dce850af7feae4dd727cc32a3e6dd2f Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 9 Feb 2022 18:47:11 +0100 Subject: [PATCH 052/105] Proto: fix compilation of the translator for coq-of-ocaml --- .../lib_protocol/script_ir_translator.ml | 111 ++++++++++-------- 1 file changed, 64 insertions(+), 47 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index ac549fba55623..a76734398e3c2 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1255,7 +1255,7 @@ type ('ret, 'name) parse_ty_ret = | Parse_entrypoints : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret -let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty_aux : +let[@coq_struct "node_value"] rec parse_ty_aux : type ret name. context -> stack_depth:int -> @@ -1281,11 +1281,11 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty error Typechecking_too_many_recursive_calls else (match ret with - | Don't_parse_entrypoints -> ok (node, (() : name)) + | Don't_parse_entrypoints -> ok (node, None) | Parse_entrypoints -> extract_entrypoint_annot node) >>? fun (node, name) -> let return ctxt ty : ret * context = - match ret with + match[@coq_match_gadt_with_result] ret with | Don't_parse_entrypoints -> (Ex_ty ty, ctxt) | Parse_entrypoints -> let at_node = @@ -1420,12 +1420,22 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty utr >>? fun (parsed_r, ctxt) -> check_type_annot loc annot >>? fun () -> - match ret with - | Don't_parse_entrypoints -> + match[@coq_match_gadt_with_result] + ( ret, + (parsed_l [@coq_type_annotation]), + (parsed_r [@coq_type_annotation]) ) + with + | (Don't_parse_entrypoints, (parsed_l : ex_ty), (parsed_r : ex_ty)) -> let (Ex_ty tl) = parsed_l in let (Ex_ty tr) = parsed_r in union_t loc tl tr >|? fun (Ty_ex_c ty) -> ((Ex_ty ty : ret), ctxt) - | Parse_entrypoints -> + + (* | Parse_entrypoints -> + * let (Ex_parameter_ty_and_entrypoints_node *) + + | ( Parse_entrypoints, + (parsed_l : ex_parameter_ty_and_entrypoints_node), + (parsed_r : ex_parameter_ty_and_entrypoints_node) ) -> let (Ex_parameter_ty_and_entrypoints_node {arg_type = tl; entrypoints = left}) = parsed_l @@ -1595,7 +1605,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty T_tx_rollup_l2_address; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty_aux_with_ret : +and[@coq_mutual_as_notation] parse_passable_ty_aux_with_ret : type ret name. context -> stack_depth:int -> @@ -1604,35 +1614,34 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab Script.node -> (ret * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty_aux [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:false - ~allow_contract:true - ~allow_ticket:true + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:false + ~allow_contract:true + ~allow_ticket:true [@coq_type_annotation]) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty_aux - : +and[@coq_mutual_as_notation] parse_any_ty_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty_aux [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:true - ~allow_contract:true - ~allow_ticket:true - ~ret:Don't_parse_entrypoints - -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_ty - ctxt ~stack_depth ~legacy big_map_loc args map_annot = + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:true + ~allow_contract:true + ~allow_ticket:true + ~ret:Don't_parse_entrypoints [@coq_type_annotation]) + +and[@coq_struct "args"] parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc + args map_annot = Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt -> match args with | [key_ty; value_ty] -> @@ -1651,16 +1660,16 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma and[@coq_mutual_as_notation] parse_big_map_value_ty_aux ctxt ~stack_depth ~legacy value_ty = - (parse_ty_aux [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:false - ~allow_operation:false - ~allow_contract:legacy - ~allow_ticket:true - ~ret:Don't_parse_entrypoints - value_ty + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:false + ~allow_operation:false + ~allow_contract:legacy + ~allow_ticket:true + ~ret:Don't_parse_entrypoints + value_ty [@coq_type_annotation]) let parse_packable_ty_aux ctxt ~stack_depth ~legacy node = (parse_ty_aux [@tailcall]) @@ -1958,7 +1967,7 @@ let find_entrypoint (type full fullc error_trace) (t ex_ty_cstr, unit) Gas_monad.t = fun ty entrypoints entrypoint -> let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in - match (ty, entrypoints) with + match[@coq_match_with_default] (ty, entrypoints) with | (_, {at_node = Some {name; original_type_expr}; _}) when Entrypoint.(name = entrypoint) -> return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) @@ -2078,7 +2087,7 @@ type ex_parameter_ty_and_entrypoints = } -> ex_parameter_ty_and_entrypoints -let parse_parameter_ty_and_entrypoints : +let parse_parameter_ty_and_entrypoints_aux : context -> stack_depth:int -> legacy:bool -> @@ -4633,7 +4642,7 @@ and[@coq_struct "ctxt"] parse_instr_aux : >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> record_trace (Ill_formed_type (Some "parameter", canonical_code, location arg_type)) - (parse_parameter_ty_and_entrypoints + (parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -5190,7 +5199,7 @@ and[@coq_mutual_as_notation] parse_contract_aux : (* can only fail because of gas *) parse_toplevel_aux ctxt ~legacy:true code >>? fun ({arg_type; _}, ctxt) -> - parse_parameter_ty_and_entrypoints + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy:true @@ -5393,7 +5402,7 @@ let parse_contract_for_script : | Error _ -> error (Invalid_contract (loc, contract)) | Ok ({arg_type; _}, ctxt) -> ( match - parse_parameter_ty_and_entrypoints + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:0 ~legacy:true @@ -5473,7 +5482,11 @@ let parse_code : let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux + ctxt + ~stack_depth:0 + ~legacy + arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5596,7 +5609,11 @@ let typecheck_code : let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux + ctxt + ~stack_depth:0 + ~legacy + arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -6598,7 +6615,7 @@ let parse_any_ty = parse_any_ty_aux ~stack_depth:0 let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints let parse_parameter_ty_and_entrypoints = - parse_parameter_ty_and_entrypoints ~stack_depth:0 + parse_parameter_ty_and_entrypoints_aux ~stack_depth:0 let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = let has_lazy_storage = has_lazy_storage ty in -- GitLab From e901dda6f997a90c2ccc52d87862cb1f007d00da Mon Sep 17 00:00:00 2001 From: Klaus Andrey Date: Fri, 11 Feb 2022 13:15:19 +0300 Subject: [PATCH 053/105] fixed wrong function definitions for value_size_aux and apply_comparable --- .../lib_protocol/script_ir_translator.ml | 2 - .../lib_protocol/script_typed_ir_size.ml | 125 ++++++++++-------- 2 files changed, 71 insertions(+), 56 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a76734398e3c2..8f61a060833ae 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1429,10 +1429,8 @@ let[@coq_struct "node_value"] rec parse_ty_aux : let (Ex_ty tl) = parsed_l in let (Ex_ty tr) = parsed_r in union_t loc tl tr >|? fun (Ty_ex_c ty) -> ((Ex_ty ty : ret), ctxt) - (* | Parse_entrypoints -> * let (Ex_parameter_ty_and_entrypoints_node *) - | ( Parse_entrypoints, (parsed_l : ex_parameter_ty_and_entrypoints_node), (parsed_r : ex_parameter_ty_and_entrypoints_node) ) -> diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index f46201049b840..de02340b4d045 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -244,88 +244,105 @@ let[@coq_struct "ty"] rec value_size_aux : fun ~count_lambda_nodes accu ty x -> let apply : type a ac. nodes_and_size -> (a, ac) ty -> a -> nodes_and_size = fun accu ty x -> - match[@coq_match_gadt] [@coq_match_with_default] ty with - | Unit_t -> ret_succ accu - | Int_t -> ret_succ_adding accu (script_int_size x) - | Nat_t -> ret_succ_adding accu (script_nat_size x) - | Signature_t -> ret_succ_adding accu signature_size - | String_t -> ret_succ_adding accu (script_string_size x) - | Bytes_t -> ret_succ_adding accu (bytes_size x) - | Mutez_t -> ret_succ_adding accu mutez_size - | Key_hash_t -> ret_succ_adding accu (key_hash_size x) - | Key_t -> ret_succ_adding accu (public_key_size x) - | Timestamp_t -> ret_succ_adding accu (timestamp_size x) - | Address_t -> ret_succ_adding accu (address_size x) - | Tx_rollup_l2_address_t -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, x) with + | (Unit_t, _) -> ret_succ accu + | (Int_t, (x : _ Script_int.num)) -> + ret_succ_adding accu (script_int_size x) + | (Nat_t, (x : _ Script_int.num)) -> + ret_succ_adding accu (script_nat_size x) + | (Signature_t, _) -> ret_succ_adding accu signature_size + | (String_t, (x : Script_string.t)) -> + ret_succ_adding accu (script_string_size x) + | (Bytes_t, (x : bytes)) -> ret_succ_adding accu (bytes_size x) + | (Mutez_t, _) -> ret_succ_adding accu mutez_size + | (Key_hash_t, (x : public_key_hash)) -> + ret_succ_adding accu (key_hash_size x) + | (Key_t, (x : public_key)) -> ret_succ_adding accu (public_key_size x) + | (Timestamp_t, (x : Script_timestamp.t)) -> + ret_succ_adding accu (timestamp_size x) + | (Address_t, (x : address)) -> ret_succ_adding accu (address_size x) + | (Tx_rollup_l2_address_t, (x : tx_rollup_l2_address)) -> ret_succ_adding accu (tx_rollup_l2_address_size x) - | Bool_t -> ret_succ accu - | Pair_t (_, _, _, _) -> ret_succ_adding accu h2w - | Union_t (_, _, _, _) -> ret_succ_adding accu h1w - | Lambda_t (_, _, _) -> + | (Bool_t, _) -> ret_succ accu + | (Pair_t (_, _, _, _), _) -> ret_succ_adding accu h2w + | (Union_t (_, _, _, _), _) -> ret_succ_adding accu h1w + | (Lambda_t (_, _, _), (x : _ lambda)) -> (lambda_size_aux [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) x - | Option_t (_, _, _) -> ret_succ_adding accu (option_size (fun _ -> !!0) x) - | List_t (_, _) -> ret_succ_adding accu (h2w +! (h2w *? x.length)) - | Set_t (_, _) -> + | (Option_t (_, _, _), (x : _ option)) -> + ret_succ_adding accu (option_size (fun _ -> !!0) x) + | (List_t (_, _), (x : _ boxed_list)) -> + ret_succ_adding accu (h2w +! (h2w *? x.length)) + | (Set_t (_, _), (x : _ set)) -> let module M = (val Script_set.get x) in let boxing_space = !!536 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h4w *? M.size)) - | Map_t (_, _, _) -> + | (Map_t (_, _, _), (x : _ map)) -> let module M = (val Script_map.get_module x) in let boxing_space = !!696 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h5w *? M.size)) - | Big_map_t (cty, ty', _) -> + | (Big_map_t (cty, ty', _), (x : _ big_map)) -> (big_map_size_aux [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) cty ty' x - | Contract_t (_, _) -> ret_succ (accu ++ contract_size x) - | Sapling_transaction_t _ -> + | (Contract_t (_, _), (x : _ typed_contract)) -> + ret_succ (accu ++ contract_size x) + | (Sapling_transaction_t _, (x : Sapling.transaction)) -> ret_succ_adding accu (Sapling.transaction_in_memory_size x) - | Sapling_transaction_deprecated_t _ -> + | (Sapling_transaction_deprecated_t _, (x : Sapling_repr.legacy_transaction)) + -> ret_succ_adding accu (Sapling.Legacy.transaction_in_memory_size x) - | Sapling_state_t _ -> ret_succ_adding accu (sapling_state_size x) + | (Sapling_state_t _, (x : Sapling.state)) -> + ret_succ_adding accu (sapling_state_size x) (* Operations are neither storable nor pushable, so they can appear neither in the storage nor in the script. Hence they cannot appear in the cache and we never need to measure their size. *) - | Operation_t -> assert false - | Chain_id_t -> ret_succ_adding accu chain_id_size - | Never_t -> ( match x with _ -> .) - | Bls12_381_g1_t -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory - | Bls12_381_g2_t -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory - | Bls12_381_fr_t -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory - | Ticket_t (_, _) -> ret_succ_adding accu (ticket_size x) - | Chest_key_t -> ret_succ_adding accu (chest_key_size x) - | Chest_t -> ret_succ_adding accu (chest_size x) + | (Operation_t, _) -> assert false + | (Chain_id_t, _) -> ret_succ_adding accu chain_id_size + | (Never_t, _) -> . + | (Bls12_381_g1_t, _) -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory + | (Bls12_381_g2_t, _) -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory + | (Bls12_381_fr_t, _) -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory + | (Ticket_t (_, _), (x : _ ticket)) -> ret_succ_adding accu (ticket_size x) + | (Chest_key_t, (x : Script_timelock.chest_key)) -> + ret_succ_adding accu (chest_key_size x) + | (Chest_t, (x : Script_timelock.chest)) -> + ret_succ_adding accu (chest_size x) in let apply_comparable : type a. nodes_and_size -> a comparable_ty -> a -> nodes_and_size = fun accu ty x -> - match[@coq_match_gadt] [@coq_match_with_default] ty with - | Unit_t -> ret_succ accu - | Int_t -> ret_succ_adding accu (script_int_size x) - | Nat_t -> ret_succ_adding accu (script_nat_size x) - | Signature_t -> ret_succ_adding accu signature_size - | String_t -> ret_succ_adding accu (script_string_size x) - | Bytes_t -> ret_succ_adding accu (bytes_size x) - | Mutez_t -> ret_succ_adding accu mutez_size - | Key_hash_t -> ret_succ_adding accu (key_hash_size x) - | Key_t -> ret_succ_adding accu (public_key_size x) - | Timestamp_t -> ret_succ_adding accu (timestamp_size x) - | Address_t -> ret_succ_adding accu (address_size x) - | Tx_rollup_l2_address_t -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, x) with + | (Unit_t, _) -> ret_succ accu + | (Int_t, (x : _ Script_int.num)) -> + ret_succ_adding accu (script_int_size x) + | (Nat_t, (x : _ Script_int.num)) -> + ret_succ_adding accu (script_nat_size x) + | (Signature_t, _) -> ret_succ_adding accu signature_size + | (String_t, (x : Script_string.t)) -> + ret_succ_adding accu (script_string_size x) + | (Bytes_t, (x : bytes)) -> ret_succ_adding accu (bytes_size x) + | (Mutez_t, _) -> ret_succ_adding accu mutez_size + | (Key_hash_t, (x : public_key_hash)) -> + ret_succ_adding accu (key_hash_size x) + | (Key_t, (x : public_key)) -> ret_succ_adding accu (public_key_size x) + | (Timestamp_t, (x : Script_timestamp.t)) -> + ret_succ_adding accu (timestamp_size x) + | (Address_t, (x : address)) -> ret_succ_adding accu (address_size x) + | (Tx_rollup_l2_address_t, (x : tx_rollup_l2_address)) -> ret_succ_adding accu (tx_rollup_l2_address_size x) - | Bool_t -> ret_succ accu - | Pair_t (_, _, _, YesYes) -> ret_succ_adding accu h2w - | Union_t (_, _, _, YesYes) -> ret_succ_adding accu h1w - | Option_t (_, _, Yes) -> + | (Bool_t, _) -> ret_succ accu + | (Pair_t (_, _, _, _), _) -> ret_succ_adding accu h2w + | (Union_t (_, _, _, YesYes), _) -> ret_succ_adding accu h1w + | (Option_t (_, _, Yes), (x : _ option)) -> ret_succ_adding accu (option_size (fun _ -> !!0) x) - | Chain_id_t -> ret_succ_adding accu chain_id_size - | Never_t -> ( match x with _ -> .) + | (Chain_id_t, _) -> ret_succ_adding accu chain_id_size + | (Never_t, _) -> . in value_traverse ty x accu {apply; apply_comparable} -- GitLab From 8eb26d1c9ce1abdcd9f5719f97ede1fe8346d84c Mon Sep 17 00:00:00 2001 From: Klaus Andrey Date: Fri, 11 Feb 2022 19:16:46 +0300 Subject: [PATCH 054/105] WIP --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 8f61a060833ae..07759fbe1407b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -6615,7 +6615,7 @@ let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints let parse_parameter_ty_and_entrypoints = parse_parameter_ty_and_entrypoints_aux ~stack_depth:0 -let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = +let get_single_sapling_state ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i) single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result = -- GitLab From 16858cd6fb2777875162825cfd68c3af085229db Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 11 Feb 2022 18:30:57 +0100 Subject: [PATCH 055/105] UNSAFE: removing the 'assert false' from the storage functors --- src/proto_alpha/lib_protocol/storage_functors.ml | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml index 3c4d9bd4c3643..e727c320061ea 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/storage_functors.ml @@ -247,7 +247,9 @@ module Make_data_set_storage (C : Raw_context.T) (I : INDEX) : C.fold ~depth:(`Eq I.path_length) s [] ~order ~init ~f:(fun file tree acc -> match C.Tree.kind tree with | `Value -> ( - match I.of_path file with None -> assert false | Some p -> f p acc) + match I.of_path file with + | None -> Lwt.return acc + | Some p -> f p acc) | `Tree -> Lwt.return acc) let elements s = @@ -319,7 +321,7 @@ struct C.Tree.to_value tree >>= function | Some v -> ( match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some path -> ( let key () = C.absolute_key s file in match of_bytes ~key v with @@ -495,7 +497,7 @@ module Make_indexed_carbonated_data_storage_INTERNAL else (* Nominal case *) match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some key -> get_unprojected s key >|=? fun (s, value) -> (s, value :: rev_values, 0, pred length)) @@ -518,9 +520,9 @@ module Make_indexed_carbonated_data_storage_INTERNAL | last :: rest when Compare.String.(last = data_name) -> ( let file = List.rev rest in match I.of_path file with - | None -> assert false + | None -> Lwt.return acc | Some path -> f path acc) - | _ -> assert false) + | _ -> Lwt.return acc) | `Tree -> Lwt.return acc) let keys_unaccounted s = @@ -640,7 +642,7 @@ module Make_indexed_data_snapshotable_storage C.Tree.to_value tree >>= function | Some v -> ( match I.of_path file with - | None -> assert false + | None -> return acc | Some path -> ( let key () = C.absolute_key s file in match V_encoder.of_bytes ~key v with @@ -672,7 +674,7 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : match C.Tree.kind tree with | `Tree -> ( match I.of_path path with - | None -> assert false + | None -> Lwt.return acc | Some path -> f path acc) | `Value -> Lwt.return acc) -- GitLab From eb05c9e14f6311ea97799f3f23c33c2bdd5b6a3c Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 11 Feb 2022 19:51:26 +0100 Subject: [PATCH 056/105] Proto: fix inlining of comparison for Coq --- src/lib_protocol_environment/sigs/v5/compare.mli | 1 + 1 file changed, 1 insertion(+) diff --git a/src/lib_protocol_environment/sigs/v5/compare.mli b/src/lib_protocol_environment/sigs/v5/compare.mli index 0437dd1e23de5..38f5f19e98bd3 100644 --- a/src/lib_protocol_environment/sigs/v5/compare.mli +++ b/src/lib_protocol_environment/sigs/v5/compare.mli @@ -120,6 +120,7 @@ module Int : sig external equal : int -> int -> bool = "%equal" end +[@@coq_plain_module] module Int32 : S with type t = int32 -- GitLab From bf89698510ffed0259f701241d8ea9a82c22616b Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 4 Mar 2022 15:20:19 +0100 Subject: [PATCH 057/105] Proto: changes to help coq-of-ocaml --- src/proto_alpha/lib_protocol/indexable.ml | 51 ++- src/proto_alpha/lib_protocol/indexable.mli | 16 +- src/proto_alpha/lib_protocol/level_repr.ml | 3 +- .../lib_protocol/script_string_repr.ml | 2 +- src/proto_alpha/lib_protocol/seed_repr.ml | 4 +- .../tx_rollup_commitments_repr.ml | 320 ++++++++++++++++++ 6 files changed, 379 insertions(+), 17 deletions(-) create mode 100644 src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml diff --git a/src/proto_alpha/lib_protocol/indexable.ml b/src/proto_alpha/lib_protocol/indexable.ml index 918e33f7d2164..efd4595208f22 100644 --- a/src/proto_alpha/lib_protocol/indexable.ml +++ b/src/proto_alpha/lib_protocol/indexable.ml @@ -148,10 +148,13 @@ let compare : | ((Hidden_value _ | Value _), (Hidden_index _ | Index _)) -> 1 let compare_values c : 'a value -> 'a value -> int = - fun (Value x) (Value y) -> c x y + fun x y -> + match[@coq_match_with_default] (x, y) with (Value x, Value y) -> c x y let compare_indexes : 'a index -> 'a index -> int = - fun (Index x) (Index y) -> Compare.Int32.compare x y + fun x y -> + match[@coq_match_with_default] (x, y) with + | (Index x, Index y) -> Compare.Int32.compare x y module type VALUE = sig type t @@ -163,7 +166,41 @@ module type VALUE = sig val pp : Format.formatter -> t -> unit end -module Make (V : VALUE) = struct +module type INDEXABLE = sig + type v_t + + type nonrec 'state t = ('state, v_t) t + + type nonrec index = v_t index + + type nonrec value = v_t value + + type nonrec either = v_t either + + val value : v_t -> value + + val index : int32 -> index tzresult + + val index_exn : int32 -> index + + val compact : either Data_encoding.Compact.t + + val encoding : either Data_encoding.t + + val index_encoding : index Data_encoding.t + + val value_encoding : value Data_encoding.t + + val compare : 'state t -> 'state' t -> int + + val compare_values : value -> value -> int + + val compare_indexes : index -> index -> int + + val pp : Format.formatter -> 'state t -> unit +end + +module Make (V : VALUE) : INDEXABLE with type v_t := V.t = struct type nonrec 'state t = ('state, V.t) t type nonrec index = V.t index @@ -172,15 +209,15 @@ module Make (V : VALUE) = struct type nonrec either = V.t either - let value = value + let value : V.t -> value = value - let index = index + let index : int32 -> index tzresult = index - let index_exn = index_exn + let index_exn : int32 -> index = index_exn let compact = compact V.encoding - let encoding = encoding V.encoding + let encoding : either Data_encoding.t = encoding V.encoding let index_encoding : index Data_encoding.t = Data_encoding.( diff --git a/src/proto_alpha/lib_protocol/indexable.mli b/src/proto_alpha/lib_protocol/indexable.mli index cc921e802f1f6..e71d8926bc4a5 100644 --- a/src/proto_alpha/lib_protocol/indexable.mli +++ b/src/proto_alpha/lib_protocol/indexable.mli @@ -162,16 +162,18 @@ module type VALUE = sig val pp : Format.formatter -> t -> unit end -module Make (V : VALUE) : sig - type nonrec 'state t = ('state, V.t) t +module type INDEXABLE = sig + type v_t - type nonrec index = V.t index + type nonrec 'state t = ('state, v_t) t - type nonrec value = V.t value + type nonrec index = v_t index - type nonrec either = V.t either + type nonrec value = v_t value - val value : V.t -> value + type nonrec either = v_t either + + val value : v_t -> value val index : int32 -> index tzresult @@ -194,4 +196,6 @@ module Make (V : VALUE) : sig val pp : Format.formatter -> 'state t -> unit end +module Make (V : VALUE) : INDEXABLE with type v_t := V.t + type error += Index_cannot_be_negative of int32 diff --git a/src/proto_alpha/lib_protocol/level_repr.ml b/src/proto_alpha/lib_protocol/level_repr.ml index 0b5926f387f57..cc16715354fcb 100644 --- a/src/proto_alpha/lib_protocol/level_repr.ml +++ b/src/proto_alpha/lib_protocol/level_repr.ml @@ -130,7 +130,8 @@ let create_cycle_eras cycle_eras = match cycle_eras with | [] -> error Invalid_cycle_eras | newest_era :: older_eras -> - let rec aux {first_level; first_cycle; _} older_eras = + let rec aux era older_eras = + let {first_level; first_cycle; _} = era in match older_eras with | ({ first_level = first_level_of_previous_era; diff --git a/src/proto_alpha/lib_protocol/script_string_repr.ml b/src/proto_alpha/lib_protocol/script_string_repr.ml index b3108eb31ef23..ea0c6bca872cc 100644 --- a/src/proto_alpha/lib_protocol/script_string_repr.ml +++ b/src/proto_alpha/lib_protocol/script_string_repr.ml @@ -57,7 +57,7 @@ let () = let empty = String_tag "" let of_string v = - let rec check_printable_ascii i = + let[@coq_struct "i_value"] rec check_printable_ascii i = if Compare.Int.(i < 0) then ok (String_tag v) else match v.[i] with diff --git a/src/proto_alpha/lib_protocol/seed_repr.ml b/src/proto_alpha/lib_protocol/seed_repr.ml index 68e4e4452f0d2..bc8c2dec03c06 100644 --- a/src/proto_alpha/lib_protocol/seed_repr.ml +++ b/src/proto_alpha/lib_protocol/seed_repr.ml @@ -78,7 +78,7 @@ let take_int32 s bound = let drop_if_over = Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) in - let rec loop s = + let[@coq_struct "s_value"] rec loop s = let (bytes, s) = take s in let r = TzEndian.get_int32 bytes 0 in (* The absolute value of min_int is min_int. Also, every @@ -101,7 +101,7 @@ let take_int64 s bound = Int64.sub Int64.max_int (Int64.rem Int64.max_int bound) in - let rec loop s = + let[@coq_struct "s_value"] rec loop s = let (bytes, s) = take s in let r = TzEndian.get_int64 bytes 0 in (* The absolute value of min_int is min_int. Also, every diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml new file mode 100644 index 0000000000000..1c356cfd7890b --- /dev/null +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml @@ -0,0 +1,320 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Marigold *) +(* Copyright (c) 2022 Nomadic Labs *) +(* Copyright (c) 2022 Oxhead Alpha *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += (* `Branch *) Commitment_hash_already_submitted + +type error += (* `Branch *) Two_commitments_from_one_committer + +type error += (* `Branch *) Wrong_commitment_predecessor_level + +type error += (* `Temporary *) Missing_commitment_predecessor + +type error += (* `Branch *) Wrong_batch_count + +type error += (* `Temporary *) Commitment_too_early + +let () = + let open Data_encoding in + (* Commitment_hash_already_submitted *) + register_error_kind + `Temporary + ~id:"tx_rollup_commit_hash_already_submitted" + ~title:"Someone already made this commitment" + ~description:"The requested commitment is a duplicate" + unit + (function Commitment_hash_already_submitted -> Some () | _ -> None) + (fun () -> Commitment_hash_already_submitted) ; + (* Two_commitments_from_one_committer *) + register_error_kind + `Temporary + ~id:"tx_rollup_two_commitments_from_one_committer" + ~title:"This contract already made a different commitment at this level" + ~description: + "This contract already made a different commitment at this level" + unit + (function Two_commitments_from_one_committer -> Some () | _ -> None) + (fun () -> Two_commitments_from_one_committer) ; + (* Wrong_commitment_predecessor_level *) + register_error_kind + `Temporary + ~id:"tx_rollup_wrong_commitment_predecessor_level" + ~title:"This commitment's predecessor is invalid" + ~description: + "This commitment has predecessor but shouldn't, or doesn't but should" + unit + (function Wrong_commitment_predecessor_level -> Some () | _ -> None) + (fun () -> Wrong_commitment_predecessor_level) ; + (* Missing_commitment_predecessor *) + register_error_kind + `Temporary + ~id:"tx_rollup_missing_commitment_predecessor" + ~title:"This commitment refers to a predecessor that doesn't exist" + ~description:"This commitment refers to a predecessor that doesn't exist" + unit + (function Missing_commitment_predecessor -> Some () | _ -> None) + (fun () -> Missing_commitment_predecessor) ; + (* Wrong_batch_count *) + register_error_kind + `Temporary + ~id:"tx_rollup_wrong_batch_count" + ~title:"This commitment has the wrong number of batches" + ~description: + "This commitment has a different number of batches than its inbox" + unit + (function Wrong_batch_count -> Some () | _ -> None) + (fun () -> Wrong_batch_count) ; + (* Commitment_too_early *) + register_error_kind + `Temporary + ~id:"tx_rollup_commitment_too_early" + ~title:"This commitment is for a level that hasn't finished yet" + ~description:"This commitment is for a level that hasn't finished yet" + unit + (function Commitment_too_early -> Some () | _ -> None) + (fun () -> Commitment_too_early) + +let compare_or cmp c1 c2 f = match cmp c1 c2 with 0 -> f () | diff -> diff + +module Commitment_hash = struct + let commitment_hash = "\017\249\195\013" (* toc1(54) *) + + module H = + Blake2B.Make + (Base58) + (struct + let name = "Commitment_hash" + + let title = "A commitment ID" + + let b58check_prefix = commitment_hash + + let size = Some 32 + end) + + include H + + let () = Base58.check_encoded_prefix b58check_encoding "toc1" 54 + + include Path_encoding.Make_hex (H) + + let rpc_arg = + let construct = Data_encoding.Binary.to_string_exn encoding in + let destruct str = + Option.value_e ~error:"Failed to decode commitment" + @@ Data_encoding.Binary.of_string_opt encoding str + in + RPC_arg.make + ~descr:"A tx_rollup commitment." + ~name:"tx_rollup_commitment" + ~construct + ~destruct + () +end + +module Commitment = struct + type batch_commitment = { + (* TODO: add effects and replace bytes with Irmin: + https://gitlab.com/tezos/tezos/-/issues/2444 + *) + root : bytes; + } + + module Batch = struct + type t = batch_commitment + + let encoding = + Data_encoding.( + conv (fun {root} -> root) (fun root -> {root}) (obj1 (req "root" bytes))) + + let pp : Format.formatter -> t -> unit = + fun fmt {root} -> Hex.pp fmt (Hex.of_bytes root) + + include Compare.Make (struct + type nonrec t = t + + let compare {root = root1} {root = root2} = Bytes.compare root1 root2 + end) + end + [@@coq_plain_module] + + let batch_commitment_equal : batch_commitment -> batch_commitment -> bool = + Batch.equal + + type t = { + level : Raw_level_repr.t; + batches : batch_commitment list; + predecessor : Commitment_hash.t option; + } + + include Compare.Make (struct + type nonrec t = t + + module Compare_root_list = Compare.List (Batch) + + let compare r1 r2 = + compare_or Raw_level_repr.compare r1.level r2.level (fun () -> + compare_or Compare_root_list.compare r1.batches r2.batches (fun () -> + Option.compare + Commitment_hash.compare + r1.predecessor + r2.predecessor)) + end) + + let pp : Format.formatter -> t -> unit = + fun fmt t -> + Format.fprintf + fmt + "commitment %a : batches = %a predecessor %a" + Raw_level_repr.pp + t.level + (Format.pp_print_list Batch.pp) + t.batches + (Format.pp_print_option Commitment_hash.pp) + t.predecessor + + (* FIXME/TORU: https://gitlab.com/tezos/tezos/-/issues/2470 + + This encoding is not bounded, and maybe it is an issue. *) + let encoding = + let open Data_encoding in + conv + (fun {level; batches; predecessor} -> (level, batches, predecessor)) + (fun (level, batches, predecessor) -> {level; batches; predecessor}) + (obj3 + (req "level" Raw_level_repr.encoding) + (req "batches" (list Batch.encoding)) + (req "predecessor" (option Commitment_hash.encoding))) + + let hash t = + let to_bytes_exn = Data_encoding.Binary.to_bytes_exn in + let level_bytes = to_bytes_exn Raw_level_repr.encoding t.level in + let predecessor_bytes = + Option.fold + ~none:Bytes.empty + ~some:(fun pred -> Commitment_hash.to_bytes pred) + t.predecessor + in + let batches_bytes = + to_bytes_exn (Data_encoding.list Batch.encoding) t.batches + in + Commitment_hash.hash_bytes [level_bytes; predecessor_bytes; batches_bytes] + + module Index = struct + type t = Commitment_hash.t + + let path_length = 1 + + let to_path c l = + let raw_key = + Data_encoding.Binary.to_bytes_exn Commitment_hash.encoding c + in + let (`Hex key) = Hex.of_bytes raw_key in + key :: l + + let of_path = function + | [key] -> + Option.bind + (Hex.to_bytes (`Hex key)) + (Data_encoding.Binary.of_bytes_opt Commitment_hash.encoding) + | _ -> None + + let rpc_arg = Commitment_hash.rpc_arg + + let encoding = Commitment_hash.encoding + + let compare = Commitment_hash.compare + end +end + +type pending_commitment = { + commitment : Commitment.t; + hash : Commitment_hash.t; + committer : Signature.Public_key_hash.t; + submitted_at : Raw_level_repr.t; +} + +let pp_pending_commitment : Format.formatter -> pending_commitment -> unit = + fun fmt {commitment; hash; committer; submitted_at} -> + Format.fprintf + fmt + "pending_commitment %a; hash = %a; committer = %a; submitted_at = %a" + Commitment.pp + commitment + Commitment_hash.pp + hash + Signature.Public_key_hash.pp_short + committer + Raw_level_repr.pp + submitted_at + +let pending_commitment_encoding = + Data_encoding.( + conv + (fun {commitment; committer; submitted_at; _} -> + (commitment, committer, submitted_at)) + (fun (commitment, committer, submitted_at) -> + let hash = Commitment.hash commitment in + {hash; commitment; committer; submitted_at}) + (obj3 + (req "commitment" Commitment.encoding) + (req "commiter" Signature.Public_key_hash.encoding) + (req "submitted_at" Raw_level_repr.encoding))) + +type t = pending_commitment list + +let encoding = Data_encoding.(list pending_commitment_encoding) + +let empty = [] + +let commitment_exists : t -> Commitment_hash.t -> bool = + fun t hash -> List.exists (fun {hash = h; _} -> Commitment_hash.(h = hash)) t + +let commitment_with_committer_exists : t -> Signature.Public_key_hash.t -> bool + = + fun t contract -> + List.exists + (fun {committer; _} -> Signature.Public_key_hash.(committer = contract)) + t + +let append : + t -> + Signature.Public_key_hash.t -> + Commitment.t -> + Raw_level_repr.t -> + t tzresult = + fun t contract commitment level -> + let hash = Commitment.hash commitment in + (* We fail if this contract already has a commitment at this level, + or if anyone has already made this commitment at this level; a + bond entitles you to at most one commitment per level. *) + error_when (commitment_exists t hash) Commitment_hash_already_submitted + >>? fun () -> + error_when + (commitment_with_committer_exists t contract) + Two_commitments_from_one_committer + >>? fun () -> + Ok ({hash; commitment; committer = contract; submitted_at = level} :: t) -- GitLab From 8eb912371fbaad9831243012b98267982b303296 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 4 Mar 2022 17:45:31 +0100 Subject: [PATCH 058/105] Proto: update coq-of-ocaml annotations for implicit types --- .../lib_protocol/script_interpreter.ml | 10 ++++---- .../lib_protocol/script_ir_translator.ml | 25 ++++++++++--------- .../lib_protocol/ticket_lazy_storage_diff.ml | 9 +++---- .../lib_protocol/ticket_scanner.ml | 2 +- 4 files changed, 23 insertions(+), 23 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 25c3ba98c054a..a915120fea149 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -621,7 +621,7 @@ and[@coq_struct "function_parameter"] step : gas k ks - (accu [@coq_implicit "(E := __INil_'b)"]) + (accu [@coq_implicit "E" "__INil_'b"]) stack | ( IIf_cons {branch_if_cons; branch_if_nil; k; _}, (accu : _ boxed_list), @@ -646,7 +646,7 @@ and[@coq_struct "function_parameter"] step : hd (tl, stack)) | (IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _)) -> - (ilist_map [@ocaml.tailcall] [@coq_implicit "(f := __IList_map_'b)"]) + (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b"]) id g gas @@ -684,7 +684,7 @@ and[@coq_struct "function_parameter"] step : let res = (Script_map.empty [@coq_type_annotation]) ty in (step [@ocaml.tailcall]) g gas k ks res stack | (IMap_map (_, body, k), (accu : _ map), (stack : _ * _)) -> - (imap_map [@ocaml.tailcall] [@coq_implicit "(g := __IMap_map_'c)"]) + (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c"]) id g gas @@ -1777,7 +1777,7 @@ and[@coq_struct "function_parameter"] log : let with_log k = match k with KLog _ -> k | _ -> KLog (k, logger) in match[@coq_match_gadt] (k, accu, stack) with | (IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _)) -> - (ilist_map [@ocaml.tailcall] [@coq_implicit "(f := __IList_map_'b2)"]) + (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b2"]) with_log g gas @@ -1790,7 +1790,7 @@ and[@coq_struct "function_parameter"] log : | (ISet_iter (_, body, k), (accu : _ set), (stack : _ * _)) -> (iset_iter [@ocaml.tailcall]) with_log g gas (body, k) ks accu stack | (IMap_map (_, body, k), (accu : _ map), (stack : _ * _)) -> - (imap_map [@ocaml.tailcall] [@coq_implicit "(g := __IMap_map_'c2)"]) + (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c2"]) with_log g gas diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 07759fbe1407b..510a241a53e14 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2741,7 +2741,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : tr script_instr | (Lambda_t _, expr) -> - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) | (Option_t (t, _, _), expr) -> @@ -2759,7 +2759,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : items (Script_list.empty, ctxt) | (List_t _, expr) -> - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Tickets *) | (Ticket_t (t, _ty_name), expr) -> @@ -2803,7 +2803,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : vs >|=? fun (_, set, ctxt) -> (set, ctxt) | (Set_t _, expr) -> - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Maps *) | (Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr)) -> @@ -2817,7 +2817,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : (fun x -> x) : (_ map * _) tzresult Lwt.t) | (Map_t _, expr) -> - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Seq_kind], kind expr)) | (Big_map_t (tk, tv, _ty_name), expr) -> (match expr with @@ -2881,7 +2881,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | (Bls12_381_g1_t, expr) -> - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Bls12_381_g2_t, Bytes (_, bs)) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt -> @@ -2889,7 +2889,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | (Bls12_381_g2_t, expr) -> - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Bls12_381_fr_t, Bytes (_, bs)) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> @@ -2900,7 +2900,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> return (Script_bls.Fr.of_z v, ctxt) | (Bls12_381_fr_t, expr) -> - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) (* /!\ When adding new lazy storage kinds, you may want to guard the parsing @@ -2923,7 +2923,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | (Sapling_transaction_t _, expr) -> - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes)) -> ( match @@ -2963,7 +2963,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : | (Sapling_state_t _, expr) -> (* Do not allow to input diffs as they are untrusted and may not be the result of a verify_update. *) - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) | (Chest_key_t, Bytes (_, bytes)) -> ( @@ -2976,7 +2976,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : | Some chest_key -> return (chest_key, ctxt) | None -> fail_parse_data ()) | (Chest_key_t, expr) -> - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Chest_t, Bytes (_, bytes)) -> ( Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) @@ -2987,7 +2987,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : | Some chest -> return (chest, ctxt) | None -> fail_parse_data ()) | (Chest_t, expr) -> - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) and[@coq_struct "ctxt"] parse_view_returning : @@ -6550,7 +6550,8 @@ let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v else let dead = Lazy_storage.IdSet.diff to_update alive in let f kind id acc = - (Lazy_storage.make [@coq_implicit "(a := unit) (u := unit)"]) + (Lazy_storage.make + [@coq_implicit "a" "unit"] [@coq_implicit "u" "unit"]) kind id Remove diff --git a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml index cd81d13147bec..3b90e7d5163ea 100644 --- a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml @@ -76,7 +76,7 @@ let parse_value_type ctxt value_type = removing a value containing tickets. *) let collect_token_diffs_of_node ctxt has_tickets node ~get_token_and_amount acc = - (Ticket_scanner.tickets_of_node [@coq_implicit "(a := a)"]) + (Ticket_scanner.tickets_of_node [@coq_implicit "a" "a"]) ctxt (* It's currently not possible to have nested lazy structures, but this is for future proofing. *) @@ -111,7 +111,7 @@ let collect_token_diffs_of_big_map_update ctxt ~big_map_id has_tickets = match expr_opt with | Some expr -> - (collect_token_diffs_of_node [@coq_implicit "(a := a)"]) + (collect_token_diffs_of_node [@coq_implicit "a" "a"]) ctxt has_tickets expr @@ -170,8 +170,7 @@ let collect_token_diffs_of_big_map_updates ctxt big_map_id ~value_type updates >>?= fun (has_tickets, ctxt) -> List.fold_left_es (fun (acc, already_updated, ctxt) update -> - (collect_token_diffs_of_big_map_update - [@coq_implicit "(a := __Ex_ty_'a)"]) + (collect_token_diffs_of_big_map_update [@coq_implicit "a" "__Ex_ty_'a"]) ctxt ~big_map_id has_tickets @@ -209,7 +208,7 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = Big_map.list_values ctxt big_map_id >>=? fun (ctxt, exprs) -> List.fold_left_es (fun (acc, ctxt) node -> - (collect_token_diffs_of_node [@coq_implicit "(a := __Ex_ty_'a)"]) + (collect_token_diffs_of_node [@coq_implicit "a" "__Ex_ty_'a"]) ctxt has_tickets node diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index 88de29a45e3a3..e9584d1b286ff 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -533,7 +533,7 @@ let tickets_of_node ctxt ~include_lazy has_tickets expr = match ht with | Ticket_inspection.False_ht -> return ([], ctxt) | (_ : _ Ticket_inspection.has_tickets) -> - (Script_ir_translator.parse_data [@coq_implicit "(A := a)"]) + (Script_ir_translator.parse_data [@coq_implicit "A" "a"]) ctxt ~legacy:true ~allow_forged:true -- GitLab From 645195f2ce20333de2edf3368908042a1c864bf8 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Mon, 7 Mar 2022 23:56:31 +0100 Subject: [PATCH 059/105] Proto: more changes to help coq-of-ocaml --- src/lib_protocol_environment/sigs/v5/map.mli | 4 +- .../lib_protocol/delegate_storage.ml | 2 +- src/proto_alpha/lib_protocol/indexable.ml | 22 +- src/proto_alpha/lib_protocol/raw_context.ml | 3 - .../lib_protocol/raw_context_intf.ml | 211 +----------- .../lib_protocol/sapling_storage.ml | 4 +- .../lib_protocol/sc_rollup_storage.ml | 2 +- src/proto_alpha/lib_protocol/slot_repr.ml | 6 +- .../lib_protocol/storage_functors.ml | 3 - .../test/unit/test_tx_rollup_l2.ml | 10 +- .../lib_protocol/ticket_hash_repr.ml | 27 +- .../tx_rollup_commitments_repr.ml | 320 ------------------ .../tx_rollup_commitments_storage.ml | 94 ----- .../lib_protocol/tx_rollup_l2_apply.ml | 8 +- .../lib_protocol/tx_rollup_l2_context.ml | 8 +- .../lib_protocol/tx_rollup_l2_context_sig.ml | 10 +- .../lib_protocol/tx_rollup_message_repr.ml | 2 +- 17 files changed, 67 insertions(+), 669 deletions(-) delete mode 100644 src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml delete mode 100644 src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml diff --git a/src/lib_protocol_environment/sigs/v5/map.mli b/src/lib_protocol_environment/sigs/v5/map.mli index 559bf1cf78546..81f19be657eff 100644 --- a/src/lib_protocol_environment/sigs/v5/map.mli +++ b/src/lib_protocol_environment/sigs/v5/map.mli @@ -154,9 +154,9 @@ module type S = sig val of_seq : (key * 'a) Seq.t -> 'a t val iter_ep : - (key -> 'a -> (unit, 'error Error_monad.trace) result Lwt.t) -> + (key -> 'a -> (unit, 'error) result Lwt.t) -> 'a t -> - (unit, 'error Error_monad.trace) result Lwt.t + (unit, 'error list) result Lwt.t end diff --git a/src/proto_alpha/lib_protocol/delegate_storage.ml b/src/proto_alpha/lib_protocol/delegate_storage.ml index 366a6d3fd0d36..80d2c8cee6e9f 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_storage.ml @@ -750,7 +750,7 @@ module Random = struct the sequence and try again). *) Int64.sub Int64.max_int (Int64.rem Int64.max_int bound) in - let rec loop (bytes, n) = + let[@coq_struct "function_parameter"] rec loop (bytes, n) = let consumed_bytes = 8 in let state_size = Bytes.length bytes in if Compare.Int.(n > state_size - consumed_bytes) then diff --git a/src/proto_alpha/lib_protocol/indexable.ml b/src/proto_alpha/lib_protocol/indexable.ml index efd4595208f22..4365483c7f732 100644 --- a/src/proto_alpha/lib_protocol/indexable.ml +++ b/src/proto_alpha/lib_protocol/indexable.ml @@ -93,9 +93,9 @@ let forget : type state a. (state, a) t -> (unknown, a) t = function | Hidden_value x | Value x -> Hidden_value x | Hidden_index x | Index x -> Hidden_index x -let to_int32 = function Index x -> x +let to_int32 = function[@coq_match_with_default] Index x -> x -let to_value = function Value x -> x +let to_value = function[@coq_match_with_default] Value x -> x let is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result = fun ~error v -> @@ -104,7 +104,8 @@ let is_value_e : error:'trace -> ('state, 'a) t -> ('a, 'trace) result = let compact val_encoding = Data_encoding.Compact.( conv - (function Hidden_index x -> Either.Left x | Hidden_value x -> Right x) + (function[@coq_match_with_default] + | Hidden_index x -> Either.Left x | Hidden_value x -> Right x) (function Left x -> Hidden_index x | Right x -> Hidden_value x) @@ or_int32 ~int32_title:"index" ~alt_title:"value" val_encoding) @@ -215,20 +216,27 @@ module Make (V : VALUE) : INDEXABLE with type v_t := V.t = struct let index_exn : int32 -> index = index_exn - let compact = compact V.encoding + let compact : either Data_encoding.Compact.t = compact V.encoding let encoding : either Data_encoding.t = encoding V.encoding let index_encoding : index Data_encoding.t = Data_encoding.( - conv (fun (Index x) -> x) (fun x -> Index x) Data_encoding.int32) + conv + (fun [@coq_match_with_default] (Index x) -> x) + (fun x -> Index x) + Data_encoding.int32) let value_encoding : value Data_encoding.t = - Data_encoding.(conv (fun (Value x) -> x) (fun x -> Value x) V.encoding) + Data_encoding.( + conv + (fun [@coq_match_with_default] (Value x) -> x) + (fun x -> Value x) + V.encoding) let pp : Format.formatter -> 'state t -> unit = fun fmt x -> pp V.pp fmt x - let compare_values = compare_values V.compare + let compare_values : value -> value -> int = compare_values V.compare let compare_indexes = compare_indexes diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index e339cc68a1f14..7f6a673d91ad0 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -1062,8 +1062,6 @@ let fold ?depth ctxt k ~order ~init ~f = let config ctxt = Context.config (context ctxt) -module Proof = Context.Proof - module Tree : Raw_context_intf.TREE with type t := t @@ -1451,7 +1449,6 @@ module M : T with type t = root = struct let config = config module Tree = Tree - module Proof = Proof let verify_tree_proof = verify_tree_proof diff --git a/src/proto_alpha/lib_protocol/raw_context_intf.ml b/src/proto_alpha/lib_protocol/raw_context_intf.ml index d6ef0becd0e5e..b3f1ad418e55a 100644 --- a/src/proto_alpha/lib_protocol/raw_context_intf.ml +++ b/src/proto_alpha/lib_protocol/raw_context_intf.ml @@ -173,7 +173,7 @@ module type VIEW = sig lexicographic order of their keys. For large nodes, it is memory-consuming, use [`Undefined] for a more memory efficient [fold]. *) val fold : - ?depth:depth -> + ?depth:Context.depth -> t -> key -> order:[`Sorted | `Undefined] -> @@ -187,10 +187,6 @@ module type VIEW = sig val config : t -> config end -module Kind = struct - type t = [`Value | `Tree] -end - module type TREE = sig (** [Tree] provides immutable, in-memory partial mirror of the context, with lazy reads and delayed writes. The trees are Merkle @@ -219,7 +215,7 @@ module type TREE = sig (** [kind t] is [t]'s kind. It's either a tree node or a leaf value. *) - val kind : tree -> Kind.t + val kind : tree -> Context.Kind.t (** [to_value t] is an Lwt promise that resolves to [Some v] if [t] is a leaf tree and [None] otherwise. It is equivalent to [find t @@ -240,203 +236,6 @@ module type TREE = sig val clear : ?depth:int -> tree -> unit end -module type PROOF = sig - (** Proofs are compact representations of trees which can be shared - between peers. - - This is expected to be used as follows: - - - A first peer runs a function [f] over a tree [t]. While performing - this computation, it records: the hash of [t] (called [before] - below), the hash of [f t] (called [after] below) and a subset of [t] - which is needed to replay [f] without any access to the first peer's - storage. Once done, all these informations are packed into a proof of - type [t] that is sent to the second peer. - - - The second peer generates an initial tree [t'] from [p] and computes - [f t']. Once done, it compares [t']'s hash and [f t']'s hash to [before] - and [after]. If they match, they know that the result state [f t'] is a - valid context state, without having to have access to the full storage - of the first peer. *) - - (** The type for file and directory names. *) - type step = string - - (** The type for values. *) - type value = bytes - - (** The type of indices for inodes' children. *) - type index = int - - (** The type for hashes. *) - type hash = Context_hash.t - - (** The type for (internal) inode proofs. - - These proofs encode large directories into a tree-like structure. This - reflects irmin-pack's way of representing nodes and computing - hashes (tree-like representations for nodes scales better than flat - representations). - - [length] is the total number of entries in the children of the inode. - It's the size of the "flattened" version of that inode. [length] can be - used to prove the correctness of operations such [Tree.length] and - [Tree.list ~offset ~length] in an efficient way. - - In proofs with [version.is_binary = false], an inode at depth 0 has a - [length] of at least [257]. Below that threshold a [Node] tag is used in - [tree]. That threshold is [3] when [version.is_binary = true]. - - [proofs] contains the children proofs. It is a sparse list of ['a] values. - These values are associated to their index in the list, and the list is - kept sorted in increasing order of indices. ['a] can be a concrete proof - or a hash of that proof. - - In proofs with [version.is_binary = true], inodes have at most 2 proofs - (indexed 0 or 1). - - In proofs with [version.is_binary = false], inodes have at most 32 proofs - (indexed from 0 to 31). *) - type 'a inode = {length : int; proofs : (index * 'a) list} - - (** The type for inode extenders. - - An extender is a compact representation of a sequence of [inode] which - contain only one child. As for inodes, The ['a] parameter can be a - concrete proof or a hash of that proof. - - If an inode proof contains singleton children [i_0, ..., i_n] such as: - [{length=l; proofs = [ (i_0, {proofs = ... { proofs = [ (i_n, p) ] }})]}], - then it is compressed into the inode extender - [{length=l; segment = [i_0;..;i_n]; proof=p}] sharing the same lenght [l] - and final proof [p]. *) - type 'a inode_extender = {length : int; segment : index list; proof : 'a} - - (** The type for compressed and partial Merkle tree proofs. - - Tree proofs do not provide any guarantee with the ordering of - computations. For instance, if two effects commute, they won't be - distinguishable by this kind of proofs. - - [Value v] proves that a value [v] exists in the store. - - [Blinded_value h] proves a value with hash [h] exists in the store. - - [Node ls] proves that a a "flat" node containing the list of files [ls] - exists in the store. - - In proofs with [version.is_binary = true], the length of [ls] is at most - 2. - - In proofs with [version.is_binary = false], the length of [ls] is at most - 256. - - [Blinded_node h] proves that a node with hash [h] exists in the store. - - [Inode i] proves that an inode [i] exists in the store. - - [Extender e] proves that an inode extender [e] exist in the store. *) - type tree = - | Value of value - | Blinded_value of hash - | Node of (step * tree) list - | Blinded_node of hash - | Inode of inode_tree inode - | Extender of inode_tree inode_extender - - (** The type for inode trees. It is a subset of [tree], limited to nodes. - - [Blinded_inode h] proves that an inode with hash [h] exists in the store. - - [Inode_values ls] is simliar to trees' [Node]. - - [Inode_tree i] is similar to tree's [Inode]. - - [Inode_extender e] is similar to trees' [Extender]. *) - and inode_tree = - | Blinded_inode of hash - | Inode_values of (step * tree) list - | Inode_tree of inode_tree inode - | Inode_extender of inode_tree inode_extender - - (** The type for kinded hashes. *) - type kinded_hash = [`Value of hash | `Node of hash] - - module Stream : sig - (** Stream proofs represent an explicit traversal of a Merle tree proof. - Every element (a node, a value, or a shallow pointer) met is first - "compressed" by shallowing its children and then recorded in the proof. - - As stream proofs directly encode the recursive construction of the - Merkle root hash is slightly simpler to implement: verifier simply - need to hash the compressed elements lazily, without any memory or - choice. - - Moreover, the minimality of stream proofs is trivial to check. - Once the computation has consumed the compressed elements required, - it is sufficient to check that no more compressed elements remain - in the proof. - - However, as the compressed elements contain all the hashes of their - shallow children, the size of stream proofs is larger - (at least double in size in practice) than tree proofs, which only - contains the hash for intermediate shallow pointers. *) - - (** The type for elements of stream proofs. - - [Value v] is a proof that the next element read in the store is the - value [v]. - - [Node n] is a proof that the next element read in the store is the - node [n]. - - [Inode i] is a proof that the next element read in the store is the - inode [i]. - - [Inode_extender e] is a proof that the next element read in the store - is the node extender [e]. *) - type elt = - | Value of value - | Node of (step * kinded_hash) list - | Inode of hash inode - | Inode_extender of hash inode_extender - - (** The type for stream proofs. - - The sequance [e_1 ... e_n] proves that the [e_1], ..., [e_n] are - read in the store in sequence. *) - type t = elt Seq.t - end - - type stream = Stream.t - - (** The type for proofs of kind ['a]. - - A proof [p] proves that the state advanced from [before p] to - [after p]. [state p]'s hash is [before p], and [state p] contains - the minimal information for the computation to reach [after p]. - - [version p] is the proof version, it packs several informations. - - [is_stream] discriminates between the stream proofs and the tree proofs. - - [is_binary] discriminates between proofs emitted from - [Tezos_context(_memory).Context_binary] and - [Tezos_context(_memory).Context]. - - It will also help discriminate between the data encoding techniques used. - - The version is meant to be decoded and encoded using the - {!Tezos_context_helpers.Context.decode_proof_version} and - {!Tezos_context_helpers.Context.encode_proof_version}. *) - type 'a t = { - version : int; - before : kinded_hash; - after : kinded_hash; - state : 'a; - } -end - module type T = sig (** The type for root contexts. *) type root @@ -450,8 +249,6 @@ module type T = sig and type value := value and type tree := tree - module Proof : PROOF - (** [verify p f] runs [f] in checking mode. [f] is a function that takes a tree as input and returns a new version of the tree and a result. [p] is a proof, that is a minimal representation of the tree that contains what [f] @@ -503,7 +300,7 @@ module type T = sig Guarantee that the given computation performs exactly the same state operations as the generating computation, *in some order*. *) - type tree_proof := Proof.tree Proof.t + type tree_proof := Context.Proof.tree Context.Proof.t (** [verify_tree_proof] is the verifier of tree proofs. *) val verify_tree_proof : (tree_proof, 'a) verifier @@ -512,7 +309,7 @@ module type T = sig Guarantee that the given computation performs exactly the same state operations as the generating computation, in the exact same order. *) - type stream_proof := Proof.stream Proof.t + type stream_proof := Context.Proof.stream Context.Proof.t (** [verify_stream] is the verifier of stream proofs. *) val verify_stream_proof : (stream_proof, 'a) verifier diff --git a/src/proto_alpha/lib_protocol/sapling_storage.ml b/src/proto_alpha/lib_protocol/sapling_storage.ml index 167f75f1f913b..600c870ef43c3 100644 --- a/src/proto_alpha/lib_protocol/sapling_storage.ml +++ b/src/proto_alpha/lib_protocol/sapling_storage.ml @@ -240,7 +240,7 @@ module Ciphertexts = struct let add ctx id c pos = Storage.Sapling.Ciphertexts.init (ctx, id) pos c let get_from ctx id offset = - let rec aux (ctx, acc) pos = + let[@coq_struct "function_parameter"] rec aux (ctx, acc) pos = Storage.Sapling.Ciphertexts.find (ctx, id) pos >>=? fun (ctx, c) -> match c with | None -> return (ctx, List.rev acc) @@ -319,7 +319,7 @@ module Roots = struct let mem ctx id root = Storage.Sapling.Roots_pos.get (ctx, id) >>=? fun start_pos -> - let rec aux pos = + let[@coq_struct "pos"] rec aux pos = Storage.Sapling.Roots.get (ctx, id) pos >>=? fun hash -> if Compare.Int.(Sapling.Hash.compare hash root = 0) then return true else diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index 6772013fe2810..7d61f36d1d06e 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml @@ -218,7 +218,7 @@ end module Store = Storage.Sc_rollup module Commitment = Sc_rollup_repr.Commitment -module Commitment_hash = Sc_rollup_repr.Commitment_hash +module Commitment_hash = Sc_rollup_repr.Commitment_hash [@@coq_plain_module] let originate ctxt ~kind ~boot_sector = Raw_context.increment_origination_nonce ctxt >>?= fun (ctxt, nonce) -> diff --git a/src/proto_alpha/lib_protocol/slot_repr.ml b/src/proto_alpha/lib_protocol/slot_repr.ml index 4cb7219bfedc2..338df1a6d3e22 100644 --- a/src/proto_alpha/lib_protocol/slot_repr.ml +++ b/src/proto_alpha/lib_protocol/slot_repr.ml @@ -84,21 +84,21 @@ module Range = struct ok (Interval {lo = min; hi = max}) let fold f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next > hi) then acc else loop ~acc:(f acc next) ~next:(next + 1) in loop ~acc:(f init lo) ~next:(lo + 1) let fold_es f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next > hi) then return acc else f acc next >>=? fun acc -> loop ~acc ~next:(next + 1) in f init lo >>=? fun acc -> loop ~acc ~next:(lo + 1) let rev_fold_es f init (Interval {lo; hi}) = - let rec loop ~acc ~next = + let[@coq_struct "next"] rec loop ~acc ~next = if Compare.Int.(next < lo) then return acc else f acc next >>=? fun acc -> loop ~acc ~next:(next - 1) in diff --git a/src/proto_alpha/lib_protocol/storage_functors.ml b/src/proto_alpha/lib_protocol/storage_functors.ml index e727c320061ea..c9eaa41fa7825 100644 --- a/src/proto_alpha/lib_protocol/storage_functors.ml +++ b/src/proto_alpha/lib_protocol/storage_functors.ml @@ -115,7 +115,6 @@ module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) : let config t = C.config t module Tree = C.Tree - module Proof = C.Proof let verify_tree_proof = C.verify_tree_proof @@ -795,8 +794,6 @@ module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) : C.Tree.empty t end - module Proof = C.Proof - let verify_tree_proof = C.verify_tree_proof let verify_stream_proof = C.verify_stream_proof diff --git a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml index b5d9787447e10..8a54b1eb680da 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_tx_rollup_l2.ml @@ -203,7 +203,7 @@ module type S = sig val set_count : t -> int32 -> t m val get_or_associate_index : - t -> value -> (t * [`Created | `Existed] * index) m + t -> value -> (t * Tx_rollup_l2_context_sig.created_existed * index) m val get : t -> value -> index option m @@ -224,7 +224,7 @@ module Test_index (Index : S) = struct let* (ctxt, value) = init_context_1 () in let* (ctxt, created, idx1) = Index.get_or_associate_index ctxt value in - assert (created = `Created) ; + assert (created = Created) ; let* idx2 = Index.get ctxt value in assert (Some idx1 = idx2) ; @@ -244,7 +244,7 @@ module Test_index (Index : S) = struct assert (idx = None) ; let* (ctxt, created, idx) = Index.get_or_associate_index ctxt value in - assert (created = `Created) ; + assert (created = Created) ; let* count = Index.count ctxt in assert (count = 1l) ; @@ -260,14 +260,14 @@ module Test_index (Index : S) = struct let expected = Indexable.index_exn 0l in let* (ctxt, created, idx) = Index.get_or_associate_index ctxt value in - assert (created = `Created) ; + assert (created = Created) ; assert (idx = expected) ; let* idx = Index.get ctxt value in assert (idx = Some (Indexable.index_exn 0l)) ; let* (ctxt, existed, idx) = Index.get_or_associate_index ctxt value in - assert (existed = `Existed) ; + assert (existed = Existed) ; assert (idx = expected) ; let* count = Index.count ctxt in diff --git a/src/proto_alpha/lib_protocol/ticket_hash_repr.ml b/src/proto_alpha/lib_protocol/ticket_hash_repr.ml index 36465bcf1245d..274f6366f3219 100644 --- a/src/proto_alpha/lib_protocol/ticket_hash_repr.ml +++ b/src/proto_alpha/lib_protocol/ticket_hash_repr.ml @@ -23,18 +23,33 @@ (* *) (*****************************************************************************) -include Script_expr_hash +type t = Script_expr_hash.t -let of_script_expr_hash t = t +let encoding = Script_expr_hash.encoding + +let pp = Script_expr_hash.pp + +let to_b58check = Script_expr_hash.to_b58check + +let of_b58check_opt = Script_expr_hash.of_b58check_opt + +let of_b58check_exn = Script_expr_hash.of_b58check_exn -let zero = zero +let of_bytes_exn = Script_expr_hash.of_bytes_exn + +let of_bytes_opt = Script_expr_hash.of_bytes_opt include Compare.Make (struct - type nonrec t = t + type nonrec t = Script_expr_hash.t - let compare = compare + let compare = Script_expr_hash.compare end) -module Index : Storage_description.INDEX with type t = t = struct +let zero = Script_expr_hash.zero + +let of_script_expr_hash t = t + +module Index : Storage_description.INDEX with type t = Script_expr_hash.t = +struct include Script_expr_hash end diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml deleted file mode 100644 index 1c356cfd7890b..0000000000000 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitments_repr.ml +++ /dev/null @@ -1,320 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Marigold *) -(* Copyright (c) 2022 Nomadic Labs *) -(* Copyright (c) 2022 Oxhead Alpha *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -type error += (* `Branch *) Commitment_hash_already_submitted - -type error += (* `Branch *) Two_commitments_from_one_committer - -type error += (* `Branch *) Wrong_commitment_predecessor_level - -type error += (* `Temporary *) Missing_commitment_predecessor - -type error += (* `Branch *) Wrong_batch_count - -type error += (* `Temporary *) Commitment_too_early - -let () = - let open Data_encoding in - (* Commitment_hash_already_submitted *) - register_error_kind - `Temporary - ~id:"tx_rollup_commit_hash_already_submitted" - ~title:"Someone already made this commitment" - ~description:"The requested commitment is a duplicate" - unit - (function Commitment_hash_already_submitted -> Some () | _ -> None) - (fun () -> Commitment_hash_already_submitted) ; - (* Two_commitments_from_one_committer *) - register_error_kind - `Temporary - ~id:"tx_rollup_two_commitments_from_one_committer" - ~title:"This contract already made a different commitment at this level" - ~description: - "This contract already made a different commitment at this level" - unit - (function Two_commitments_from_one_committer -> Some () | _ -> None) - (fun () -> Two_commitments_from_one_committer) ; - (* Wrong_commitment_predecessor_level *) - register_error_kind - `Temporary - ~id:"tx_rollup_wrong_commitment_predecessor_level" - ~title:"This commitment's predecessor is invalid" - ~description: - "This commitment has predecessor but shouldn't, or doesn't but should" - unit - (function Wrong_commitment_predecessor_level -> Some () | _ -> None) - (fun () -> Wrong_commitment_predecessor_level) ; - (* Missing_commitment_predecessor *) - register_error_kind - `Temporary - ~id:"tx_rollup_missing_commitment_predecessor" - ~title:"This commitment refers to a predecessor that doesn't exist" - ~description:"This commitment refers to a predecessor that doesn't exist" - unit - (function Missing_commitment_predecessor -> Some () | _ -> None) - (fun () -> Missing_commitment_predecessor) ; - (* Wrong_batch_count *) - register_error_kind - `Temporary - ~id:"tx_rollup_wrong_batch_count" - ~title:"This commitment has the wrong number of batches" - ~description: - "This commitment has a different number of batches than its inbox" - unit - (function Wrong_batch_count -> Some () | _ -> None) - (fun () -> Wrong_batch_count) ; - (* Commitment_too_early *) - register_error_kind - `Temporary - ~id:"tx_rollup_commitment_too_early" - ~title:"This commitment is for a level that hasn't finished yet" - ~description:"This commitment is for a level that hasn't finished yet" - unit - (function Commitment_too_early -> Some () | _ -> None) - (fun () -> Commitment_too_early) - -let compare_or cmp c1 c2 f = match cmp c1 c2 with 0 -> f () | diff -> diff - -module Commitment_hash = struct - let commitment_hash = "\017\249\195\013" (* toc1(54) *) - - module H = - Blake2B.Make - (Base58) - (struct - let name = "Commitment_hash" - - let title = "A commitment ID" - - let b58check_prefix = commitment_hash - - let size = Some 32 - end) - - include H - - let () = Base58.check_encoded_prefix b58check_encoding "toc1" 54 - - include Path_encoding.Make_hex (H) - - let rpc_arg = - let construct = Data_encoding.Binary.to_string_exn encoding in - let destruct str = - Option.value_e ~error:"Failed to decode commitment" - @@ Data_encoding.Binary.of_string_opt encoding str - in - RPC_arg.make - ~descr:"A tx_rollup commitment." - ~name:"tx_rollup_commitment" - ~construct - ~destruct - () -end - -module Commitment = struct - type batch_commitment = { - (* TODO: add effects and replace bytes with Irmin: - https://gitlab.com/tezos/tezos/-/issues/2444 - *) - root : bytes; - } - - module Batch = struct - type t = batch_commitment - - let encoding = - Data_encoding.( - conv (fun {root} -> root) (fun root -> {root}) (obj1 (req "root" bytes))) - - let pp : Format.formatter -> t -> unit = - fun fmt {root} -> Hex.pp fmt (Hex.of_bytes root) - - include Compare.Make (struct - type nonrec t = t - - let compare {root = root1} {root = root2} = Bytes.compare root1 root2 - end) - end - [@@coq_plain_module] - - let batch_commitment_equal : batch_commitment -> batch_commitment -> bool = - Batch.equal - - type t = { - level : Raw_level_repr.t; - batches : batch_commitment list; - predecessor : Commitment_hash.t option; - } - - include Compare.Make (struct - type nonrec t = t - - module Compare_root_list = Compare.List (Batch) - - let compare r1 r2 = - compare_or Raw_level_repr.compare r1.level r2.level (fun () -> - compare_or Compare_root_list.compare r1.batches r2.batches (fun () -> - Option.compare - Commitment_hash.compare - r1.predecessor - r2.predecessor)) - end) - - let pp : Format.formatter -> t -> unit = - fun fmt t -> - Format.fprintf - fmt - "commitment %a : batches = %a predecessor %a" - Raw_level_repr.pp - t.level - (Format.pp_print_list Batch.pp) - t.batches - (Format.pp_print_option Commitment_hash.pp) - t.predecessor - - (* FIXME/TORU: https://gitlab.com/tezos/tezos/-/issues/2470 - - This encoding is not bounded, and maybe it is an issue. *) - let encoding = - let open Data_encoding in - conv - (fun {level; batches; predecessor} -> (level, batches, predecessor)) - (fun (level, batches, predecessor) -> {level; batches; predecessor}) - (obj3 - (req "level" Raw_level_repr.encoding) - (req "batches" (list Batch.encoding)) - (req "predecessor" (option Commitment_hash.encoding))) - - let hash t = - let to_bytes_exn = Data_encoding.Binary.to_bytes_exn in - let level_bytes = to_bytes_exn Raw_level_repr.encoding t.level in - let predecessor_bytes = - Option.fold - ~none:Bytes.empty - ~some:(fun pred -> Commitment_hash.to_bytes pred) - t.predecessor - in - let batches_bytes = - to_bytes_exn (Data_encoding.list Batch.encoding) t.batches - in - Commitment_hash.hash_bytes [level_bytes; predecessor_bytes; batches_bytes] - - module Index = struct - type t = Commitment_hash.t - - let path_length = 1 - - let to_path c l = - let raw_key = - Data_encoding.Binary.to_bytes_exn Commitment_hash.encoding c - in - let (`Hex key) = Hex.of_bytes raw_key in - key :: l - - let of_path = function - | [key] -> - Option.bind - (Hex.to_bytes (`Hex key)) - (Data_encoding.Binary.of_bytes_opt Commitment_hash.encoding) - | _ -> None - - let rpc_arg = Commitment_hash.rpc_arg - - let encoding = Commitment_hash.encoding - - let compare = Commitment_hash.compare - end -end - -type pending_commitment = { - commitment : Commitment.t; - hash : Commitment_hash.t; - committer : Signature.Public_key_hash.t; - submitted_at : Raw_level_repr.t; -} - -let pp_pending_commitment : Format.formatter -> pending_commitment -> unit = - fun fmt {commitment; hash; committer; submitted_at} -> - Format.fprintf - fmt - "pending_commitment %a; hash = %a; committer = %a; submitted_at = %a" - Commitment.pp - commitment - Commitment_hash.pp - hash - Signature.Public_key_hash.pp_short - committer - Raw_level_repr.pp - submitted_at - -let pending_commitment_encoding = - Data_encoding.( - conv - (fun {commitment; committer; submitted_at; _} -> - (commitment, committer, submitted_at)) - (fun (commitment, committer, submitted_at) -> - let hash = Commitment.hash commitment in - {hash; commitment; committer; submitted_at}) - (obj3 - (req "commitment" Commitment.encoding) - (req "commiter" Signature.Public_key_hash.encoding) - (req "submitted_at" Raw_level_repr.encoding))) - -type t = pending_commitment list - -let encoding = Data_encoding.(list pending_commitment_encoding) - -let empty = [] - -let commitment_exists : t -> Commitment_hash.t -> bool = - fun t hash -> List.exists (fun {hash = h; _} -> Commitment_hash.(h = hash)) t - -let commitment_with_committer_exists : t -> Signature.Public_key_hash.t -> bool - = - fun t contract -> - List.exists - (fun {committer; _} -> Signature.Public_key_hash.(committer = contract)) - t - -let append : - t -> - Signature.Public_key_hash.t -> - Commitment.t -> - Raw_level_repr.t -> - t tzresult = - fun t contract commitment level -> - let hash = Commitment.hash commitment in - (* We fail if this contract already has a commitment at this level, - or if anyone has already made this commitment at this level; a - bond entitles you to at most one commitment per level. *) - error_when (commitment_exists t hash) Commitment_hash_already_submitted - >>? fun () -> - error_when - (commitment_with_committer_exists t contract) - Two_commitments_from_one_committer - >>? fun () -> - Ok ({hash; commitment; committer = contract; submitted_at = level} :: t) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml deleted file mode 100644 index e414e422f789a..0000000000000 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitments_storage.ml +++ /dev/null @@ -1,94 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2021 Marigold *) -(* Copyright (c) 2021 Nomadic Labs *) -(* Copyright (c) 2021 Oxhead Alpha *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -let just_ctxt (ctxt, _, _) = ctxt - -open Tx_rollup_commitments_repr - -(** Return commitments in the order that they were submitted *) -let get_or_empty_commitments : - Raw_context.t -> - Raw_level_repr.t * Tx_rollup_repr.t -> - (Raw_context.t * Tx_rollup_commitments_repr.t) tzresult Lwt.t = - fun ctxt key -> - Storage.Tx_rollup.Commitment_list.find ctxt key >|=? fun (ctxt, commitment) -> - Option.fold - commitment - ~none:(ctxt, Tx_rollup_commitments_repr.empty) - ~some:(fun l -> (ctxt, List.rev l)) - -let get_prev_level ctxt tx_rollup level = - Tx_rollup_inbox_storage.get_adjacent_levels ctxt level tx_rollup - >|=? fun (ctxt, predecessor_level, _) -> (ctxt, predecessor_level) - -let check_commitment_predecessor_hash ctxt tx_rollup (commitment : Commitment.t) - = - let level = commitment.level in - (* Check that level has the correct predecessor *) - get_prev_level ctxt tx_rollup level >>=? fun (ctxt, predecessor_level) -> - match (predecessor_level, commitment.predecessor) with - | (None, None) -> return ctxt - | (Some _, None) | (None, Some _) -> fail Wrong_commitment_predecessor_level - | (Some predecessor_level, Some hash) -> - (* The predecessor level must include this commitment*) - get_or_empty_commitments ctxt (predecessor_level, tx_rollup) - >>=? fun (ctxt, predecesor_commitments) -> - fail_unless - (Tx_rollup_commitments_repr.commitment_exists - predecesor_commitments - hash) - Missing_commitment_predecessor - >>=? fun () -> return ctxt - -let add_commitment ctxt tx_rollup contract (commitment : Commitment.t) = - let key = (commitment.level, tx_rollup) in - get_or_empty_commitments ctxt key >>=? fun (ctxt, pending) -> - Tx_rollup_inbox_storage.get ctxt ~level:(Level commitment.level) tx_rollup - >>=? fun (ctxt, inbox) -> - let expected_len = List.length inbox.contents in - let actual_len = List.length commitment.batches in - fail_unless Compare.Int.(expected_len = actual_len) Wrong_batch_count - >>=? fun () -> - check_commitment_predecessor_hash ctxt tx_rollup commitment >>=? fun ctxt -> - Tx_rollup_commitments_repr.append - pending - contract - commitment - (Raw_context.current_level ctxt).level - >>?= fun new_pending -> - Storage.Tx_rollup.Commitment_list.add ctxt key new_pending >|=? just_ctxt - -let get_commitments : - Raw_context.t -> - Tx_rollup_repr.t -> - Raw_level_repr.t -> - (Raw_context.t * Tx_rollup_commitments_repr.t) tzresult Lwt.t = - fun ctxt tx_rollup level -> - Storage.Tx_rollup.State.find ctxt tx_rollup >>=? fun (ctxt, state) -> - match state with - | None -> fail @@ Tx_rollup_state_storage.Tx_rollup_does_not_exist tx_rollup - | Some _ -> get_or_empty_commitments ctxt (level, tx_rollup) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml index a0aa2e90516ed..7253e598917ea 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml @@ -336,8 +336,8 @@ module Make (Context : CONTEXT) = struct | Right v -> ( let+ (ctxt, created, idx) = get_or_associate_index ctxt v in match created with - | `Existed -> (ctxt, indexes, idx) - | `Created -> (ctxt, add_index indexes (v, idx), idx)) + | Existed -> (ctxt, indexes, idx) + | Created -> (ctxt, add_index indexes (v, idx), idx)) | Left i -> return (ctxt, indexes, i) let address_index ctxt indexes indexable = @@ -445,7 +445,7 @@ module Make (Context : CONTEXT) = struct (* If the address is created, we add it to [indexes]. *) match created with - | `Existed -> + | Existed -> (* If the public key existed in the context, it should not be added in [indexes]. However, the metadata might not have been initialized for the public key. Especially during @@ -463,7 +463,7 @@ module Make (Context : CONTEXT) = struct Address_metadata.init_with_public_key ctxt idx signer_pk in return (ctxt, indexes, signer_pk, idx) - | `Created -> + | Created -> (* If the index is created, we need to add to indexes and initialize the metadata. *) let indexes = diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml index ae06d5b2330af..9aac11edd78d5 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml @@ -301,10 +301,10 @@ struct let open Syntax in let* index_opt = get ctxt addr in match index_opt with - | Some idx -> return (ctxt, `Existed, idx) + | Some idx -> return (ctxt, Existed, idx) | None -> let+ (ctxt, idx) = associate_index ctxt addr in - (ctxt, `Created, idx) + (ctxt, Created, idx) module Internal_for_tests = struct let set_count ctxt count = set ctxt Address_count count @@ -338,10 +338,10 @@ struct let open Syntax in let* index_opt = get ctxt ticket in match index_opt with - | Some idx -> return (ctxt, `Existed, idx) + | Some idx -> return (ctxt, Existed, idx) | None -> let+ (ctxt, idx) = associate_index ctxt ticket in - (ctxt, `Created, idx) + (ctxt, Created, idx) module Internal_for_tests = struct let set_count ctxt count = set ctxt Ticket_count count diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml index ba8d16138f325..635e27a2a7efd 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml @@ -157,6 +157,8 @@ let () = (function Counter_overflow -> Some () | _ -> None) (fun () -> Counter_overflow) +type created_existed = Created | Existed + (** This module type describes the API of the [Tx_rollup] context, which is used to implement the semantics of the L2 operations. *) module type CONTEXT = sig @@ -276,9 +278,7 @@ module type CONTEXT = sig This function can fail with [Too_many_l2_addresses] iff there is no fresh index available. *) val get_or_associate_index : - t -> - Tx_rollup_l2_address.t -> - (t * [`Created | `Existed] * address_index) m + t -> Tx_rollup_l2_address.t -> (t * created_existed * address_index) m (** [count ctxt] returns the number of addresses that have been involved in the transaction rollup. *) @@ -319,9 +319,7 @@ module type CONTEXT = sig This function can fail with [Too_many_l2_tickets] iff there is no fresh index available. *) val get_or_associate_index : - t -> - Alpha_context.Ticket_hash.t -> - (t * [`Created | `Existed] * ticket_index) m + t -> Alpha_context.Ticket_hash.t -> (t * created_existed * ticket_index) m (** [count ctxt] returns the number of tickets that have been involved in the transaction rollup. *) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml index c1a50a995be8f..2b21a834ad1c7 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_message_repr.ml @@ -71,7 +71,7 @@ let encoding = (fun deposit -> Deposit deposit); ] -let pp fmt = +let[@coq_axiom_with_reason "unresolved implicit arguments"] pp fmt = let open Format in function | Batch str -> -- GitLab From 92464bcd1574d2c3f0c9f2bba4f09d94d7f9dc12 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 8 Mar 2022 18:14:21 +0100 Subject: [PATCH 060/105] Proto: more changes for coq-of-ocaml --- .../lib_protocol/gas_comparable_input_size.ml | 2 +- .../lib_protocol/sc_rollup_storage.ml | 60 +++++++++++-------- src/proto_alpha/lib_protocol/storage.ml | 24 ++++++-- .../tx_rollup_commitment_storage.ml | 10 ++-- 4 files changed, 61 insertions(+), 35 deletions(-) diff --git a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml index 6e90810eba692..9d65919e4bf86 100644 --- a/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml +++ b/src/proto_alpha/lib_protocol/gas_comparable_input_size.ml @@ -106,7 +106,7 @@ let tx_rollup_l2_address x = let timestamp (tstamp : Alpha_context.Script_timestamp.t) : t = Z.numbits (Alpha_context.Script_timestamp.to_zint tstamp) / 8 -let rec size_of_comparable_value : +let[@coq_axiom_with_reason "gadts"] rec size_of_comparable_value : type a. a Script_typed_ir.comparable_ty -> a -> t = fun (type a) (wit : a Script_typed_ir.comparable_ty) (v : a) -> match wit with diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index 7d61f36d1d06e..1a6cd89848bb4 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml @@ -217,8 +217,6 @@ module Lwt_tzresult_syntax = struct end module Store = Storage.Sc_rollup -module Commitment = Sc_rollup_repr.Commitment -module Commitment_hash = Sc_rollup_repr.Commitment_hash [@@coq_plain_module] let originate ctxt ~kind ~boot_sector = Raw_context.increment_origination_nonce ctxt >>?= fun (ctxt, nonce) -> @@ -233,7 +231,10 @@ let originate ctxt ~kind ~boot_sector = Storage.Sc_rollup.Boot_sector.add ctxt address boot_sector >>= fun ctxt -> let inbox = Sc_rollup_inbox_repr.empty address level.level in Storage.Sc_rollup.Inbox.init ctxt address inbox >>=? fun (ctxt, size_diff) -> - Store.Last_cemented_commitment.init ctxt address Commitment_hash.zero + Store.Last_cemented_commitment.init + ctxt + address + Sc_rollup_repr.Commitment_hash.zero >>=? fun (ctxt, lcc_size_diff) -> Store.Staker_count.init ctxt address 0l >>=? fun (ctxt, stakers_size_diff) -> let addresses_size = 2 * Sc_rollup_repr.Address.size in @@ -372,7 +373,7 @@ let set_commitment_added ctxt rollup node new_value = let deallocate ctxt rollup node = let open Lwt_tzresult_syntax in - if Commitment_hash.(node = zero) then return ctxt + if Sc_rollup_repr.Commitment_hash.(node = zero) then return ctxt else let* (ctxt, _size_freed) = Store.Commitments.remove_existing (ctxt, rollup) node @@ -430,7 +431,7 @@ let withdraw_stake ctxt rollup staker = match res with | None -> fail Sc_rollup_not_staked | Some staked_on_commitment -> - if Commitment_hash.(staked_on_commitment = lcc) then + if Sc_rollup_repr.Commitment_hash.(staked_on_commitment = lcc) then (* TODO: https://gitlab.com/tezos/tezos/-/issues/2449 We should refund stake here. *) @@ -456,14 +457,14 @@ let sc_rollup_commitment_storage_size_in_bytes = 84 let assert_commitment_not_too_far_ahead ctxt rollup lcc commitment = let open Lwt_tzresult_syntax in let* (ctxt, min_level) = - if Commitment_hash.(lcc = zero) then + if Sc_rollup_repr.Commitment_hash.(lcc = zero) then let* level = Store.Initial_level.get ctxt rollup in return (ctxt, level) else let* (lcc, ctxt) = get_commitment_internal ctxt rollup lcc in - return (ctxt, Commitment.(lcc.inbox_level)) + return (ctxt, Sc_rollup_repr.Commitment.(lcc.inbox_level)) in - let max_level = Commitment.(commitment.inbox_level) in + let max_level = Sc_rollup_repr.Commitment.(commitment.inbox_level) in if Compare.Int32.( sc_rollup_max_lookahead < Raw_level_repr.diff max_level min_level) @@ -475,16 +476,16 @@ let assert_commitment_not_too_far_ahead ctxt rollup lcc commitment = *) let assert_commitment_frequency ctxt rollup commitment = let open Lwt_tzresult_syntax in - let pred = Commitment.(commitment.predecessor) in + let pred = Sc_rollup_repr.Commitment.(commitment.predecessor) in let* (ctxt, pred_level) = - if Commitment_hash.(pred = zero) then + if Sc_rollup_repr.Commitment_hash.(pred = zero) then let* level = Store.Initial_level.get ctxt rollup in return (ctxt, level) else let* (pred, ctxt) = get_commitment_internal ctxt rollup commitment.predecessor in - return (ctxt, Commitment.(pred.inbox_level)) + return (ctxt, Sc_rollup_repr.Commitment.(pred.inbox_level)) in (* We want to check the following inequalities on [commitment.inbox_level], [commitment.predecessor.inbox_level] and the constant [sc_rollup_commitment_frequency]. @@ -526,14 +527,14 @@ let refine_stake ctxt rollup staker commitment = let* (lcc, ctxt) = last_cemented_commitment ctxt rollup in let* (staked_on, ctxt) = find_staker ctxt rollup staker in let* ctxt = assert_refine_conditions_met ctxt rollup lcc commitment in - let new_hash = Commitment.hash commitment in + let new_hash = Sc_rollup_repr.Commitment.hash commitment in (* TODO: https://gitlab.com/tezos/tezos/-/issues/2559 Add a test checking that L2 nodes can catch up after going offline. *) - let rec go node ctxt = + let[@coq_struct "node_value"] rec go node ctxt = (* WARNING: Do NOT reorder this sequence of ifs. we must check for staked_on before LCC, since refining from the LCC to another commit is a valid operation. *) - if Commitment_hash.(node = staked_on) then ( + if Sc_rollup_repr.Commitment_hash.(node = staked_on) then ( (* Previously staked commit found: Insert new commitment if not existing *) let* (ctxt, commitment_size_diff, _was_bound) = @@ -560,7 +561,7 @@ let refine_stake ctxt rollup staker commitment = size_diff = 0 || size_diff = sc_rollup_commitment_storage_size_in_bytes)) ; return (new_hash, ctxt) (* See WARNING above. *)) - else if Commitment_hash.(node = lcc) then + else if Sc_rollup_repr.Commitment_hash.(node = lcc) then (* We reached the LCC, but [staker] is not staked directly on it. Thus, we backtracked. Note that everyone is staked indirectly on the LCC. *) @@ -570,7 +571,7 @@ let refine_stake ctxt rollup staker commitment = let* (_size, ctxt) = increase_commitment_stake_count ctxt rollup node in (go [@ocaml.tailcall]) pred ctxt in - go Commitment.(commitment.predecessor) ctxt + go Sc_rollup_repr.Commitment.(commitment.predecessor) ctxt let publish_commitment ctxt rollup staker commitment = let open Lwt_tzresult_syntax in @@ -599,8 +600,9 @@ let cement_commitment ctxt rollup new_lcc = let* (ctxt, new_lcc_added) = Store.Commitment_added.get (ctxt, rollup) new_lcc in - if Commitment_hash.(new_lcc_commitment.predecessor <> old_lcc) then - fail Sc_rollup_parent_not_lcc + if + Sc_rollup_repr.Commitment_hash.(new_lcc_commitment.predecessor <> old_lcc) + then fail Sc_rollup_parent_not_lcc else let* (new_lcc_stake_count, ctxt) = get_commitment_stake_count ctxt rollup new_lcc @@ -629,7 +631,8 @@ let cement_commitment ctxt rollup new_lcc = @@ Sc_rollup_repr.Number_of_messages.to_int32 new_lcc_commitment.number_of_messages) -type conflict_point = Commitment_hash.t * Commitment_hash.t +type conflict_point = + Sc_rollup_repr.Commitment_hash.t * Sc_rollup_repr.Commitment_hash.t (** [goto_inbox_level ctxt rollup inbox_level commit] Follows the predecessors of [commit] until it arrives at the exact [inbox_level]. The result is the commit hash at the given inbox level. *) @@ -637,7 +640,9 @@ let goto_inbox_level ctxt rollup inbox_level commit = let open Lwt_tzresult_syntax in let rec go ctxt commit = let* (info, ctxt) = get_commitment_internal ctxt rollup commit in - if Raw_level_repr.(info.Commitment.inbox_level <= inbox_level) then ( + if + Raw_level_repr.(info.Sc_rollup_repr.Commitment.inbox_level <= inbox_level) + then ( (* Assert that we're exactly at that level. If this isn't the case, we're most likely in a situation where inbox levels are inconsistent. *) assert (Raw_level_repr.(info.inbox_level = inbox_level)) ; @@ -655,7 +660,7 @@ let get_conflict_point ctxt rollup staker1 staker2 = let* (commit2, ctxt) = find_staker ctxt rollup staker2 in let* () = fail_when - Commitment_hash.( + Sc_rollup_repr.Commitment_hash.( (* If PVM is in pre-boot state, there might be stakes on the zero commitment. *) commit1 = zero || commit2 = zero (* If either commit is the LCC, that also means there can't be a conflict. *) @@ -685,7 +690,7 @@ let get_conflict_point ctxt rollup staker1 staker2 = We use this fact in the following to efficiently traverse both commitment histories towards the conflict points. *) let rec traverse_in_parallel ctxt commit1 commit2 = - if Commitment_hash.(commit1 = commit2) then + if Sc_rollup_repr.Commitment_hash.(commit1 = commit2) then (* This case will most dominantly happen when either commit is part of the other's history. It occurs when the commit that is farther ahead gets dereferenced to its predecessor often enough to land at the other commit. *) @@ -695,7 +700,9 @@ let get_conflict_point ctxt rollup staker1 staker2 = let* (commit2_info, ctxt) = get_commitment_internal ctxt rollup commit2 in assert ( Raw_level_repr.(commit1_info.inbox_level = commit2_info.inbox_level)) ; - if Commitment_hash.(commit1_info.predecessor = commit2_info.predecessor) + if + Sc_rollup_repr.Commitment_hash.( + commit1_info.predecessor = commit2_info.predecessor) then (* Same predecessor means we've found the conflict points. *) return ((commit1, commit2), ctxt) @@ -715,14 +722,15 @@ let remove_staker ctxt rollup staker = match res with | None -> fail Sc_rollup_not_staked | Some staked_on -> - if Commitment_hash.(staked_on = lcc) then fail Sc_rollup_remove_lcc + if Sc_rollup_repr.Commitment_hash.(staked_on = lcc) then + fail Sc_rollup_remove_lcc else let* (ctxt, _size_diff) = Store.Stakers.remove_existing (ctxt, rollup) staker in let* ctxt = modify_staker_count ctxt rollup Int32.pred in - let rec go node ctxt = - if Commitment_hash.(node = lcc) then return ctxt + let[@coq_struct "node_value"] rec go node ctxt = + if Sc_rollup_repr.Commitment_hash.(node = lcc) then return ctxt else let* (pred, ctxt) = get_predecessor ctxt rollup node in let* ctxt = decrease_commitment_stake_count ctxt rollup node in diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 66bdfdacd4a6d..4fce49f8e8221 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1554,7 +1554,11 @@ module Sc_rollup = struct let encoding = Sc_rollup_repr.Commitment_hash.encoding end) - module Stakers = + module Stakers : + Non_iterable_indexed_carbonated_data_storage + with type key = Signature.Public_key_hash.t + and type value = Sc_rollup_repr.Commitment_hash.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1578,7 +1582,11 @@ module Sc_rollup = struct let encoding = Data_encoding.int32 end) - module Commitments = + module Commitments : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_repr.Commitment_hash.t + and type value = Sc_rollup_repr.Commitment.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1591,7 +1599,11 @@ module Sc_rollup = struct let encoding = Sc_rollup_repr.Commitment.encoding end) - module Commitment_stake_count = + module Commitment_stake_count : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_repr.Commitment_hash.t + and type value = int32 + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1604,7 +1616,11 @@ module Sc_rollup = struct let encoding = Data_encoding.int32 end) - module Commitment_added = + module Commitment_added : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_repr.Commitment_hash.t + and type value = Raw_level_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml index 641b33cb61bb2..133814b41d99c 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml @@ -74,8 +74,10 @@ let check_message_result ctxt {messages; _} result ~path ~index = {provided = computed; expected = `Valid_path (messages.root, index)}) >>? fun () -> ok ctxt -let adjust_commitments_count ctxt tx_rollup pkh ~(dir : [`Incr | `Decr]) = - let delta = match dir with `Incr -> 1 | `Decr -> -1 in +type direction = Incr | Decr + +let adjust_commitments_count ctxt tx_rollup pkh ~(dir : direction) = + let delta = match dir with Incr -> 1 | Decr -> -1 in Storage.Tx_rollup.Commitment_bond.find (ctxt, tx_rollup) pkh >>=? fun (ctxt, commitment) -> let count = @@ -251,7 +253,7 @@ let add_commitment ctxt tx_rollup state pkh commitment = commitment.level commitment_hash >>?= fun state -> - adjust_commitments_count ctxt tx_rollup pkh ~dir:`Incr >>=? fun ctxt -> + adjust_commitments_count ctxt tx_rollup pkh ~dir:Incr >>=? fun ctxt -> return (ctxt, state, to_slash) let pending_bonded_commitments : @@ -322,7 +324,7 @@ let remove_commitment ctxt rollup state = fail (Internal_error "Missing finalized_at field")) >>=? fun () -> (* Decrement the bond count of the committer *) - adjust_commitments_count ctxt rollup commitment.committer ~dir:`Decr + adjust_commitments_count ctxt rollup commitment.committer ~dir:Decr >>=? fun ctxt -> (* We remove the commitment *) Storage.Tx_rollup.Commitment.remove (ctxt, rollup) tail -- GitLab From d4c51afd221816b9d2d81a68cfc0639e0402df58 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 9 Mar 2022 18:44:56 +0100 Subject: [PATCH 061/105] Proto: more changes for coq-of-ocaml --- src/lib_protocol_environment/sigs/v5/map.mli | 2 +- src/proto_alpha/lib_protocol/apply_results.ml | 8 +- .../lib_protocol/gas_input_size.ml | 2 +- .../lib_protocol/script_interpreter.ml | 10 ++- .../lib_protocol/script_interpreter_defs.ml | 2 +- .../lib_protocol/script_ir_annot.ml | 2 +- .../lib_protocol/script_ir_translator.ml | 9 +- src/proto_alpha/lib_protocol/script_map.ml | 24 +++++- src/proto_alpha/lib_protocol/script_set.ml | 16 +++- .../lib_protocol/script_typed_ir.ml | 2 + .../lib_protocol/script_typed_ir.mli | 2 + .../lib_protocol/script_typed_ir_size.ml | 3 +- .../lib_protocol/ticket_accounting.ml | 16 ++-- .../lib_protocol/tx_rollup_l2_batch.ml | 24 +++--- .../lib_protocol/tx_rollup_l2_context.ml | 6 +- .../lib_protocol/tx_rollup_l2_context_sig.ml | 85 ++++++++++--------- .../lib_protocol/tx_rollup_l2_storage_sig.ml | 62 ++++++++------ 17 files changed, 174 insertions(+), 101 deletions(-) diff --git a/src/lib_protocol_environment/sigs/v5/map.mli b/src/lib_protocol_environment/sigs/v5/map.mli index 81f19be657eff..8e1d02424fa2a 100644 --- a/src/lib_protocol_environment/sigs/v5/map.mli +++ b/src/lib_protocol_environment/sigs/v5/map.mli @@ -154,7 +154,7 @@ module type S = sig val of_seq : (key * 'a) Seq.t -> 'a t val iter_ep : - (key -> 'a -> (unit, 'error) result Lwt.t) -> + (key -> 'a -> (unit, 'error list) result Lwt.t) -> 'a t -> (unit, 'error list) result Lwt.t diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index d687b35ed15c4..c58133f9dba3a 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -697,7 +697,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_return_bond_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_return_bond_result {balance_updates; consumed_gas} -> (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas, consumed_milligas) -> @@ -722,7 +722,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_finalize_commitment_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_finalize_commitment_result {balance_updates; consumed_gas; level} -> (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas, level)) @@ -748,7 +748,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_remove_commitment_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_remove_commitment_result {balance_updates; consumed_gas; level} -> (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas, level)) @@ -771,7 +771,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Tx_rollup_rejection_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Tx_rollup_rejection_result {balance_updates; consumed_gas} -> (balance_updates, Gas.Arith.ceil consumed_gas, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas, consumed_milligas) -> diff --git a/src/proto_alpha/lib_protocol/gas_input_size.ml b/src/proto_alpha/lib_protocol/gas_input_size.ml index bccdf39979e8e..3026abf4e27ef 100644 --- a/src/proto_alpha/lib_protocol/gas_input_size.ml +++ b/src/proto_alpha/lib_protocol/gas_input_size.ml @@ -52,7 +52,7 @@ let node leaves = let r = List.fold_left ( ++ ) micheline_zero leaves in {r with traversal = r.traversal + 1} -let rec of_micheline (x : ('a, 'b) Micheline.node) = +let[@coq_struct "x_value"] rec of_micheline (x : ('a, 'b) Micheline.node) = match x with | Micheline.Int (_loc, z) -> let int_bytes = integer (Alpha_context.Script_int.of_zint z) in diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index a915120fea149..d7c67800ffee9 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -423,7 +423,7 @@ and[@coq_struct "gas"] imap_map : fun log_if_needed g gas (body, k) ks accu stack -> let map = accu in let xs = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in - let ys = Script_map.empty_from map in + let ys = (Script_map.empty_from [@coq_type_annotation]) map in let ks = log_if_needed (KMap_enter_body (body, xs, ys, KCons (k, ks))) in let (accu, stack) = stack in (next [@ocaml.tailcall]) g gas ks accu stack @@ -1185,7 +1185,13 @@ and[@coq_struct "function_parameter"] step : let ctxt = update_context gas ctxt in let return_none ctxt = let (gas, ctxt) = local_gas_counter_and_outdated_context ctxt in - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack in match c with | Contract c -> ( diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 1f872b956f2a5..9622033f39eae 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -295,7 +295,7 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = | (INeg_bls12_381_g1 _, _, _) -> Interp_costs.neg_bls12_381_g1 | (INeg_bls12_381_g2 _, _, _) -> Interp_costs.neg_bls12_381_g2 | (INeg_bls12_381_fr _, _, _) -> Interp_costs.neg_bls12_381_fr - | (IMul_bls12_381_fr_z _, _, _) -> + | (IMul_bls12_381_fr_z _, (accu : _ Script_int.num), _) -> let z = accu in Interp_costs.mul_bls12_381_fr_z z | (IMul_bls12_381_z_fr _, _, (stack : _ Script_int.num * _)) -> diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index a0cb334ce1416..219aa6956933d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -42,7 +42,7 @@ let error_unexpected_annot loc annot = (* Check that the predicate p holds on all s.[k] for k >= i *) let string_iter p s i = let len = String.length s in - let rec aux i = + let[@coq_struct "i_value"] rec aux i = if Compare.Int.(i >= len) then Result.return_unit else p s.[i] >>? fun () -> aux (i + 1) in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 510a241a53e14..a97fdcca1adec 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -788,7 +788,7 @@ let rec comparable_ty_eq : let not_equal () = of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative -> trace_of_error @@ -2768,7 +2768,10 @@ let[@coq_struct "ctxt"] rec parse_data_aux : parse_comparable_data ?type_logger ctxt ty expr >>=? fun (({destination; entrypoint = _}, (contents, amount)), ctxt) -> match destination with - | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) + | Contract ticketer -> + return + ( {ticketer; contents = contents [@coq_type_annotation]; amount}, + ctxt ) | Tx_rollup _ -> fail (Unexpected_ticket_owner destination) else traced_fail (Unexpected_forged_value (location expr)) (* Sets *) @@ -6418,6 +6421,8 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = let boxed = m let size = M.size + + let boxed_map_tag = () end in ( ctxt, Script_map.make diff --git a/src/proto_alpha/lib_protocol/script_map.ml b/src/proto_alpha/lib_protocol/script_map.ml index e3fa0e966c7bc..8cf9f123e74c7 100644 --- a/src/proto_alpha/lib_protocol/script_map.ml +++ b/src/proto_alpha/lib_protocol/script_map.ml @@ -45,6 +45,8 @@ let empty_from : type a b c. (a, b) map -> (a, c) map = let boxed = OPS.empty let size = 0 + + let boxed_map_tag = () end) let empty : type a b. a comparable_ty -> (a, b) map = @@ -52,11 +54,27 @@ let empty : type a b. a comparable_ty -> (a, b) map = let module OPS : Boxed_map_OPS with type key = a = struct let key_size = Gas_comparable_input_size.size_of_comparable_value ty - include Map.Make (struct + module Map = Map.Make (struct type t = a let compare = Script_comparable.compare_comparable ty end) + + type 'a t = 'a Map.t + + type key = Map.key + + let empty = Map.empty + + let add = Map.add + + let remove = Map.remove + + let find = Map.find + + let fold = Map.fold + + let fold_es = Map.fold_es end in Map_tag (module struct @@ -69,6 +87,8 @@ let empty : type a b. a comparable_ty -> (a, b) map = let boxed = OPS.empty let size = 0 + + let boxed_map_tag = () end) let get : type key value. key -> (key, value) map -> value option = @@ -95,6 +115,8 @@ let update : type a b. a -> b option -> (a, b) map -> (a, b) map = let boxed = boxed let size = size + + let boxed_map_tag = () end) let mem : type key value. key -> (key, value) map -> bool = diff --git a/src/proto_alpha/lib_protocol/script_set.ml b/src/proto_alpha/lib_protocol/script_set.ml index 22a37d1cc10d7..15a650c3d62e7 100644 --- a/src/proto_alpha/lib_protocol/script_set.ml +++ b/src/proto_alpha/lib_protocol/script_set.ml @@ -37,11 +37,25 @@ let empty : type a. a comparable_ty -> a set = let module OPS : Boxed_set_OPS with type elt = a = struct let elt_size = Gas_comparable_input_size.size_of_comparable_value ty - include Set.Make (struct + module Set = Set.Make (struct type t = a let compare = Script_comparable.compare_comparable ty end) + + type t = Set.t + + type elt = Set.elt + + let empty = Set.empty + + let add = Set.add + + let mem = Set.mem + + let remove = Set.remove + + let fold = Set.fold end in Set_tag (module struct diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 614b878f950db..dbe99010c087a 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -399,6 +399,8 @@ module type Boxed_map = sig val boxed : value OPS.t val size : int + + val boxed_map_tag : unit end type ('key, 'value) map = diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 1651e995e13d8..df5507e49d691 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -254,6 +254,8 @@ module type Boxed_map = sig val boxed : value OPS.t val size : int + + val boxed_map_tag : unit end (** [map] is made algebraic in order to distinguish it from the other type diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index de02340b4d045..a530e37c3df8f 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -681,7 +681,8 @@ let rec kinstr_extra_size : type a s r f. (a, s, r, f) kinstr -> nodes_and_size | Item_t (ty, _) -> ty_size ty) | IRead_ticket (_, k) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr k in - match kinfo.kstack_ty with Item_t (ty, _) -> ty_size ty) + match[@coq_match_with_default] kinfo.kstack_ty with + | Item_t (ty, _) -> ty_size ty) | ICompare (_, ty, _) -> comparable_ty_size ty | ISet_iter (_, body, _) -> ( let kinfo = Script_typed_ir.kinfo_of_kinstr body in diff --git a/src/proto_alpha/lib_protocol/ticket_accounting.ml b/src/proto_alpha/lib_protocol/ticket_accounting.ml index e04e6c5c19fb0..19edb40736a50 100644 --- a/src/proto_alpha/lib_protocol/ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/ticket_accounting.ml @@ -58,7 +58,7 @@ module Ticket_token_map = struct Gas.consume ctxt (Ticket_costs.add_z_cost b1 b2) >|? fun ctxt -> (Z.add b1 b2, ctxt) - let of_list ctxt token_amounts = + let of_list_with_merge ctxt token_amounts = Ticket_token_map.of_list ctxt ~merge_overlap token_amounts let add ctxt = Ticket_token_map.merge ctxt ~merge_overlap @@ -83,9 +83,9 @@ let ticket_balances_of_value ctxt ~include_lazy ty value = >|? fun ctxt -> ((token, Script_int.to_zint amount) :: acc, ctxt)) ([], ctxt) tickets - >>?= fun (list, ctxt) -> Ticket_token_map.of_list ctxt list + >>?= fun (list, ctxt) -> Ticket_token_map.of_list_with_merge ctxt list -let update_ticket_balances ctxt ~total_storage_diff token destinations = +let update_ticket_balances_raw ctxt ~total_storage_diff token destinations = List.fold_left_es (fun (tot_storage_diff, ctxt) (owner, delta) -> Ticket_balance_key.of_ex_token ctxt ~owner token @@ -117,7 +117,7 @@ let update_ticket_balances_for_self_contract ctxt ~self ticket_diffs = is_valid_balance_update (invalid_ticket_transfer_error ~ticket_token ~amount) >>?= fun () -> - update_ticket_balances + update_ticket_balances_raw ctxt ~total_storage_diff ticket_token @@ -132,7 +132,7 @@ let ticket_diffs_of_lazy_storage_diff ctxt ~storage_type_has_tickets Ticket_lazy_storage_diff.ticket_diffs_of_lazy_storage_diff ctxt lazy_storage_diff - >>=? fun (diffs, ctxt) -> Ticket_token_map.of_list ctxt diffs + >>=? fun (diffs, ctxt) -> Ticket_token_map.of_list_with_merge ctxt diffs else return (Ticket_token_map.empty, ctxt) (* TODO #2465 @@ -242,6 +242,10 @@ let update_ticket_balances ctxt ~self ~ticket_diffs operations = ([], ctxt) destinations >>?= fun (destinations, ctxt) -> - update_ticket_balances ctxt ~total_storage_diff ticket_token destinations) + update_ticket_balances_raw + ctxt + ~total_storage_diff + ticket_token + destinations) (total_storage_diff, ctxt) ticket_op_diffs diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml index 210668f9a9847..c879022d0e0a4 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.ml @@ -144,7 +144,7 @@ module V1 = struct let operation_content_encoding = Data_encoding.Compact.make ~tag_size compact_operation_content - let compact_operation encoding_signer = + let compact_operation_raw encoding_signer = Data_encoding.Compact.( conv (fun {signer; counter; contents} -> (signer, counter, contents)) @@ -154,30 +154,32 @@ module V1 = struct (req "counter" int64) (req "contents" @@ list ~bits:4 operation_content_encoding)) - let operation_encoding encoding_signer = - Data_encoding.Compact.(make ~tag_size (compact_operation encoding_signer)) + let operation_encoding_raw encoding_signer = + Data_encoding.Compact.( + make ~tag_size (compact_operation_raw encoding_signer)) - let compact_transaction encoding_signer = - Data_encoding.Compact.list ~bits:8 (operation_encoding encoding_signer) + let compact_transaction_raw encoding_signer = + Data_encoding.Compact.list ~bits:8 (operation_encoding_raw encoding_signer) - let transaction_encoding : + let transaction_encoding_raw : 'a -> ('b, Indexable.unknown) transaction Data_encoding.t = fun encoding_signer -> - Data_encoding.Compact.(make ~tag_size (compact_transaction encoding_signer)) + Data_encoding.Compact.( + make ~tag_size (compact_transaction_raw encoding_signer)) let compact_signer_index = Data_encoding.Compact.(conv Indexable.to_int32 Indexable.index_exn int32) let compact_signer_either = Signer_indexable.compact - let compact_operation = compact_operation compact_signer_either + let compact_operation = compact_operation_raw compact_signer_either let compact_transaction_signer_index = - compact_transaction compact_signer_index + compact_transaction_raw compact_signer_index - let compact_transaction = compact_transaction compact_signer_either + let compact_transaction = compact_transaction_raw compact_signer_either - let transaction_encoding = transaction_encoding compact_signer_either + let transaction_encoding = transaction_encoding_raw compact_signer_either let compact ~bits : (Indexable.unknown, Indexable.unknown) t Data_encoding.Compact.t = diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml index 9aac11edd78d5..5097999488026 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml @@ -119,7 +119,7 @@ let packed_key_encoding : packed_key Data_encoding.t = underlying storage. *) let value_encoding : type a. a key -> a Data_encoding.t = let open Data_encoding in - function + function[@coq_match_gadt_with_result] | Address_metadata _ -> metadata_encoding | Address_count -> int32 | Address_index _ -> Tx_rollup_l2_address.Indexable.index_encoding @@ -175,7 +175,9 @@ struct type 'a m = 'a S.m - module Syntax = struct + module Syntax : + Tx_rollup_l2_context_sig.SYNTAX with type t := t and type 'a m := 'a m = + struct include S.Syntax let ( let*? ) res f = diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml index 635e27a2a7efd..7eb3f4b7aa992 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml @@ -159,6 +159,49 @@ let () = type created_existed = Created | Existed +(** The necessary monadic operators the storage monad is required to + provide. *) +module type SYNTAX = sig + type t + + type 'a m + + val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m + + val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m + + (** [let*?] is for binding the value from Result-only + expressions into the storage monad. *) + val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m + + (** [fail err] shortcuts the current computation by raising an + error. + + Said error can be handled with the [catch] combinator. *) + val fail : error -> 'a m + + (** [catch p k h] tries to executes the monadic computation [p]. + If [p] terminates without an error, then its result is passed + to the continuation [k]. On the contrary, if an error [err] is + raised, it is passed to the error handler [h]. *) + val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m + + (** [return x] is the simplest computation inside the monad [m] which simply + computes [x] and nothing else. *) + val return : 'a -> 'a m + + (** [list_fold_left_m f] is a monadic version of [List.fold_left + f], wherein [f] is not a pure computation, but a computation + in the monad [m]. *) + val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m + + (** [fail_unless cond err] raises [err] iff [cond] is [false]. *) + val fail_unless : bool -> error -> unit m + + (** [fail_when cond err] raises [err] iff [cond] is [true]. *) + val fail_when : bool -> error -> unit m +end + (** This module type describes the API of the [Tx_rollup] context, which is used to implement the semantics of the L2 operations. *) module type CONTEXT = sig @@ -179,48 +222,12 @@ module type CONTEXT = sig needs to be inside the monad [m]. *) type 'a m - (** The necessary monadic operators the storage monad is required to - provide. *) - module Syntax : sig - val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m - - val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m - - (** [let*?] is for binding the value from Result-only - expressions into the storage monad. *) - val ( let*? ) : ('a, error) result -> ('a -> 'b m) -> 'b m - - (** [fail err] shortcuts the current computation by raising an - error. - - Said error can be handled with the [catch] combinator. *) - val fail : error -> 'a m - - (** [catch p k h] tries to executes the monadic computation [p]. - If [p] terminates without an error, then its result is passed - to the continuation [k]. On the contrary, if an error [err] is - raised, it is passed to the error handler [h]. *) - val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m - - (** [return x] is the simplest computation inside the monad [m] which simply - computes [x] and nothing else. *) - val return : 'a -> 'a m - - (** [list_fold_left_m f] is a monadic version of [List.fold_left - f], wherein [f] is not a pure computation, but a computation - in the monad [m]. *) - val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m - - (** [fail_unless cond err] raises [err] iff [cond] is [false]. *) - val fail_unless : bool -> error -> unit m - - (** [fail_when cond err] raises [err] iff [cond] is [true]. *) - val fail_when : bool -> error -> unit m - end + module Syntax : SYNTAX with type t := t and type 'a m := 'a m (** [bls_aggregate_verify] allows to verify the aggregated signature of a batch. *) - val bls_verify : (Bls_signature.pk * bytes) list -> signature -> bool m + val bls_verify : + (Bls_signature.pk * bytes) list -> Bls_signature.signature -> bool m (** The metadata associated to an address. *) module Address_metadata : sig diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml index 4a81f9cd41808..2b62542033cea 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_storage_sig.ml @@ -25,6 +25,39 @@ (* *) (*****************************************************************************) +(** The necessary monadic operators the monad of the storage backend + is required to provide. *) +module type SYNTAX = sig + type t + + type 'a m + + val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m + + val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m + + (** [fail err] shortcuts the current computation by raising an + error. + + Said error can be handled with the [catch] combinator. *) + val fail : error -> 'a m + + (** [catch p k h] tries to executes the monadic computation [p]. + If [p] terminates without an error, then its result is passed + to the continuation [k]. On the contrary, if an error [err] is + raised, it is passed to the error handler [h]. *) + val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m + + (** [return x] is the simplest computation inside the monad [m] which simply + computes [x] and nothing else. *) + val return : 'a -> 'a m + + (** [list_fold_left_m f] is a monadic version of [List.fold_left + f], wherein [f] is not a pure computation, but a computation + in the monad [m]. *) + val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m +end + (** This module type is the minimal API a storage backend has to implement to be compatible with the [Tx_rollup] layer-2 implementation. @@ -44,34 +77,7 @@ module type STORAGE = sig (** The monad of the storage backend. *) type 'a m - (** The necessary monadic operators the monad of the storage backend - is required to provide. *) - module Syntax : sig - val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m - - val ( let* ) : 'a m -> ('a -> 'b m) -> 'b m - - (** [fail err] shortcuts the current computation by raising an - error. - - Said error can be handled with the [catch] combinator. *) - val fail : error -> 'a m - - (** [catch p k h] tries to executes the monadic computation [p]. - If [p] terminates without an error, then its result is passed - to the continuation [k]. On the contrary, if an error [err] is - raised, it is passed to the error handler [h]. *) - val catch : 'a m -> ('a -> 'b m) -> (error -> 'b m) -> 'b m - - (** [return x] is the simplest computation inside the monad [m] which simply - computes [x] and nothing else. *) - val return : 'a -> 'a m - - (** [list_fold_left_m f] is a monadic version of [List.fold_left - f], wherein [f] is not a pure computation, but a computation - in the monad [m]. *) - val list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m - end + module Syntax : SYNTAX with type t := t and type 'a m := 'a m (** [get storage key] returns the value stored in [storage] for [key], if it exists. Returns [None] if it does not. *) -- GitLab From f8dc694a1b9836d22afcdc9e28d1ea7f1329b2ff Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Sun, 13 Mar 2022 16:47:13 +0100 Subject: [PATCH 062/105] Proto: compile ty_eq in Coq --- .../lib_protocol/script_ir_translator.ml | 28 ++++++++++--------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index a97fdcca1adec..4b66d23694bf1 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -880,27 +880,28 @@ let ty_eq : let memo_size_eq ms1 ms2 = Gas_monad.of_result (memo_size_eq ~error_details ms1 ms2) in - let rec help : - type ta tac tb tbc. - (ta, tac) ty -> - (tb, tbc) ty -> - (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = - fun ty1 ty2 -> - help0 ty1 ty2 - |> Gas_monad.record_trace_eval ~error_details (fun () -> - default_ty_eq_error ty1 ty2) - and help0 : + let rec help0 : type ta tac tb tbc. (ta, tac) ty -> (tb, tbc) ty -> (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = fun ty1 ty2 -> + let help : + type ta tac tb tbc. + (ta, tac) ty -> + (tb, tbc) ty -> + (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = + fun ty1 ty2 -> + help0 ty1 ty2 + |> Gas_monad.record_trace_eval ~error_details (fun () -> + default_ty_eq_error ty1 ty2) + in let open Gas_monad.Syntax in let* () = Gas_monad.consume_gas Typecheck_costs.merge_cycle in let not_equal () = Gas_monad.of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative -> trace_of_error @@ default_ty_eq_error ty1 ty2) in @@ -1018,8 +1019,9 @@ let ty_eq : | (Chest_key_t, Chest_key_t) -> return Eq | (Chest_key_t, _) -> not_equal () in - help ty1 ty2 - [@@coq_axiom_with_reason "non-top-level mutual recursion"] + help0 ty1 ty2 + |> Gas_monad.record_trace_eval ~error_details (fun () -> + default_ty_eq_error ty1 ty2) (* Same as ty_eq but for stacks. A single error monad is used here because there is no need to -- GitLab From 4b07429a663a254f8540e7185dc486fd4240bc81 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Sun, 13 Mar 2022 17:03:06 +0100 Subject: [PATCH 063/105] Proto: remove a warning from coq-of-ocaml --- src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml index 7253e598917ea..80edb6960fcb2 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml @@ -688,7 +688,7 @@ module Make (Context : CONTEXT) = struct failed because of a [Counter_mismatch] the counters are left untouched. *) - let update_counters ctxt status transaction = + let[@coq_axiom_with_reason "match on extensible type not at the head"] update_counters ctxt status transaction = match status with | Transaction_failure {reason = Counter_mismatch _; _} -> return ctxt | Transaction_failure _ | Transaction_success -> -- GitLab From 61183edd28c090d6a9ef1a7e1387cf213fb06821 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 15 Mar 2022 22:22:18 +0100 Subject: [PATCH 064/105] Proto: more changes for coq-of-ocaml --- src/lib_crypto/blake2B.ml | 15 +- src/lib_crypto/blake2B.mli | 16 +- .../sigs/v5/data_encoding.mli | 4 +- src/proto_alpha/lib_plugin/plugin.ml | 11 +- .../lib_protocol/alpha_context.mli | 12 +- src/proto_alpha/lib_protocol/apply_results.ml | 34 +- .../lib_protocol/raw_context_intf.ml | 3 - .../lib_protocol/script_interpreter_defs.ml | 3 +- .../lib_protocol/script_ir_translator.ml | 334 ++++++++++-------- .../lib_protocol/script_ir_translator.mli | 1 + .../lib_protocol/script_typed_ir.ml | 3 + .../lib_protocol/script_typed_ir.mli | 3 + .../lib_protocol/services_registration.ml | 20 +- .../lib_protocol/services_registration.mli | 6 +- .../lib_protocol/ticket_operations_diff.ml | 16 +- .../lib_protocol/ticket_scanner.ml | 1 + .../lib_protocol/tx_rollup_l2_apply.ml | 3 +- 17 files changed, 262 insertions(+), 223 deletions(-) diff --git a/src/lib_crypto/blake2B.ml b/src/lib_crypto/blake2B.ml index 4022f5993b593..011fbd085a18d 100644 --- a/src/lib_crypto/blake2B.ml +++ b/src/lib_crypto/blake2B.ml @@ -318,20 +318,13 @@ end let rec log2 x = if x <= 1 then 0 else 1 + log2 ((x + 1) / 2) -module Make_merkle_tree (R : sig - val register_encoding : - prefix:string -> - length:int -> - to_raw:('a -> string) -> - of_raw:(string -> 'a option) -> - wrap:('a -> Base58.data) -> - 'a Base58.encoding -end) -(K : PrefixedName) (Contents : sig +module type To_bytes = sig type t val to_bytes : t -> Bytes.t -end) = +end + +module Make_merkle_tree (R : Register) (K : PrefixedName) (Contents : To_bytes) = struct include Make (R) (K) diff --git a/src/lib_crypto/blake2B.mli b/src/lib_crypto/blake2B.mli index 044734007acd6..021a5201e74de 100644 --- a/src/lib_crypto/blake2B.mli +++ b/src/lib_crypto/blake2B.mli @@ -68,20 +68,14 @@ module Make (Register : Register) (Name : PrefixedName) : S.HASH (**/**) -module Make_merkle_tree (R : sig - val register_encoding : - prefix:string -> - length:int -> - to_raw:('a -> string) -> - of_raw:(string -> 'a option) -> - wrap:('a -> Base58.data) -> - 'a Base58.encoding -end) -(K : PrefixedName) (Contents : sig +module type To_bytes = sig type t val to_bytes : t -> Bytes.t -end) : S.MERKLE_TREE with type elt = Contents.t +end + +module Make_merkle_tree (R : Register) (K : PrefixedName) (Contents : To_bytes) : + S.MERKLE_TREE with type elt = Contents.t module Generic_Merkle_tree (H : sig type t diff --git a/src/lib_protocol_environment/sigs/v5/data_encoding.mli b/src/lib_protocol_environment/sigs/v5/data_encoding.mli index e7cd699b0623a..b3c52a30caf2c 100644 --- a/src/lib_protocol_environment/sigs/v5/data_encoding.mli +++ b/src/lib_protocol_environment/sigs/v5/data_encoding.mli @@ -466,6 +466,8 @@ type 't case type case_tag = Tag of int | Json_only +type match_result + (** A sum descriptor can be optimized by providing a specific [matching_function] which efficiently determines in which case some value of type ['a] falls. @@ -481,8 +483,6 @@ type case_tag = Tag of int | Json_only inhabited. *) type 'a matching_function = 'a -> match_result -and match_result - (** [matched t e u] represents the fact that a value is tagged with [t] and carries the payload [u] which can be encoded with [e]. diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 68d0f3388bf20..fccbe56e362ea 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -1510,7 +1510,7 @@ module RPC = struct let register0_fullctxt ~chunked s f = patched_services := RPC_directory.register ~chunked !patched_services s (fun ctxt q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let register0 ~chunked s f = @@ -1520,7 +1520,8 @@ module RPC = struct patched_services := RPC_directory.register ~chunked !patched_services s (fun ctxt q i -> let mode = - if q#successor_level then `Successor_level else `Head_level + if q#successor_level then Services_registration.Successor_level + else Head_level in Services_registration.rpc_init ctxt mode >>=? fun ctxt -> f ctxt q i) @@ -1535,7 +1536,7 @@ module RPC = struct let opt_register0_fullctxt ~chunked s f = patched_services := RPC_directory.opt_register ~chunked !patched_services s (fun ctxt q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let opt_register0 ~chunked s f = @@ -1548,7 +1549,7 @@ module RPC = struct !patched_services s (fun (ctxt, arg) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let register1 ~chunked s f = @@ -1561,7 +1562,7 @@ module RPC = struct !patched_services s (fun ((ctxt, arg1), arg2) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let register2 ~chunked s f = diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index afe5eab0aa835..2277f3d7bf055 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1459,7 +1459,7 @@ end (** This module re-exports functions from {!Ticket_hash_repr}. See documentation of the functions there. *) module Ticket_hash : sig - type t + type t = Ticket_hash_repr.t val encoding : t Data_encoding.t @@ -1814,7 +1814,7 @@ end (** This module re-exports definitions from {!Tx_rollup_message_repr}. *) module Tx_rollup_message : sig - type deposit = { + type deposit = Tx_rollup_message_repr.deposit = { sender : public_key_hash; destination : Tx_rollup_l2_address.Indexable.value; ticket_hash : Ticket_hash.t; @@ -2314,7 +2314,10 @@ module Delegate : sig endorsing_power:int -> context tzresult Lwt.t - type deposits = {initial_amount : Tez.t; current_amount : Tez.t} + type deposits = Storage.deposits = { + initial_amount : Tez.t; + current_amount : Tez.t; + } val frozen_deposits : context -> public_key_hash -> deposits tzresult Lwt.t @@ -2474,7 +2477,7 @@ module Sc_rollup : sig module Map : Map.S with type key = t end - module Address : S.HASH + module Address : S.HASH [@@coq_plain_module] type t = Address.t @@ -2483,6 +2486,7 @@ module Sc_rollup : sig val encoding : t Data_encoding.t end + [@@coq_plain_module] module Staker : S.SIGNATURE_PUBLIC_KEY_HASH with type t = Signature.Public_key_hash.t diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index c58133f9dba3a..d3de9e9e6d34c 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -910,7 +910,7 @@ module Manager_result = struct ~select:(function | Successful_manager_result (Sc_rollup_cement_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_cement_result {consumed_gas} -> (Gas.Arith.ceil consumed_gas, consumed_gas)) ~kind:Kind.Sc_rollup_cement_manager_kind @@ -984,7 +984,7 @@ module Internal_result = struct select = (function Manager (Transaction _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Transaction {amount; destination; parameters; entrypoint} -> let parameters = if @@ -1023,7 +1023,7 @@ module Internal_result = struct select = (function Manager (Origination _ as op) -> Some op | _ -> None); proj = - (function + (function[@coq_match_with_default] | Origination {credit; delegate; script} -> (credit, delegate, script)); inj = (fun (credit, delegate, script) -> @@ -1044,7 +1044,7 @@ module Internal_result = struct | _ -> None); select = (function Manager (Delegation _ as op) -> Some op | _ -> None); - proj = (function Delegation key -> key); + proj = (function[@coq_match_with_default] Delegation key -> key); inj = (fun key -> Delegation key); } @@ -1057,13 +1057,16 @@ module Internal_result = struct (fun ((), x) -> inj x) let encoding = - let make (MCase {tag; name; encoding; iselect = _; select; proj; inj}) = - case - (Tag tag) - name - encoding - (fun o -> match select o with None -> None | Some o -> Some (proj o)) - (fun x -> Manager (inj x)) + let make m_case = + match[@coq_grab_existentials] m_case with + | MCase {tag; name; encoding; iselect = _; select; proj; inj} -> + case + (Tag tag) + name + encoding + (fun o -> + match select o with None -> None | Some o -> Some (proj o)) + (fun x -> Manager (inj x)) in union ~tag_size:`Uint8 @@ -1085,9 +1088,12 @@ 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_result.MCase ires_case : kind Internal_result.case) = - match[@coq_grab_existentials] res_case.op_case with - | Operation.Encoding.Manager_operations.MCase op_case -> + (ires_case : kind Internal_result.case) = + let (Operation.Encoding.Manager_operations.MCase op_case) = + res_case.op_case + in + match[@coq_grab_existentials] ires_case with + | Internal_result.MCase ires_case -> case (Tag op_case.tag) ~title:op_case.name diff --git a/src/proto_alpha/lib_protocol/raw_context_intf.ml b/src/proto_alpha/lib_protocol/raw_context_intf.ml index b3f1ad418e55a..8840c5d9c8b37 100644 --- a/src/proto_alpha/lib_protocol/raw_context_intf.ml +++ b/src/proto_alpha/lib_protocol/raw_context_intf.ml @@ -28,9 +28,6 @@ as-is for direct context accesses, and used in {!Storage_functors} to provide restricted views to the context. *) -(** The tree depth of a fold. See the [fold] function for more information. *) -type depth = [`Eq of int | `Le of int | `Lt of int | `Ge of int | `Gt of int] - (** The type for context configuration. If two trees or stores have the same configuration, they will generate the same context hash. *) type config = Context.config diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 9622033f39eae..f225e77368bd2 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -200,7 +200,8 @@ let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = let outputs = List.length tx.outputs in Interp_costs.sapling_verify_update_deprecated ~inputs ~outputs | (ISplit_ticket _, (accu : _ ticket), (stack : (_ * _) * _)) -> - let ticket = accu and ((amount_a, amount_b), _) = stack in + let ticket = accu in + let ((amount_a, amount_b), _) = stack in Interp_costs.split_ticket ticket.amount amount_a amount_b | (IJoin_tickets (_, ty, _), (ticket_a_b : _ ticket * _ ticket), _) -> let (ticket_a, ticket_b) = ticket_a_b in diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 4b66d23694bf1..20ade0d827390 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1825,6 +1825,7 @@ type ('arg, 'storage) code = code_size : Cache_memory_helpers.sint; } -> ('arg, 'storage) code +[@@coq_force_gadt] type ex_script = Ex_script : ('a, 'c) Script_typed_ir.script -> ex_script @@ -1959,7 +1960,7 @@ let find_entrypoint (type full fullc error_trace) (entrypoints : full entrypoints) entrypoint : (full ex_ty_cstr, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let rec find_entrypoint : + let[@coq_struct "ty"] rec find_entrypoint : type t tc. (t, tc) ty -> t entrypoints_node -> @@ -1967,7 +1968,7 @@ let find_entrypoint (type full fullc error_trace) (t ex_ty_cstr, unit) Gas_monad.t = fun ty entrypoints entrypoint -> let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in - match[@coq_match_with_default] (ty, entrypoints) with + match[@coq_match_gadt] [@coq_match_with_default] (ty, entrypoints) with | (_, {at_node = Some {name; original_type_expr}; _}) when Entrypoint.(name = entrypoint) -> return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) @@ -2009,7 +2010,13 @@ let find_entrypoint_for_type (type full fullc exp expc error_trace) entrypoints entrypoint loc : (Entrypoint.t * (exp, expc) ty, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let* res = find_entrypoint ~error_details full entrypoints entrypoint in + let* res = + (find_entrypoint + ~error_details + full + entrypoints + entrypoint [@coq_type_annotation]) + in match res with | Ex_ty_cstr {ty; _} -> ( match entrypoints.root.at_node with @@ -2827,7 +2834,9 @@ let[@coq_struct "ctxt"] rec parse_data_aux : | (Big_map_t (tk, tv, _ty_name), expr) -> (match expr with | Int (loc, id) -> - return (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + return + (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + [@coq_type_annotation] | Seq (_, vs) -> parse_big_map_items ?type_logger ctxt expr tk tv vs (fun x -> Some x) >|=? fun (diff, ctxt) -> (None, diff, ctxt) @@ -2948,7 +2957,7 @@ let[@coq_struct "ctxt"] rec parse_data_aux : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | (Sapling_transaction_deprecated_t _, expr) -> - (traced_fail [@coq_implicit "(B := a * Raw_context.t)"]) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) | (Sapling_state_t memo_size, Int (loc, id)) -> if allow_forged then @@ -4761,7 +4770,7 @@ and[@coq_struct "ctxt"] parse_instr_aux : Lwt.return ( parse_entrypoint_annot_lax loc annot >>? fun entrypoint -> let open Tc_context in - match tc_context.callsite with + match[@coq_match_gadt] tc_context.callsite with | _ when is_in_lambda tc_context -> error (Forbidden_instr_in_context (loc, Script_tc_errors.Lambda, prim)) @@ -4774,11 +4783,11 @@ and[@coq_struct "ctxt"] parse_instr_aux : (Forbidden_instr_in_context (loc, Script_tc_errors.View, prim)) | Toplevel {param_type; entrypoints; storage_type = _} -> Gas_monad.run ctxt - @@ find_entrypoint - ~error_details:Informative - param_type - entrypoints - entrypoint + @@ (find_entrypoint + ~error_details:Informative + param_type + entrypoints + entrypoint [@coq_type_annotation]) >>? fun (r, ctxt) -> r >>? fun (Ex_ty_cstr {ty = param_type; _}) -> contract_t loc param_type >>? fun res_ty -> @@ -5207,12 +5216,14 @@ and[@coq_mutual_as_notation] parse_contract_aux : ~stack_depth:(stack_depth + 1) ~legacy:true arg_type - >>? fun ( Ex_parameter_ty_and_entrypoints - {arg_type = targ; entrypoints}, - ctxt ) -> + >>? fun [@coq_match_gadt] ( Ex_parameter_ty_and_entrypoints + {arg_type = targ; entrypoints}, + ctxt ) -> (* we don't check targ size here because it's a legacy contract code *) Gas_monad.run ctxt - @@ find_entrypoint_for_type + @@ (find_entrypoint_for_type + [@coq_implicit + "full" "__Ex_parameter_ty_and_entrypoints_'a1"]) ~error_details:Informative ~full:targ ~expected:arg @@ -5404,7 +5415,7 @@ let parse_contract_for_script : match parse_toplevel_aux ctxt ~legacy:true code with | Error _ -> error (Invalid_contract (loc, contract)) | Ok ({arg_type; _}, ctxt) -> ( - match + match[@coq_match_gadt] parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:0 @@ -5418,7 +5429,9 @@ let parse_contract_for_script : ctxt ) -> ( (* we don't check targ size here because it's a legacy contract code *) Gas_monad.run ctxt - @@ find_entrypoint_for_type + @@ (find_entrypoint_for_type + [@coq_implicit + "full" "__Ex_parameter_ty_and_entrypoints_'a"]) ~error_details:Fast ~full:targ ~expected:arg @@ -5807,53 +5820,64 @@ let[@coq_struct "ctxt"] rec unparse_data_aux : unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) | (Big_map_t (kt, vt, _), (x : _ big_map)) -> ( - let (Big_map {id; diff = {map; size; _}; _}) = x in - match id with - | Some id -> - if Compare.Int.( = ) size 0 then - return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) - else - let items = - Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] - in - let items = - (* Sort the items in Michelson comparison order and not in key - hash order. This code path is only exercised for tracing, - so we don't bother carbonating this sort operation - precisely. Also, the sort uses a reverse compare because - [unparse_items] will reverse the result. *) - List.sort - (fun (a, _) (b, _) -> - Script_comparable.compare_comparable kt b a) - items - in - (* this can't fail if the original type is well-formed - because [option vt] is always strictly smaller than [big_map kt vt] *) - option_t loc vt >>?= fun vt -> - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> - ( Micheline.Prim - ( loc, - D_Pair, - [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], - [] ), - ctxt ) - | None -> - let items = - Big_map_overlay.fold - (fun _ (k, v) acc -> - match v with None -> acc | Some v -> (k, v) :: acc) - map - [] - in - let items = - (* See note above. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)) + match[@coq_match_gadt] x with + | Big_map {id; diff = {map; size; _}; _} -> ( + match id with + | Some id -> + if Compare.Int.( = ) size 0 then + return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) + else + let items = + Big_map_overlay.fold + (fun _ (k, v) acc -> (k, v) :: acc) + map + [] + in + let items = + (* Sort the items in Michelson comparison order and not in key + hash order. This code path is only exercised for tracing, + so we don't bother carbonating this sort operation + precisely. Also, the sort uses a reverse compare because + [unparse_items] will reverse the result. *) + List.sort + (fun (a, _) (b, _) -> + Script_comparable.compare_comparable kt b a) + items + in + (* this can't fail if the original type is well-formed + because [option vt] is always strictly smaller than [big_map kt vt] *) + option_t loc vt >>?= fun vt -> + unparse_items + ctxt + ~stack_depth:(stack_depth + 1) + mode + kt + vt + items + >|=? fun (items, ctxt) -> + ( Micheline.Prim + ( loc, + D_Pair, + [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], + [] ), + ctxt ) + | None -> + let items = + Big_map_overlay.fold + (fun _ (k, v) acc -> + match v with None -> acc | Some v -> (k, v) :: acc) + map + [] + in + let items = + (* See note above. *) + List.sort + (fun (a, _) (b, _) -> + Script_comparable.compare_comparable kt b a) + items + in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt))) | (Lambda_t _, (x : _ lambda)) -> let (Lam (_, original_code)) = x in unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code @@ -5865,7 +5889,8 @@ let[@coq_struct "ctxt"] rec unparse_data_aux : Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s in (Bytes (loc, bytes), ctxt) ) - | (Sapling_transaction_deprecated_t _, s) -> + | (Sapling_transaction_deprecated_t _, (s : Sapling_repr.legacy_transaction)) + -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) >|? fun ctxt -> @@ -6076,11 +6101,11 @@ let pack_data ctxt ty data = (* ---------------- Big map -------------------------------------------------*) -let empty_big_map key_type value_type = +let empty_big_map key_type value_type : ('a, 'b) big_map = Big_map { id = None; - diff = {map = Big_map_overlay.empty; size = 0}; + diff = {map = Big_map_overlay.empty; size = 0} [@coq_type_annotation]; key_type; value_type; } @@ -6094,40 +6119,44 @@ let big_map_mem ctxt key (Big_map {id; diff; key_type; _}) = | (Some (_, None), _) -> return (false, ctxt) | (Some (_, Some _), _) -> return (true, ctxt) -let big_map_get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = - match (Big_map_overlay.find key diff.map, id) with - | (Some (_, x), _) -> return (x, ctxt) - | (None, None) -> return (None, ctxt) - | (None, Some id) -> ( - Alpha_context.Big_map.get_opt ctxt id key >>=? function - | (ctxt, None) -> return (None, ctxt) - | (ctxt, Some value) -> - parse_data_aux - ~stack_depth:0 - ctxt - ~legacy:true - ~allow_forged:true - value_type - (Micheline.root value) - >|=? fun (x, ctxt) -> (Some x, ctxt)) +let big_map_get_by_hash ctxt key big_map = + match[@coq_match_gadt] big_map with + | Big_map {id; diff; value_type; _} -> ( + match (Big_map_overlay.find key diff.map, id) with + | (Some (_, x), _) -> return (x, ctxt) + | (None, None) -> return (None, ctxt) + | (None, Some id) -> ( + Alpha_context.Big_map.get_opt ctxt id key >>=? function + | (ctxt, None) -> return (None, ctxt) + | (ctxt, Some value) -> + parse_data_aux + ~stack_depth:0 + ctxt + ~legacy:true + ~allow_forged:true + value_type + (Micheline.root value) + >|=? fun (x, ctxt) -> (Some x, ctxt))) let big_map_get ctxt key (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - big_map_get_by_hash ctxt key_hash map + (big_map_get_by_hash [@coq_implicit "B" "A"]) ctxt key_hash map -let big_map_update_by_hash ctxt key_hash key value (Big_map map) = - let contains = Big_map_overlay.mem key_hash map.diff.map in - return - ( Big_map - { - map with - diff = +let big_map_update_by_hash ctxt key_hash key value map = + match[@coq_match_gadt] map with + | Big_map map -> + let contains = Big_map_overlay.mem key_hash map.diff.map in + return + ( Big_map { - map = Big_map_overlay.add key_hash (key, value) map.diff.map; - size = (if contains then map.diff.size else map.diff.size + 1); - }; - }, - ctxt ) + map with + diff = + { + map = Big_map_overlay.add key_hash (key, value) map.diff.map; + size = (if contains then map.diff.size else map.diff.size + 1); + }; + }, + ctxt ) let big_map_update ctxt key value (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> @@ -6136,8 +6165,8 @@ let big_map_update ctxt key value (Big_map {key_type; _} as map) = let big_map_get_and_update ctxt key value (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> big_map_update_by_hash ctxt key_hash key value map >>=? fun (map', ctxt) -> - big_map_get_by_hash ctxt key_hash map >>=? fun (old_value, ctxt) -> - return ((old_value, map'), ctxt) + (big_map_get_by_hash [@coq_implicit "B" "B"]) ctxt key_hash map + >>=? fun (old_value, ctxt) -> return ((old_value, map'), ctxt) (* ---------------- Lazy storage---------------------------------------------*) @@ -6146,60 +6175,63 @@ type lazy_storage_ids = Lazy_storage.IdSet.t let no_lazy_storage_id = Lazy_storage.IdSet.empty let diff_of_big_map ctxt mode ~temporary ~ids_to_copy - (Big_map {id; key_type; value_type; diff}) = - (match id with - | Some id -> - if Lazy_storage.IdSet.mem Big_map id ids_to_copy then - Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> - (ctxt, Lazy_storage.Copy {src = id}, duplicate) - else - (* The first occurrence encountered of a big_map reuses the - ID. This way, the payer is only charged for the diff. - For this to work, this diff has to be put at the end of - the global diff, otherwise the duplicates will use the - updated version as a base. This is true because we add - this diff first in the accumulator of - `extract_lazy_storage_updates`, and this accumulator is not - reversed. *) - return (ctxt, Lazy_storage.Existing, id) - | None -> - Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> - Lwt.return - (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in - Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> - unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> - let key_type = Micheline.strip_locations kt in - let value_type = Micheline.strip_locations kv in - (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) - >>=? fun (ctxt, init, id) -> - let pairs = - Big_map_overlay.fold - (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) - diff.map - [] - in - List.fold_left_es - (fun (acc, ctxt) (key_hash, key, value) -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - unparse_comparable_data ~loc:() ctxt mode key_type key - >>=? fun (key_node, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost key_node) >>?= fun ctxt -> - let key = Micheline.strip_locations key_node in - (match value with - | None -> return (None, ctxt) - | Some x -> - unparse_data_aux ~stack_depth:0 ctxt mode value_type x - >>=? fun (node, ctxt) -> + (big_map : ('a, 'b) big_map) = + match[@coq_match_gadt] big_map with + | Big_map {id; key_type; value_type; diff} -> + (match id with + | Some id -> + if Lazy_storage.IdSet.mem Big_map id ids_to_copy then + Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> + (ctxt, Lazy_storage.Copy {src = id}, duplicate) + else + (* The first occurrence encountered of a big_map reuses the + ID. This way, the payer is only charged for the diff. + For this to work, this diff has to be put at the end of + the global diff, otherwise the duplicates will use the + updated version as a base. This is true because we add + this diff first in the accumulator of + `extract_lazy_storage_updates`, and this accumulator is not + reversed. *) + return (ctxt, Lazy_storage.Existing, id) + | None -> + Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> Lwt.return - ( Gas.consume ctxt (Script.strip_locations_cost node) >|? fun ctxt -> - (Some (Micheline.strip_locations node), ctxt) )) - >|=? fun (value, ctxt) -> - let diff_item = Big_map.{key; key_hash; value} in - (diff_item :: acc, ctxt)) - ([], ctxt) - (List.rev pairs) - >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) + (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in + Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> + unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> + let key_type = Micheline.strip_locations kt in + let value_type = Micheline.strip_locations kv in + (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) + >>=? fun (ctxt, init, id) -> + let pairs : (Script_expr_hash.t * 'a * 'b option) list = + Big_map_overlay.fold + (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) + diff.map + [] + in + List.fold_left_es + (fun (acc, ctxt) (key_hash, key, value) -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> + unparse_comparable_data ~loc:() ctxt mode key_type key + >>=? fun (key_node, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost key_node) + >>?= fun ctxt -> + let key = Micheline.strip_locations key_node in + (match value with + | None -> return (None, ctxt) + | Some x -> + unparse_data_aux ~stack_depth:0 ctxt mode value_type x + >>=? fun (node, ctxt) -> + Lwt.return + ( Gas.consume ctxt (Script.strip_locations_cost node) + >|? fun ctxt -> (Some (Micheline.strip_locations node), ctxt) )) + >|=? fun (value, ctxt) -> + let diff_item = Big_map.{key; key_hash; value} in + (diff_item :: acc, ctxt)) + ([], ctxt) + (List.rev pairs) + >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) let diff_of_sapling_state ctxt ~temporary ~ids_to_copy ({id; diff; memo_size} : Sapling.state) = diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 6f47224b86a32..1cfe28ee5146e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -111,6 +111,7 @@ type ('arg, 'storage) code = field as it has a dynamic size. *) } -> ('arg, 'storage) code +[@@coq_force_gadt] type ex_code = Ex_code : ('a, 'c) code -> ex_code diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index dbe99010c087a..21aa52c3245bc 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1151,6 +1151,7 @@ and 'arg typed_contract = address : address; } -> 'arg typed_contract +[@@coq_force_gadt] and (_, _, _, _) continuation = | KNil : ('r, 'f, 'r, 'f) continuation @@ -1302,6 +1303,7 @@ and ('key, 'value) big_map = value_type : ('value, _) ty; } -> ('key, 'value) big_map +[@@coq_force_gadt] and ('a, 's, 'r, 'f) kdescr = { kloc : Script.location; @@ -1367,6 +1369,7 @@ and ('input, 'output) view_signature = output_ty : ('output, _) ty; } -> ('input, 'output) view_signature +[@@coq_force_gadt] and 'kind manager_operation = | Transaction : { diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index df5507e49d691..cef6f6b90a17b 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1149,6 +1149,7 @@ and 'arg typed_contract = address : address; } -> 'arg typed_contract +[@@coq_force_gadt] (* @@ -1396,6 +1397,7 @@ and ('key, 'value) big_map = value_type : ('value, _) ty; } -> ('key, 'value) big_map +[@@coq_force_gadt] and ('a, 's, 'r, 'f) kdescr = { kloc : Script.location; @@ -1495,6 +1497,7 @@ and ('input, 'output) view_signature = output_ty : ('output, _) ty; } -> ('input, 'output) view_signature +[@@coq_force_gadt] and 'kind manager_operation = | Transaction : { diff --git a/src/proto_alpha/lib_protocol/services_registration.ml b/src/proto_alpha/lib_protocol/services_registration.ml index de94c5dbdf695..4fa5d81a2d9c3 100644 --- a/src/proto_alpha/lib_protocol/services_registration.ml +++ b/src/proto_alpha/lib_protocol/services_registration.ml @@ -31,12 +31,14 @@ type rpc_context = { context : Alpha_context.t; } +type level = Head_level | Successor_level + let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) mode = let timestamp = block_header.timestamp in let level = match mode with - | `Head_level -> block_header.level - | `Successor_level -> Int32.succ block_header.level + | Head_level -> block_header.level + | Successor_level -> Int32.succ block_header.level in Alpha_context.prepare ~level @@ -51,7 +53,7 @@ let rpc_services = let register0_fullctxt ~chunked s f = rpc_services := RPC_directory.register ~chunked !rpc_services s (fun ctxt q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let register0 ~chunked s f = register0_fullctxt ~chunked s (fun {context; _} -> f context) @@ -63,7 +65,7 @@ let register0_noctxt ~chunked s f = let register1_fullctxt ~chunked s f = rpc_services := RPC_directory.register ~chunked !rpc_services s (fun (ctxt, arg) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let register1 ~chunked s f = register1_fullctxt ~chunked s (fun {context; _} x -> f context x) @@ -75,7 +77,7 @@ let register2_fullctxt ~chunked s f = !rpc_services s (fun ((ctxt, arg1), arg2) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let register2 ~chunked s f = register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i -> @@ -84,7 +86,7 @@ let register2 ~chunked s f = let opt_register0_fullctxt ~chunked s f = rpc_services := RPC_directory.opt_register ~chunked !rpc_services s (fun ctxt q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let opt_register0 ~chunked s f = opt_register0_fullctxt ~chunked s (fun {context; _} -> f context) @@ -92,7 +94,7 @@ let opt_register0 ~chunked s f = let opt_register1_fullctxt ~chunked s f = rpc_services := RPC_directory.opt_register ~chunked !rpc_services s (fun (ctxt, arg) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let opt_register1 ~chunked s f = opt_register1_fullctxt ~chunked s (fun {context; _} x -> f context x) @@ -104,7 +106,7 @@ let opt_register2_fullctxt ~chunked s f = !rpc_services s (fun ((ctxt, arg1), arg2) q i -> - rpc_init ctxt `Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) + rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let opt_register2 ~chunked s f = opt_register2_fullctxt ~chunked s (fun {context; _} a1 a2 q i -> @@ -114,7 +116,7 @@ let get_rpc_services () = let p = RPC_directory.map (fun c -> - rpc_init c `Head_level >|= function + rpc_init c Head_level >|= function | Error t -> raise (Failure (Format.asprintf "%a" Error_monad.pp_trace t)) | Ok c -> c.context) diff --git a/src/proto_alpha/lib_protocol/services_registration.mli b/src/proto_alpha/lib_protocol/services_registration.mli index c6bc2ed72c92a..da7faca5500a2 100644 --- a/src/proto_alpha/lib_protocol/services_registration.mli +++ b/src/proto_alpha/lib_protocol/services_registration.mli @@ -44,6 +44,8 @@ type rpc_context = { context : t; } +type level = Head_level | Successor_level + (** [rpc_init rpc_context mode] allows to instantiate an [rpc_context] using the [Alpha_context] representation from a raw context representation (the one the shell knows). @@ -60,9 +62,7 @@ type rpc_context = { paths depend on the level. Using the successor level allows to ensure that the simulation is done on a fresh level. *) val rpc_init : - Updater.rpc_context -> - [`Head_level | `Successor_level] -> - rpc_context Error_monad.tzresult Lwt.t + Updater.rpc_context -> level -> rpc_context Error_monad.tzresult Lwt.t val register0 : chunked:bool -> diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index a508530f3078a..df7d4e4fdb583 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -191,15 +191,15 @@ let tickets_of_transaction ctxt ~destination ~entrypoint ~location (Script {arg_type; entrypoints; _}), ctxt ) -> (* Find the entrypoint type for the given entrypoint. *) - Gas_monad.run - ctxt - (Script_ir_translator.find_entrypoint - ~error_details:Informative - arg_type - entrypoints - entrypoint) + (Gas_monad.run + ctxt + (Script_ir_translator.find_entrypoint + ~error_details:Informative + arg_type + entrypoints + entrypoint) [@coq_type_annotation]) >>?= fun (res, ctxt) -> - res >>?= fun (Ex_ty_cstr {ty = entry_arg_ty; _}) -> + res >>?= fun [@coq_match_gadt] (Ex_ty_cstr {ty = entry_arg_ty; _}) -> Ticket_scanner.type_has_tickets ctxt entry_arg_ty >>?= fun (has_tickets, ctxt) -> (* Check that the parameter's type matches that of the entry-point, and diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index e9584d1b286ff..ccb047487c62f 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -517,6 +517,7 @@ type 'a has_tickets = | Has_tickets : 'a Ticket_inspection.has_tickets * ('a, _) Script_typed_ir.ty -> 'a has_tickets +[@@coq_force_gadt] let type_has_tickets ctxt ty = Ticket_inspection.has_tickets_of_ty ctxt ty >|? fun (has_tickets, ctxt) -> diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml index 80edb6960fcb2..ae3b050dd6ba7 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml @@ -688,7 +688,8 @@ module Make (Context : CONTEXT) = struct failed because of a [Counter_mismatch] the counters are left untouched. *) - let[@coq_axiom_with_reason "match on extensible type not at the head"] update_counters ctxt status transaction = + let[@coq_axiom_with_reason "match on extensible type not at the head"] update_counters + ctxt status transaction = match status with | Transaction_failure {reason = Counter_mismatch _; _} -> return ctxt | Transaction_failure _ | Transaction_success -> -- GitLab From 4277fcbf23da8fd93bccd8f7e94fcaa90aeedd0e Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 22 Mar 2022 13:10:53 +0100 Subject: [PATCH 065/105] Proto: more changes for coq-of-ocaml --- src/proto_alpha/lib_protocol/apply.ml | 2 +- .../lib_protocol/script_interpreter.ml | 30 ++++++++++++++----- 2 files changed, 24 insertions(+), 8 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 3702a5d570918..6eee58ac848f8 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1243,7 +1243,7 @@ let apply_internal_manager_operation_content : | Delegation delegate -> apply_delegation ~ctxt ~source ~delegate ~before_operation -let apply_external_manager_operation_content : +let[@coq_axiom_with_reason "unresolved implicit type"] apply_external_manager_operation_content : type kind. context -> Script_ir_translator.unparsing_mode -> diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index d7c67800ffee9..929385e5a2c3b 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -238,9 +238,8 @@ let ifailwith : ifailwith_type = { ifailwith = (fun logger (ctxt, _) gas kloc tv accu -> - let v = accu in let ctxt = update_context gas ctxt in - trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v) + trace Cannot_serialize_failure (unparse_data ctxt Optimized tv accu) >>=? fun (v, _ctxt) -> let v = Micheline.strip_locations v in get_log logger >>=? fun log -> fail (Reject (kloc, v, log))); @@ -719,7 +718,11 @@ and[@coq_struct "function_parameter"] step : (* Big map operations *) | (IEmpty_big_map (_, tk, tv, k), _, _) -> let ebm = - (Script_ir_translator.empty_big_map [@coq_type_annotation]) tk tv + (Script_ir_translator.empty_big_map + [@coq_implicit "a" "__IEmpty_big_map_'b"] + [@coq_implicit "b" "__IEmpty_big_map_'c"]) + tk + tv in (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack) | (IBig_map_mem (_, k), _, (stack : _ * _)) -> @@ -735,7 +738,13 @@ and[@coq_struct "function_parameter"] step : ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.big_map_get ctxt key map ) >>=? fun (res, ctxt, gas) -> - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (res [@coq_type_annotation]) + stack | (IBig_map_update (_, k), _, (stack : _ * (_ * _))) -> let key = accu in let (maybe_value, (map, stack)) = stack in @@ -1461,7 +1470,14 @@ and[@coq_struct "function_parameter"] step : (Script_int.of_int64 balance, state) ) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) | ( ISapling_verify_update_deprecated (_, k), (accu : Sapling_repr.legacy_transaction), (stack : _ * _) ) -> ( @@ -2010,8 +2026,8 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal ctxt (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint) >>?= fun (r, ctxt) -> - record_trace (Bad_contract_parameter step_constants.self) r - >>?= fun (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _}) + record_trace (Bad_contract_parameter step_constants.self) (r [@coq_type_annotation]) + >>?= fun [@coq_match_gadt] (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _}) -> trace (Bad_contract_parameter step_constants.self) -- GitLab From 8f8c0d6480634f6a2d7328c0c6981685b2a918f9 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 25 Mar 2022 00:51:11 +0100 Subject: [PATCH 066/105] Proto: add missing operation_repr definition for Coq --- src/proto_alpha/lib_protocol/script_interpreter.ml | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 929385e5a2c3b..f97f882e39cce 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -2026,9 +2026,15 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal ctxt (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint) >>?= fun (r, ctxt) -> - record_trace (Bad_contract_parameter step_constants.self) (r [@coq_type_annotation]) - >>?= fun [@coq_match_gadt] (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _}) - -> + record_trace + (Bad_contract_parameter step_constants.self) + (r [@coq_type_annotation]) + >>?= fun [@coq_match_gadt] (Ex_ty_cstr + { + ty = entrypoint_ty; + construct; + original_type_expr = _; + }) -> trace (Bad_contract_parameter step_constants.self) (lift_execution_arg ctxt ~internal entrypoint_ty construct arg) -- GitLab From d343618b42a594841d2ff55aaa0d09cd45f749f4 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Mon, 28 Mar 2022 01:50:13 +0200 Subject: [PATCH 067/105] Proto: more changes for coq-of-ocaml --- src/proto_alpha/bin_sc_rollup_node/store.ml | 2 + .../lib_protocol/alpha_context.mli | 6 +- src/proto_alpha/lib_protocol/apply_results.ml | 2 +- .../lib_protocol/dependent_bool.ml | 4 +- .../lib_protocol/dependent_bool.mli | 2 +- src/proto_alpha/lib_protocol/indexable.ml | 2 +- src/proto_alpha/lib_protocol/merkle_list.ml | 14 ++- src/proto_alpha/lib_protocol/merkle_list.mli | 7 +- .../lib_protocol/sc_rollup_arith.ml | 32 ++++-- .../lib_protocol/sc_rollup_inbox_repr.ml | 22 +++- .../lib_protocol/sc_rollup_inbox_repr.mli | 2 + .../lib_protocol/sc_rollup_repr.mli | 2 +- .../lib_protocol/sc_rollup_storage.ml | 4 +- .../lib_protocol/sc_rollup_tick_repr.ml | 26 +++-- .../lib_protocol/script_interpreter.ml | 2 +- .../lib_protocol/script_ir_translator.ml | 26 +++-- .../lib_protocol/script_typed_ir.ml | 9 +- .../lib_protocol/script_typed_ir.mli | 4 +- .../lib_protocol/script_typed_ir_size.ml | 2 +- .../lib_protocol/skip_list_repr.ml | 18 +-- .../lib_protocol/skip_list_repr.mli | 6 +- src/proto_alpha/lib_protocol/storage.ml | 2 +- .../lib_protocol/ticket_operations_diff.ml | 5 +- .../lib_protocol/ticket_scanner.ml | 4 +- .../lib_protocol/tx_rollup_l2_apply.ml | 106 ++++++++++++++++++ .../lib_protocol/tx_rollup_l2_apply.mli | 9 +- .../lib_protocol/tx_rollup_l2_context.ml | 3 +- .../lib_protocol/tx_rollup_l2_context_sig.ml | 67 ++++++----- .../lib_protocol/tx_rollup_parameters.ml | 6 +- .../lib_protocol/tx_rollup_state_repr.ml | 2 +- 30 files changed, 286 insertions(+), 112 deletions(-) diff --git a/src/proto_alpha/bin_sc_rollup_node/store.ml b/src/proto_alpha/bin_sc_rollup_node/store.ml index a528546ee8c39..18874ade3adce 100644 --- a/src/proto_alpha/bin_sc_rollup_node/store.ml +++ b/src/proto_alpha/bin_sc_rollup_node/store.ml @@ -128,6 +128,8 @@ module IStoreTree = struct type key = path type value = bytes + + let __infer_t _ = () end module Inbox = Sc_rollup.Inbox.MakeHashingScheme (IStoreTree) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 2277f3d7bf055..baef949694131 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2491,9 +2491,9 @@ module Sc_rollup : sig module Staker : S.SIGNATURE_PUBLIC_KEY_HASH with type t = Signature.Public_key_hash.t - module Commitment_hash : S.HASH + module Commitment_hash : S.HASH [@@coq_plain_module] - module State_hash : S.HASH + module State_hash : S.HASH [@@coq_plain_module] module Number_of_messages : Bounded.Int32.S @@ -2601,6 +2601,8 @@ module Sc_rollup : sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end module MakeHashingScheme (Tree : TREE) : diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index d3de9e9e6d34c..b6e3f22f3b908 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -930,7 +930,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_publish_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_publish_result {consumed_gas; staked_hash} -> (Gas.Arith.ceil consumed_gas, consumed_gas, staked_hash)) ~kind:Kind.Sc_rollup_publish_manager_kind diff --git a/src/proto_alpha/lib_protocol/dependent_bool.ml b/src/proto_alpha/lib_protocol/dependent_bool.ml index 8fb3c49ec11a7..5ae4a13404e10 100644 --- a/src/proto_alpha/lib_protocol/dependent_bool.ml +++ b/src/proto_alpha/lib_protocol/dependent_bool.ml @@ -36,7 +36,7 @@ type ('a, 'b, 'r) dand = | YesYes : (yes, yes, yes) dand type ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand -[@@unboxed] +[@@unboxed] [@@coq_force_gadt] let dand : type a b. a dbool -> b dbool -> (a, b) ex_dand = fun a b -> @@ -57,7 +57,7 @@ type (_, _) eq = Eq : ('a, 'a) eq let merge_dand : type a b c1 c2. (a, b, c1) dand -> (a, b, c2) dand -> (c1, c2) eq = fun w1 w2 -> - match (w1, w2) with + match[@coq_match_with_default] (w1, w2) with | (NoNo, NoNo) -> Eq | (NoYes, NoYes) -> Eq | (YesNo, YesNo) -> Eq diff --git a/src/proto_alpha/lib_protocol/dependent_bool.mli b/src/proto_alpha/lib_protocol/dependent_bool.mli index 54416d9fd9c3e..a5265a36a14f0 100644 --- a/src/proto_alpha/lib_protocol/dependent_bool.mli +++ b/src/proto_alpha/lib_protocol/dependent_bool.mli @@ -46,7 +46,7 @@ type ('a, 'b, 'r) dand = | YesYes : (yes, yes, yes) dand type ('a, 'b) ex_dand = Ex_dand : ('a, 'b, _) dand -> ('a, 'b) ex_dand -[@@unboxed] +[@@unboxed] [@@coq_force_gadt] (** Logical conjunction of dependent booleans. *) val dand : 'a dbool -> 'b dbool -> ('a, 'b) ex_dand diff --git a/src/proto_alpha/lib_protocol/indexable.ml b/src/proto_alpha/lib_protocol/indexable.ml index 4365483c7f732..9a103016a0f5b 100644 --- a/src/proto_alpha/lib_protocol/indexable.ml +++ b/src/proto_alpha/lib_protocol/indexable.ml @@ -238,7 +238,7 @@ module Make (V : VALUE) : INDEXABLE with type v_t := V.t = struct let compare_values : value -> value -> int = compare_values V.compare - let compare_indexes = compare_indexes + let compare_indexes : index -> index -> int = compare_indexes let compare : 'state t -> 'state' t -> int = fun x y -> compare V.compare x y end diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml index 88da122fa3146..c7bb2ad328802 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.ml +++ b/src/proto_alpha/lib_protocol/merkle_list.ml @@ -88,12 +88,14 @@ module type T = sig end end -module Make (El : sig +module type S_El = sig type t val to_bytes : t -> bytes -end) -(H : S.HASH) : T with type elt = El.t and type h = H.t = struct +end + +module Make (El : S_El) (H : S.HASH) : T with type elt = El.t and type h = H.t = +struct type h = H.t type elt = El.t @@ -164,7 +166,7 @@ end) Pre-condition: pos >= 0 /| pos < 2^depth Post-condition: len(to_bin pos depth) = depth *) let to_bin ~pos ~depth = - let rec aux acc pos depth = + let[@coq_struct "depth"] rec aux acc pos depth = let (pos', dir) = (pos / 2, pos mod 2) in match depth with | 0 -> acc @@ -175,14 +177,14 @@ end) (* Constructs a tree of a given depth in which every right subtree is empty * and the only leaf contains the hash of el. *) let make_spine_with el = - let rec aux left = function + let[@coq_struct "function_parameter"] rec aux left = function | 0 -> left | d -> (aux [@tailcall]) (node_of left Empty) (d - 1) in aux (leaf_of el) let snoc t (el : elt) = - let rec traverse tree depth key = + let[@coq_struct "depth"] rec traverse tree depth key = match (tree, key) with | (Node (_, t_left, Empty), true :: _key) -> (* The base case where the left subtree is full and we start diff --git a/src/proto_alpha/lib_protocol/merkle_list.mli b/src/proto_alpha/lib_protocol/merkle_list.mli index 2352d451b7738..8a40dbe749eee 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.mli +++ b/src/proto_alpha/lib_protocol/merkle_list.mli @@ -107,9 +107,10 @@ module type T = sig end end -module Make (El : sig +module type S_El = sig type t val to_bytes : t -> bytes -end) -(H : S.HASH) : T with type elt = El.t and type h = H.t +end + +module Make (El : S_El) (H : S.HASH) : T with type elt = El.t and type h = H.t diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 67d40d068be53..2f4105f5b2dfc 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -233,7 +233,7 @@ module Make (Context : P) : open Monad open Monad.Syntax - module MakeVar (P : sig + module type P_MakeVar = sig type t val name : string @@ -243,8 +243,21 @@ module Make (Context : P) : val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t - end) = - struct + end + + module type S_MakeVar = sig + type t + + val create : unit Monad.t + + val get : t Monad.t + + val set : t -> unit Monad.t + + val pp : (Format.formatter -> unit -> unit) Monad.t + end + + module MakeVar (P : P_MakeVar) : S_MakeVar with type t := P.t = struct let key = [P.name] let create = set_value key P.encoding P.initial @@ -265,14 +278,15 @@ module Make (Context : P) : return @@ fun fmt () -> Format.fprintf fmt "@[%s : %a@]" P.name P.pp v end - module MakeDeque (P : sig + module type P_MakeDeque = sig type t val name : string val encoding : t Data_encoding.t - end) = - struct + end + + module MakeDeque (P : P_MakeDeque) = struct (* A stateful deque. @@ -343,11 +357,13 @@ module Make (Context : P) : let clear = remove [P.name] end - module CurrentTick = MakeVar (struct + module Tick_with_name = struct include Tick let name = "tick" - end) + end + + module CurrentTick = MakeVar (Tick_with_name) module Stack = MakeDeque (struct type t = int diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml index be457b5de8bba..abb6421913aa4 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -330,11 +330,13 @@ module type TREE = sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end -module MakeHashingScheme (Tree : TREE) : - MerkelizedOperations with type tree = Tree.tree = struct - module Tree = Tree +module MakeHashingScheme (P : TREE) : + MerkelizedOperations with type tree = P.tree = struct + module Tree = P type tree = Tree.tree @@ -474,7 +476,7 @@ module MakeHashingScheme (Tree : TREE) : in (history, inbox) in - let rec aux (history, inbox) = + let[@coq_struct "function_parameter"] rec aux (history, inbox) = if Raw_level_repr.(inbox.level = target_level) then (history, inbox) else aux (archive_level history inbox) in @@ -552,7 +554,15 @@ end include ( MakeHashingScheme (struct - include Context.Tree + let find = Context.Tree.find + + let find_tree = Context.Tree.find_tree + + let add = Context.Tree.add + + let is_empty = Context.Tree.is_empty + + let hash = Context.Tree.hash type t = Context.t @@ -561,5 +571,7 @@ include ( type value = bytes type key = string list + + let __infer_t (_ : t) = () end) : MerkelizedOperations with type tree = Context.tree) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli index 705a988ea575a..f22d62a822fdd 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli @@ -271,6 +271,8 @@ module type TREE = sig val is_empty : tree -> bool val hash : tree -> Context_hash.t + + val __infer_t : t -> unit end (** diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli index decea0652e935..4e7c87c53fe7f 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli @@ -58,7 +58,7 @@ end module Commitment_hash : S.HASH [@@coq_plain_module] -module State_hash : S.HASH +module State_hash : S.HASH [@@coq_plain_module] (** Number of messages consumed by a single commitment. This represents a claim about the shape of the Inbox, which can be disputed as part of a commitment diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index 1a6cd89848bb4..b79466da00fdd 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml @@ -638,7 +638,7 @@ type conflict_point = arrives at the exact [inbox_level]. The result is the commit hash at the given inbox level. *) let goto_inbox_level ctxt rollup inbox_level commit = let open Lwt_tzresult_syntax in - let rec go ctxt commit = + let[@coq_struct "commit"] rec go ctxt commit = let* (info, ctxt) = get_commitment_internal ctxt rollup commit in if Raw_level_repr.(info.Sc_rollup_repr.Commitment.inbox_level <= inbox_level) @@ -689,7 +689,7 @@ let get_conflict_point ctxt rollup staker1 staker2 = (* The inbox level of a commitment increases by a fixed amount over the preceding commitment. We use this fact in the following to efficiently traverse both commitment histories towards the conflict points. *) - let rec traverse_in_parallel ctxt commit1 commit2 = + let[@coq_struct "commit1"] rec traverse_in_parallel ctxt commit1 commit2 = if Sc_rollup_repr.Commitment_hash.(commit1 = commit2) then (* This case will most dominantly happen when either commit is part of the other's history. It occurs when the commit that is farther ahead gets dereferenced to its predecessor often diff --git a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml index e16ac07c91347..293bef4d2da88 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml @@ -24,13 +24,13 @@ (* *) (*****************************************************************************) -include Z +type t = Z.t -let initial = zero +let initial = Z.zero -let next = succ +let next = Z.succ -let pp = pp_print +let pp = Z.pp_print let encoding = Data_encoding.n @@ -40,16 +40,24 @@ let of_int x = if Compare.Int.(x < 0) then None else Some (Z.of_int x) let to_int x = if Z.fits_int x then Some (Z.to_int x) else None -let ( <= ) = leq +let ( <= ) = Z.leq -let ( < ) = lt +let ( < ) = Z.lt -let ( >= ) = geq +let ( >= ) = Z.geq -let ( > ) = gt +let ( > ) = Z.gt -let ( = ) = equal +let ( = ) = Z.equal let ( <> ) x y = not (x = y) +let compare = Z.compare + +let equal = Z.equal + +let min = Z.min + +let max = Z.max + module Map = Map.Make (Z) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index f97f882e39cce..e0758b8a87191 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1988,7 +1988,7 @@ let lift_execution_arg (type a ac) ctxt ~internal (entrypoint_ty : (a, ac) ty) >>?= fun (res, ctxt) -> res >>?= fun Eq -> let parsed_arg : a = parsed_arg in - return (parsed_arg, ctxt)) + return ((parsed_arg [@coq_cast]), ctxt)) >>=? fun (entrypoint_arg, ctxt) -> return (construct entrypoint_arg, ctxt) type execution_result = { diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 20ade0d827390..3199c53ed403b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -162,7 +162,8 @@ let check_kind kinds expr = the end of the file. *) let rec ty_of_comparable_ty : - type a. a comparable_ty -> (a, Dependent_bool.yes) ty = function + type a. a comparable_ty -> (a, Dependent_bool.yes) ty = + function[@coq_match_with_default] | Unit_t -> Unit_t | Never_t -> Never_t | Int_t -> Int_t @@ -186,7 +187,7 @@ let rec ty_of_comparable_ty : let rec unparse_comparable_ty_uncarbonated : type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = - fun ~loc -> function + fun ~loc -> function[@coq_match_with_default] | Unit_t -> Prim (loc, T_unit, [], []) | Never_t -> Prim (loc, T_never, [], []) | Int_t -> Prim (loc, T_int, [], []) @@ -679,7 +680,8 @@ let hash_comparable_data ctxt ty data = All comparable types are dupable, this function exists only to not forget checking this property when adding new types. *) -let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function +let check_dupable_comparable_ty : type a. a comparable_ty -> unit = + function[@coq_match_with_default] | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t | Tx_rollup_l2_address_t | Pair_t _ | Union_t _ | Option_t _ -> @@ -796,7 +798,7 @@ let rec comparable_ty_eq : (ty_of_comparable_ty ta) (ty_of_comparable_ty tb)) in - match (ta, tb) with + match[@coq_match_with_default] (ta, tb) with | (Unit_t, Unit_t) -> return (Eq : (ta comparable_ty, tb comparable_ty) eq) | (Unit_t, _) -> not_equal () | (Never_t, Never_t) -> return Eq @@ -1974,7 +1976,7 @@ let find_entrypoint (type full fullc error_trace) return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _}) -> ( - Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function + Gas_monad.bind_recover (find_entrypoint tl left entrypoint [@coq_type_annotation]) @@ (function [@coq_match_gadt] | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> return (Ex_ty_cstr @@ -1984,11 +1986,11 @@ let find_entrypoint (type full fullc error_trace) original_type_expr; }) | Error () -> - let+ (Ex_ty_cstr {ty; construct; original_type_expr}) = - find_entrypoint tr right entrypoint - in - Ex_ty_cstr - {ty; construct = (fun e -> R (construct e)); original_type_expr}) + let+ x = (find_entrypoint tr right entrypoint [@coq_type_annotation]) in + match x with + | Ex_ty_cstr {ty; construct; original_type_expr} -> + Ex_ty_cstr {ty; construct = (fun e -> R ((construct [@coq_type-annotation]) e)); original_type_expr}) + [@coq_cast]) | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in @@ -2478,7 +2480,9 @@ let[@coq_struct "ty"] rec parse_comparable_data : >>?= fun ctxt -> let legacy = false in - match[@coq_match_gadt_with_result] (ty, script_data) with + match[@coq_match_gadt_with_result] [@coq_match_with_default] + (ty, script_data) + with | (Unit_t, expr) -> Lwt.return @@ traced_no_lwt @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 21aa52c3245bc..b6fad0aec4e9b 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -467,6 +467,7 @@ type ('arg, 'storage) script = field as it has a dynamic size. *) } -> ('arg, 'storage) script +[@@coq_force_gadt] (* ---- Instructions --------------------------------------------------------*) and ('before_top, 'before, 'result_top, 'result) kinstr = @@ -1805,7 +1806,8 @@ let ty_metadata : type a ac. (a, ac) ty -> a ty_metadata = function | Bls12_381_fr_t | Chest_t | Chest_key_t -> meta_basic -let comparable_ty_metadata : type a. a comparable_ty -> a ty_metadata = function +let comparable_ty_metadata : type a. a comparable_ty -> a ty_metadata = + function[@coq_match_with_default] | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t | Tx_rollup_l2_address_t -> @@ -1854,7 +1856,8 @@ let is_comparable : type v c. (v, c) ty -> c dbool = function | Chest_t -> No | Chest_key_t -> No -type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed] +type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c +[@@ocaml.unboxed] [@@coq_force_gadt] let unit_t = Unit_t @@ -2254,7 +2257,7 @@ module Ty_traverse = struct (continue [@ocaml.tailcall]) accu in let return () = (continue [@ocaml.tailcall]) accu in - match ty with + match[@coq_match_with_default] ty with | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t | Key_hash_t | Key_t | Timestamp_t | Address_t | Tx_rollup_l2_address_t | Bool_t | Chain_id_t | Never_t -> diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index cef6f6b90a17b..429d6fe12d8de 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -324,6 +324,7 @@ type ('arg, 'storage) script = code_size : Cache_memory_helpers.sint; } -> ('arg, 'storage) script +[@@coq_force_gadt] (* ---- Instructions --------------------------------------------------------*) @@ -1559,7 +1560,8 @@ val comparable_ty_size : 'a comparable_ty -> 'a Type_size.t val is_comparable : ('v, 'c) ty -> 'c dbool -type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c [@@ocaml.unboxed] +type 'v ty_ex_c = Ty_ex_c : ('v, _) ty -> 'v ty_ex_c +[@@ocaml.unboxed] [@@coq_force_gadt] val unit_key : unit comparable_ty diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index a530e37c3df8f..19259f866beb9 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -45,7 +45,7 @@ module Ty_size = struct let apply_comparable : type a. nodes_and_size -> a comparable_ty -> nodes_and_size = fun accu cty -> - match cty with + match[@coq_match_with_default] cty with | Unit_t -> ret_succ_adding accu base_basic | Int_t -> ret_succ_adding accu base_basic | Nat_t -> ret_succ_adding accu base_basic diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.ml b/src/proto_alpha/lib_protocol/skip_list_repr.ml index 3a5a221d34fc7..6e1a9efce38d7 100644 --- a/src/proto_alpha/lib_protocol/skip_list_repr.ml +++ b/src/proto_alpha/lib_protocol/skip_list_repr.ml @@ -38,7 +38,7 @@ module type S = sig 'content Data_encoding.t -> ('content, 'ptr) cell Data_encoding.t - val index : (_, _) cell -> int + val index : ('content, 'ptr) cell -> int val content : ('content, 'ptr) cell -> 'content @@ -69,9 +69,11 @@ module type S = sig bool end -module Make (Parameters : sig +module type S_Parameters = sig val basis : int -end) : S = struct +end + +module Make (Parameters : S_Parameters) : S = struct let () = assert (Compare.Int.(Parameters.basis >= 2)) open Parameters @@ -170,7 +172,7 @@ end) : S = struct let next ~prev_cell ~prev_cell_ptr content = let index = prev_cell.index + 1 in let back_pointers = - let rec aux power accu i = + let[@coq_struct "power"] rec aux power accu i = if Compare.Int.(index < power) then List.rev accu else let back_pointer_i = @@ -194,7 +196,7 @@ end) : S = struct let best_skip cell target_index = let index = cell.index in - let rec aux idx pow best_idx best_skip = + let[@coq_struct "idx"] rec aux idx pow best_idx best_skip = if Compare.Int.(idx >= FallbackArray.length cell.back_pointers) then best_idx else @@ -209,7 +211,7 @@ end) : S = struct aux 0 1 None None let back_path ~deref ~cell_ptr ~target_index = - let rec aux path ptr = + let[@coq_struct "ptr"] rec aux path ptr = let path = ptr :: path in Option.bind (deref ptr) @@ fun cell -> let index = cell.index in @@ -224,7 +226,7 @@ end) : S = struct let mem equal x l = let open FallbackArray in let n = length l in - let rec aux idx = + let[@coq_struct "idx"] rec aux idx = if Compare.Int.(idx >= n) then false else match FallbackArray.get l idx with @@ -239,7 +241,7 @@ end) : S = struct assume_some (deref target_ptr) @@ fun target -> assume_some (deref cell_ptr) @@ fun cell -> let target_index = index target and cell_index = index cell in - let rec valid_path index cell_ptr path = + let[@coq_struct "path"] rec valid_path index cell_ptr path = match (cell_ptr, path) with | (final_cell, []) -> equal_ptr target_ptr final_cell && Compare.Int.(index = target_index) diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.mli b/src/proto_alpha/lib_protocol/skip_list_repr.mli index 843003e18a151..88c52825bd5ef 100644 --- a/src/proto_alpha/lib_protocol/skip_list_repr.mli +++ b/src/proto_alpha/lib_protocol/skip_list_repr.mli @@ -112,6 +112,8 @@ module type S = sig bool end -module Make (_ : sig +module type S_Parameters = sig val basis : int -end) : S +end + +module Make (_ : S_Parameters) : S diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 4fce49f8e8221..49ad72bacda16 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -108,7 +108,7 @@ module Tenderbake = struct (Raw_level_repr) module First_level_of_protocol = - Make_single_data_storage (Registered) (Raw_context) + Make_single_data_storage (Registered) (Raw_context.M) (struct let name = ["first_level_of_protocol"] end) diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index df7d4e4fdb583..f3c64c590079d 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -166,7 +166,8 @@ let cast_transaction_parameter (type a ac b bc) ctxt location entry_arg_ty parameters_ty) >>?= fun (res, ctxt) -> - res >>?= fun Script_ir_translator.Eq -> return ((parameters : a), ctxt) + res >>?= fun Script_ir_translator.Eq -> + return (((parameters [@coq_cast]) : a), ctxt) let tickets_of_transaction ctxt ~destination ~entrypoint ~location ~parameters_ty ~parameters = @@ -215,7 +216,7 @@ let tickets_of_transaction ctxt ~destination ~entrypoint ~location ~include_lazy:true ctxt has_tickets - parameters + (parameters [@coq_type_annotation]) >>=? fun (tickets, ctxt) -> return (Some {destination = Contract destination; tickets}, ctxt) diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index ccb047487c62f..5c0ed9931a640 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -108,7 +108,7 @@ module Ticket_inspection = struct a Script_typed_ir.comparable_ty -> (a has_tickets -> ret) -> ret = fun key_ty k -> let open Script_typed_ir in - match key_ty with + match[@coq_match_with_default] key_ty with | Unit_t -> (k [@ocaml.tailcall]) False_ht | Never_t -> (k [@ocaml.tailcall]) False_ht | Int_t -> (k [@ocaml.tailcall]) False_ht @@ -273,7 +273,7 @@ module Ticket_collection = struct ret tzresult Lwt.t = fun ctxt comp_ty acc k -> let open Script_typed_ir in - match comp_ty with + match[@coq_match_with_default] comp_ty with | Unit_t -> (k [@ocaml.tailcall]) ctxt acc | Never_t -> (k [@ocaml.tailcall]) ctxt acc | Int_t -> (k [@ocaml.tailcall]) ctxt acc diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml index ae3b050dd6ba7..6cd19e044d9a3 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml @@ -317,6 +317,112 @@ type parameters = { tx_rollup_max_withdrawals_per_batch : int; } +module type S = sig + type ctxt + + type 'a m + + (** The operations are versioned (see {!Tx_rollup_l2_batch}), + so their interpretations are. *) + + module Batch_V1 : sig + open Tx_rollup_l2_batch.V1 + + (** [apply_batch ctxt parameters batch] interprets the batch + {!Tx_rollup_l2_batch.V1.t}. + + By construction, a failing transaction will not affect the [ctxt] + and other transactions will still be interpreted. + That is, this function can only fail because of internals errors. + Otherwise, the errors that caused the transactions to fail can be + observed in the result (see {!Message_result.Batch_V1.t}). + + The counters are incremented when the operation is part of a transaction + that is correctly signed and whose every operations have the expected + counter. In particular, the result of the application is not important + (i.e. the counters are updated even if the transaction failed). + + In addition, the list of withdrawals resulting from each + layer2-to-layer1 transfer message in the batch is returned. + *) + val apply_batch : + ctxt -> + parameters -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.withdrawal list) m + + (** [check_signature ctxt batch] asserts that [batch] is correctly signed. + + We recall that [batch] may contain indexes, that is integers which + replace larger values. The [signer] field of the + {!Tx_rollup_l2_batch.operation} type is concerned. This field is either + the public key to be used to check the signature, or an index. + In case of the public key, [check_signature] will check whether or not + the related {!Tx_rollup_l2_address.t} has already an index assigned, + and allocate one if not. + + Overall, [check_signature] returns the revised context, the list of + newly allocated indexes, and an updated version of the batches where + all [signer] field have been replaced by valid indexes. + + {b Note:} What a user is expected to sign is the version of the + operation it sends to the network. This is potentially unsafe, + because it means the user signs indexes, not addresses nor + ticket hashes. This poses two threats: Tezos reorganization, + and malicious provider of indexes. A Tezos reorganization may + imply that an index allocated to one address in a given branch + is allocated to another address in another branch. We deal with + this issue by making the rollup node aware of the Tezos level at + each time an index is allocated. This allows to implement a RPC that + can safely tell a client to use either the full value or the index, + thanks to Tenderbake finality. To prevent the rollup node to lie, + we will make the rollup node provide Merkle proofs that allows the + client to verify that the index is correct. + *) + val check_signature : + ctxt -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt * indexes * (Indexable.index_only, Indexable.unknown) t) m + end + + (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2 + address in [ctxt]. + + This function can fail if the [deposit.amount] is not strictly-positive. + + If the [deposit] causes an error, then a withdrawal returning + the funds to the deposit's sender is returned. + *) + val apply_deposit : + ctxt -> + Tx_rollup_message.deposit -> + (ctxt + * Message_result.deposit_result + * Tx_rollup_withdraw.withdrawal option) + m + + (** [apply_message ctxt parameters message] interprets the [message] in the + [ctxt]. + + That is, + + {ul {li Deposit tickets if the message is a deposit. } + {li Decodes the batch and interprets it for the + correct batch version. }} + + The function can fail with {!Invalid_batch_encoding} if it's not able + to decode the batch. + + The function can also return errors from subsequent functions, + see {!apply_deposit} and batch interpretations for various versions. + + The list of withdrawals in the message result followed the ordering + of the contents in the message. + *) + val apply_message : + ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m +end + module Make (Context : CONTEXT) = struct open Context open Syntax diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli index 44619b09fe58b..4aaa7ad4c10e1 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli @@ -122,10 +122,10 @@ type parameters = { tx_rollup_max_withdrawals_per_batch : int; } -module Make (Context : CONTEXT) : sig - open Context +module type S = sig + type ctxt - type ctxt = t + type 'a m (** The operations are versioned (see {!Tx_rollup_l2_batch}), so their interpretations are. *) @@ -224,3 +224,6 @@ module Make (Context : CONTEXT) : sig val apply_message : ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m end + +module Make (Context : CONTEXT) : + S with type ctxt = Context.t and type 'a m := 'a Context.m diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml index 5097999488026..67cfdb0ebead1 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml @@ -175,8 +175,7 @@ struct type 'a m = 'a S.m - module Syntax : - Tx_rollup_l2_context_sig.SYNTAX with type t := t and type 'a m := 'a m = + module Syntax : Tx_rollup_l2_context_sig.SYNTAX with type 'a m := 'a m = struct include S.Syntax diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml index 7eb3f4b7aa992..270247f0feaad 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml @@ -162,8 +162,6 @@ type created_existed = Created | Existed (** The necessary monadic operators the storage monad is required to provide. *) module type SYNTAX = sig - type t - type 'a m val ( let+ ) : 'a m -> ('a -> 'b) -> 'b m @@ -202,6 +200,39 @@ module type SYNTAX = sig val fail_when : bool -> error -> unit m end +module type ADDRESS_METADATA = sig + type t + + type 'a m + + (** [get ctxt idx] returns the current metadata associated to the + address indexed by [idx]. *) + val get : t -> address_index -> metadata option m + + (** [incr_counter ctxt idx] increments the counter of the + address indexed by [idx]. + + This function can fail with [Counter_overflow] iff the counter + has reached the [Int64.max_int] limit. + + This function can fail with [Unknown_address_index] if [idx] + has not been associated with a layer-2 address already. *) + val incr_counter : t -> address_index -> t m + + (** [init_with_public_key ctxt idx pk] initializes the metadata + associated to the address indexed by [idx]. + + This can fails with [Metadata_already_initialized] if this + function has already been called with [idx]. *) + val init_with_public_key : t -> address_index -> Bls_signature.pk -> t m + + (**/**) + + module Internal_for_tests : sig + val set : t -> address_index -> metadata -> t m + end +end + (** This module type describes the API of the [Tx_rollup] context, which is used to implement the semantics of the L2 operations. *) module type CONTEXT = sig @@ -222,7 +253,7 @@ module type CONTEXT = sig needs to be inside the monad [m]. *) type 'a m - module Syntax : SYNTAX with type t := t and type 'a m := 'a m + module Syntax : SYNTAX with type 'a m := 'a m (** [bls_aggregate_verify] allows to verify the aggregated signature of a batch. *) @@ -230,34 +261,8 @@ module type CONTEXT = sig (Bls_signature.pk * bytes) list -> Bls_signature.signature -> bool m (** The metadata associated to an address. *) - module Address_metadata : sig - (** [get ctxt idx] returns the current metadata associated to the - address indexed by [idx]. *) - val get : t -> address_index -> metadata option m - - (** [incr_counter ctxt idx] increments the counter of the - address indexed by [idx]. - - This function can fail with [Counter_overflow] iff the counter - has reached the [Int64.max_int] limit. - - This function can fail with [Unknown_address_index] if [idx] - has not been associated with a layer-2 address already. *) - val incr_counter : t -> address_index -> t m - - (** [init_with_public_key ctxt idx pk] initializes the metadata - associated to the address indexed by [idx]. - - This can fails with [Metadata_already_initialized] if this - function has already been called with [idx]. *) - val init_with_public_key : t -> address_index -> Bls_signature.pk -> t m - - (**/**) - - module Internal_for_tests : sig - val set : t -> address_index -> metadata -> t m - end - end + module Address_metadata : + ADDRESS_METADATA with type t := t and type 'a m := 'a m (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}. diff --git a/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml b/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml index 7c93e0a7f75e9..5832a20262b31 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml @@ -35,8 +35,10 @@ let get_deposit_parameters : (a, comparable) Script_typed_ir.ty -> a -> deposit_parameters tzresult = fun ty contents -> let open Script_typed_ir in - match (ty, contents) with + match[@coq_match_gadt] (ty, contents) with | ( Pair_t (Ticket_t (ty, _), Tx_rollup_l2_address_t, _, _), - (ticket, l2_destination) ) -> + (contents : + _ Script_typed_ir.ticket * Script_typed_ir.tx_rollup_l2_address) ) -> + let (ticket, l2_destination) = contents in ok {ex_ticket = Ticket_scanner.Ex_ticket (ty, ticket); l2_destination} | _ -> error Alpha_context.Tx_rollup_errors.Wrong_deposit_parameters diff --git a/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml index d7a7409c6f5ad..2c3b8f2265ddc 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_state_repr.ml @@ -430,7 +430,7 @@ let update_burn_per_byte_helper : be the maximum amount. *) | Error _ -> {state with burn_per_byte = Tez_repr.max_mutez; inbox_ema} -let rec update_burn_per_byte : +let[@coq_struct "elapsed"] rec update_burn_per_byte : t -> elapsed:int -> factor:int -> final_size:int -> hard_limit:int -> t = fun state ~elapsed ~factor ~final_size ~hard_limit -> (* factor is expected to be a low number ~ 100 *) -- GitLab From 489b71658085f15d59c80cf816223a4558b9cdda Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 5 Apr 2022 19:35:11 +0200 Subject: [PATCH 068/105] Proto: formatting --- .../lib_protocol/script_ir_translator.ml | 23 +++++++++++++------ 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 3199c53ed403b..e232c60027e99 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1976,7 +1976,9 @@ let find_entrypoint (type full fullc error_trace) return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _}) -> ( - Gas_monad.bind_recover (find_entrypoint tl left entrypoint [@coq_type_annotation]) @@ (function [@coq_match_gadt] + Gas_monad.bind_recover + (find_entrypoint tl left entrypoint [@coq_type_annotation]) + @@ function[@coq_match_gadt] [@coq_cast] | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> return (Ex_ty_cstr @@ -1985,12 +1987,19 @@ let find_entrypoint (type full fullc error_trace) construct = (fun e -> L (construct e)); original_type_expr; }) - | Error () -> - let+ x = (find_entrypoint tr right entrypoint [@coq_type_annotation]) in - match x with - | Ex_ty_cstr {ty; construct; original_type_expr} -> - Ex_ty_cstr {ty; construct = (fun e -> R ((construct [@coq_type-annotation]) e)); original_type_expr}) - [@coq_cast]) + | Error () -> ( + let+ x = + (find_entrypoint tr right entrypoint [@coq_type_annotation]) + in + match x with + | Ex_ty_cstr {ty; construct; original_type_expr} -> + Ex_ty_cstr + { + ty; + construct = + (fun e -> R ((construct [@coq_type -annotation]) e)); + original_type_expr; + })) | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in -- GitLab From 2e81d791accc4386a9c82e832078a4ec28400f94 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 7 Apr 2022 19:23:37 +0200 Subject: [PATCH 069/105] Proto: more changes to help coq-of-ocaml --- .../lib_protocol/alpha_context.mli | 23 +++++++++------ src/proto_alpha/lib_protocol/apply.ml | 10 +++---- .../lib_protocol/script_ir_translator.ml | 2 +- .../lib_protocol/script_typed_ir_size.ml | 6 ++-- src/proto_alpha/lib_protocol/storage.ml | 4 +-- .../integration/operations/test_tx_rollup.ml | 16 +++++------ .../lib_protocol/tx_rollup_commitment_repr.ml | 8 +++++- .../tx_rollup_commitment_repr.mli | 2 +- .../tx_rollup_commitment_storage.ml | 20 +++++++------ .../tx_rollup_commitment_storage.mli | 7 +++-- .../lib_protocol/tx_rollup_errors_repr.ml | 28 +++++++++++-------- src/proto_alpha/lib_protocol/tx_rollup_gas.ml | 4 +-- .../lib_protocol/tx_rollup_l2_apply.ml | 7 ++--- 13 files changed, 80 insertions(+), 57 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index baef949694131..0251cac021fdb 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1677,7 +1677,7 @@ module Tx_rollup_withdraw : sig end module Tx_rollup_withdraw_list_hash : sig - include S.HASH + include S.HASH with type t = Tx_rollup_withdraw_list_hash_repr.t val hash_uncarbonated : Tx_rollup_withdraw.t list -> t @@ -1961,11 +1961,14 @@ module Tx_rollup_commitment : sig val compact : t -> Compact.t end + type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + val check_message_result : context -> Compact.t -> - [ `Hash of Tx_rollup_message_result_hash.t - | `Result of Tx_rollup_message_result.t ] -> + hash_or_result -> path:Merkle.path -> index:int -> context tzresult @@ -2074,6 +2077,12 @@ module Tx_rollup_hash : sig end module Tx_rollup_errors : sig + type error_or_commitment = Inbox | Commitment + + type valid_path_or_hash = + | Valid_path of Tx_rollup_commitment.Merkle.h * int + | Hash of Tx_rollup_message_result_hash.t + type error += | Tx_rollup_already_exists of Tx_rollup.t | Tx_rollup_does_not_exist of Tx_rollup.t @@ -2110,7 +2119,7 @@ module Tx_rollup_errors : sig length : int; } | Wrong_path_depth of { - kind : [`Inbox | `Commitment]; + kind : error_or_commitment; provided : int; limit : int; } @@ -2129,9 +2138,7 @@ module Tx_rollup_errors : sig } | Wrong_rejection_hash of { provided : Tx_rollup_message_result_hash.t; - expected : - [ `Valid_path of Tx_rollup_commitment.Merkle.h * int - | `Hash of Tx_rollup_message_result_hash.t ]; + expected : valid_path_or_hash; } | Wrong_deposit_parameters | Proof_failed_to_reject @@ -2143,7 +2150,7 @@ module Tx_rollup_errors : sig | No_withdrawals_to_dispatch val check_path_depth : - [`Inbox | `Commitment] -> int -> count_limit:int -> unit tzresult + error_or_commitment -> int -> count_limit:int -> unit tzresult end module Bond_id : sig diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 6eee58ac848f8..ce300ff60a9a1 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -1340,7 +1340,7 @@ let[@coq_axiom_with_reason "unresolved implicit type"] apply_external_manager_op Tx_rollup_commitment.check_message_result ctxt commitment.commitment - (`Result {context_hash; withdraw_list_hash}) + (Result {context_hash; withdraw_list_hash}) ~path:message_result_path ~index:message_index >>?= fun ctxt -> @@ -1928,7 +1928,7 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) Constants.parametric ctxt in Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth message_result_path) ~count_limit:tx_rollup_max_messages_per_inbox >>?= fun () -> @@ -1962,17 +1962,17 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) Constants.parametric ctxt in Tx_rollup_errors.check_path_depth - `Inbox + Inbox (Tx_rollup_inbox.Merkle.path_depth message_path) ~count_limit:tx_rollup_max_messages_per_inbox >>?= fun () -> Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth message_result_path) ~count_limit:tx_rollup_max_messages_per_inbox >>?= fun () -> Tx_rollup_errors.check_path_depth - `Commitment + Commitment (Tx_rollup_commitment.Merkle.path_depth previous_message_result_path) ~count_limit:tx_rollup_max_messages_per_inbox >>?= fun () -> return ctxt diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index e232c60027e99..83814322c2bf7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1997,7 +1997,7 @@ let find_entrypoint (type full fullc error_trace) { ty; construct = - (fun e -> R ((construct [@coq_type -annotation]) e)); + (fun e -> R ((construct [@coq_type_annotation]) e)); original_type_expr; })) | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 19259f866beb9..a9a51a40e717b 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -276,11 +276,13 @@ let[@coq_struct "ty"] rec value_size_aux : | (List_t (_, _), (x : _ boxed_list)) -> ret_succ_adding accu (h2w +! (h2w *? x.length)) | (Set_t (_, _), (x : _ set)) -> - let module M = (val Script_set.get x) in + let set = Script_set.get x in + let module M = (val set) in let boxing_space = !!536 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h4w *? M.size)) | (Map_t (_, _, _), (x : _ map)) -> - let module M = (val Script_map.get_module x) in + let map = Script_map.get_module x in + let module M = (val map) in let boxing_space = !!696 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h5w *? M.size)) | (Big_map_t (cty, ty', _), (x : _ big_map)) -> diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 49ad72bacda16..41eb6142b53e6 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1388,7 +1388,7 @@ module Ticket_balance = struct let name = ["ticket_balance"] end - module Raw_context = Make_subcontext (Registered) (Raw_context) (Name) + module Raw_context = Make_subcontext (Registered) (Raw_context.M) (Name) module Paid_storage_space = Make_single_data_storage (Registered) (Raw_context) @@ -1418,7 +1418,7 @@ end module Tx_rollup = struct module Indexed_context = Make_indexed_subcontext - (Make_subcontext (Registered) (Raw_context) + (Make_subcontext (Registered) (Raw_context.M) (struct let name = ["tx_rollup"] end)) diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml index 505cf75c7b6f5..45e92ceb02601 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_tx_rollup.ml @@ -2814,7 +2814,7 @@ module Rejection = struct Tx_rollup_message_result_hash.hash_uncarbonated previous_message_result; expected = - `Hash + Hash (Tx_rollup_message_result_hash.of_b58check_exn "txmr344vtdPzvWsfnoSd3mJ3MCFA5ehKLQs1pK9WGcX4FEACg1rVgC"); })) @@ -4247,7 +4247,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4268,7 +4268,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4310,7 +4310,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4331,7 +4331,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, 0)} -> + {provided = _; expected = Valid_path (_, 0)} -> true | _ -> false) incr @@ -4609,7 +4609,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, idx)} -> + {provided = _; expected = Valid_path (_, idx)} -> Compare.Int.(idx = valid_message_index) | _ -> false) incr @@ -4630,7 +4630,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, idx)} -> + {provided = _; expected = Valid_path (_, idx)} -> Compare.Int.(idx = wrong_message_index) | _ -> false) incr @@ -4653,7 +4653,7 @@ module Withdraw = struct ~expect_failure: (check_proto_error_f @@ function | Tx_rollup_errors.Wrong_rejection_hash - {provided = _; expected = `Valid_path (_, idx)} -> + {provided = _; expected = Valid_path (_, idx)} -> Compare.Int.(idx = wrong_message_index) | _ -> false) incr diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml index 6de7e88e16950..3d8da9c0aaed5 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.ml @@ -94,7 +94,13 @@ type 'a template = { inbox_merkle_root : Tx_rollup_inbox_repr.Merkle.root; } -let map_template f x = {x with messages = f x.messages} +let map_template f x = + { + level = x.level; + messages = f x.messages; + predecessor = x.predecessor; + inbox_merkle_root = x.inbox_merkle_root; + } let pp_template : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a template -> unit diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli index 8a396f24d3986..277059cb20e75 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_repr.mli @@ -33,7 +33,7 @@ module Hash : sig include S.HASH end -module Merkle_hash : S.HASH +module Merkle_hash : S.HASH [@@coq_plain_module] module Merkle : Merkle_list.T diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml index 133814b41d99c..bb0e2e45bb4a1 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.ml @@ -50,10 +50,14 @@ open Tx_rollup_errors_repr *) +type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + let check_message_result ctxt {messages; _} result ~path ~index = (match result with - | `Hash hash -> ok (ctxt, hash) - | `Result result -> Tx_rollup_hash_builder.message_result ctxt result) + | Hash hash -> ok (ctxt, hash) + | Result result -> Tx_rollup_hash_builder.message_result ctxt result) >>? fun (ctxt, computed) -> Tx_rollup_gas.consume_check_path_commitment_cost ctxt >>? fun ctxt -> let cond = @@ -71,7 +75,7 @@ let check_message_result ctxt {messages; _} result ~path ~index = cond Tx_rollup_errors_repr.( Wrong_rejection_hash - {provided = computed; expected = `Valid_path (messages.root, index)}) + {provided = computed; expected = Valid_path (messages.root, index)}) >>? fun () -> ok ctxt type direction = Incr | Decr @@ -352,7 +356,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state check_message_result ctxt commitment - (`Hash disputed_result) + (Hash disputed_result) ~path:disputed_result_path ~index:disputed_position >>?= fun ctxt -> @@ -364,7 +368,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state let expected = Tx_rollup_message_result_hash_repr.init in fail_unless Tx_rollup_message_result_hash_repr.(agreed = expected) - (Wrong_rejection_hash {provided = agreed; expected = `Hash expected}) + (Wrong_rejection_hash {provided = agreed; expected = Hash expected}) >>=? fun () -> return ctxt | Some pred_level -> ( Storage.Tx_rollup.Commitment.find (ctxt, tx_rollup) pred_level @@ -377,7 +381,7 @@ let check_agreed_and_disputed_results ctxt tx_rollup state fail_unless Tx_rollup_message_result_hash_repr.(agreed = expected) (Wrong_rejection_hash - {provided = agreed; expected = `Hash expected}) + {provided = agreed; expected = Hash expected}) >>=? fun () -> return ctxt | None -> ( match Tx_rollup_state_repr.last_removed_commitment_hashes state with @@ -385,14 +389,14 @@ let check_agreed_and_disputed_results ctxt tx_rollup state fail_unless Tx_rollup_message_result_hash_repr.(agreed = last_hash) (Wrong_rejection_hash - {provided = agreed; expected = `Hash last_hash}) + {provided = agreed; expected = Hash last_hash}) >>=? fun () -> return ctxt | None -> fail (Internal_error "Missing commitment predecessor"))) else check_message_result ctxt commitment - (`Result agreed_result) + (Result agreed_result) ~path:agreed_result_path ~index:(disputed_position - 1) >>?= fun ctxt -> return ctxt diff --git a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.mli b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.mli index d273649533974..e588c662a69a2 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_commitment_storage.mli @@ -28,11 +28,14 @@ (** This module introduces various functions to manipulate the storage related to commitments for transaction rollups. *) +type hash_or_result = + | Hash of Tx_rollup_message_result_hash_repr.t + | Result of Tx_rollup_message_result_repr.t + val check_message_result : Raw_context.t -> Tx_rollup_commitment_repr.Compact.t -> - [ `Hash of Tx_rollup_message_result_hash_repr.t - | `Result of Tx_rollup_message_result_repr.t ] -> + hash_or_result -> path:Tx_rollup_commitment_repr.Merkle.path -> index:int -> Raw_context.t tzresult diff --git a/src/proto_alpha/lib_protocol/tx_rollup_errors_repr.ml b/src/proto_alpha/lib_protocol/tx_rollup_errors_repr.ml index 274c7924180d9..8dd6557057897 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_errors_repr.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_errors_repr.ml @@ -25,6 +25,12 @@ (* *) (*****************************************************************************) +type error_or_commitment = Inbox | Commitment + +type valid_path_or_hash = + | Valid_path of Tx_rollup_commitment_repr.Merkle.h * int + | Hash of Tx_rollup_message_result_hash_repr.t + type error += | Tx_rollup_already_exists of Tx_rollup_repr.t | Tx_rollup_does_not_exist of Tx_rollup_repr.t @@ -60,7 +66,7 @@ type error += length : int; } | Wrong_path_depth of { - kind : [`Inbox | `Commitment]; + kind : error_or_commitment; provided : int; limit : int; } @@ -81,9 +87,7 @@ type error += } | Wrong_rejection_hash of { provided : Tx_rollup_message_result_hash_repr.t; - expected : - [ `Valid_path of Tx_rollup_commitment_repr.Merkle.h * int - | `Hash of Tx_rollup_message_result_hash_repr.t ]; + expected : valid_path_or_hash; } | Ticket_payload_size_limit_exceeded of {payload_size : int; limit : int} | Wrong_deposit_parameters @@ -401,14 +405,14 @@ let () = (Tag 0) ~title:"Inbox" (constant "inbox") - (function `Inbox -> Some () | _ -> None) - (fun () -> `Inbox); + (function Inbox -> Some () | _ -> None) + (fun () -> Inbox); case (Tag 1) ~title:"Commitment" (constant "commitment") - (function `Commitment -> Some () | _ -> None) - (fun () -> `Commitment); + (function Commitment -> Some () | _ -> None) + (fun () -> Commitment); ])) (req "provided" int31) (req "limit" int31)) @@ -583,16 +587,16 @@ let () = (Tag 0) ~title:"hash" Tx_rollup_message_result_hash_repr.encoding - (function `Hash h -> Some h | _ -> None) - (fun h -> `Hash h); + (function Hash h -> Some h | _ -> None) + (fun h -> Hash h); case (Tag 1) ~title:"valid_path" (obj2 (req "root" Tx_rollup_commitment_repr.Merkle_hash.encoding) (req "index" int31)) - (function `Valid_path (h, i) -> Some (h, i) | _ -> None) - (fun (h, i) -> `Valid_path (h, i)); + (function Valid_path (h, i) -> Some (h, i) | _ -> None) + (fun (h, i) -> Valid_path (h, i)); ]))) (function | Wrong_rejection_hash {provided; expected} -> Some (provided, expected) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_gas.ml b/src/proto_alpha/lib_protocol/tx_rollup_gas.ml index afc2ff63478e8..9dfab50e807a3 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_gas.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_gas.ml @@ -53,7 +53,7 @@ let check_path_cost element_size path_depth = hash_cost element_size >>? fun element_hash_cost -> (* At each step of the way, we hash 2 hashes together *) hash_cost 64 >>? fun hash_cost -> - let rec acc_hash_cost acc i = + let[@coq_struct "i_value"] rec acc_hash_cost acc i = if Compare.Int.(i <= 0) then acc else acc_hash_cost (hash_cost + acc) (i - 1) in @@ -80,7 +80,7 @@ let snoc_cost element_size max_depth = (* We consider an over-approximation where the tree is already at it maximum height *) hash_cost 64 >>? fun hash_cost -> - let rec acc_hash_cost acc i = + let[@coq_struct "i_value"] rec acc_hash_cost acc i = if Compare.Int.(i <= 0) then acc else acc_hash_cost (hash_cost + acc) (i - 1) in diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml index 6cd19e044d9a3..f4b9d0d91bb9a 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml @@ -349,7 +349,7 @@ module type S = sig ctxt -> parameters -> (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.withdrawal list) m + (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m (** [check_signature ctxt batch] asserts that [batch] is correctly signed. @@ -396,10 +396,7 @@ module type S = sig val apply_deposit : ctxt -> Tx_rollup_message.deposit -> - (ctxt - * Message_result.deposit_result - * Tx_rollup_withdraw.withdrawal option) - m + (ctxt * Message_result.deposit_result * Tx_rollup_withdraw.t option) m (** [apply_message ctxt parameters message] interprets the [message] in the [ctxt]. -- GitLab From dae985d7f298dda5470ea8af7aa550473d6e26b7 Mon Sep 17 00:00:00 2001 From: Daniel Hilst Selli Date: Fri, 8 Apr 2022 14:41:21 -0300 Subject: [PATCH 070/105] Proto : more changes for coq-of-ocaml --- src/proto_alpha/lib_protocol/storage.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 41eb6142b53e6..b9b48d1b1d37e 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1411,8 +1411,13 @@ module Ticket_balance = struct end) module Index = Make_index (Ticket_hash_repr.Index) - module Table = - Make_indexed_carbonated_data_storage (Table_context) (Index) (Encoding.Z) + module Table : + Non_iterable_indexed_carbonated_data_storage + with type t := Raw_context.t + and type key = Ticket_hash_repr.t + and type value = Z.t = + Make_indexed_carbonated_data_storage (Table_context) (Index) + (Encoding.Z) end module Tx_rollup = struct -- GitLab From 49d4e63bd8ab336bc7b74b812c9d23f4b9c4372c Mon Sep 17 00:00:00 2001 From: Daniel Hilst Selli Date: Fri, 8 Apr 2022 21:13:03 -0300 Subject: [PATCH 071/105] Proto : Fixes for coq-of-ocaml in merkle_list.ml --- src/proto_alpha/lib_protocol/merkle_list.ml | 53 +++++++++++---------- 1 file changed, 27 insertions(+), 26 deletions(-) diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml index c7bb2ad328802..1853932921d15 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.ml +++ b/src/proto_alpha/lib_protocol/merkle_list.ml @@ -81,9 +81,9 @@ module type T = sig module Internal_for_tests : sig val path_to_list : path -> h list - + val equal : t -> t -> bool - + val to_list : t -> h list end end @@ -147,7 +147,7 @@ struct let empty = H.zero - let root = function Empty -> empty | Leaf h -> h | Node (h, _, _) -> h + let root_aux = function Empty -> empty | Leaf h -> h | Node (h, _, _) -> h let nil = {tree = Empty; depth = 0; next_pos = 0} @@ -157,7 +157,7 @@ struct let hash2 h1 h2 = H.(hash_bytes [to_bytes h1; to_bytes h2]) - let node_of t1 t2 = Node (hash2 (root t1) (root t2), t1, t2) + let node_of t1 t2 = Node (hash2 (root_aux t1) (root_aux t2), t1, t2) (* to_bin computes the [depth]-long binary representation of [pos] (left-padding with 0s if required). This corresponds to the tree traversal @@ -172,7 +172,7 @@ struct | 0 -> acc | d -> aux (Compare.Int.(dir = 1) :: acc) pos' (d - 1) in - aux [] pos depth + aux List.nil pos depth (* Constructs a tree of a given depth in which every right subtree is empty * and the only leaf contains the hash of el. *) @@ -211,13 +211,15 @@ struct let (tree', depth') = match (t.tree, t.depth, t.next_pos) with | (Empty, 0, 0) -> (node_of (leaf_of el) Empty, 1) - | (tree, depth, pos) when Int32.(equal (shift_left 1l depth) (of_int pos)) + | (tree, depth, pos) -> - let t_right = make_spine_with el depth in - (node_of tree t_right, depth + 1) - | (tree, depth, pos) -> - let key = to_bin ~pos ~depth in - (traverse tree depth key, depth) + if Int32.(equal (shift_left 1l depth) (of_int pos)) + then + let t_right = make_spine_with el depth in + (node_of tree t_right, depth + 1) + else + let key = to_bin ~pos ~depth in + (traverse tree depth key, depth) in {tree = tree'; depth = depth'; next_pos = t.next_pos + 1} @@ -250,18 +252,19 @@ struct let (tree', depth') = match (t.tree, t.depth, t.next_pos) with | (Empty, 0, 0) -> (node_of (leaf_of el) Empty, 1) - | (tree, depth, pos) when Int32.(equal (shift_left 1l depth) (of_int pos)) - -> - let t_right = make_spine_with el depth in - (node_of tree t_right, depth + 1) | (tree, depth, pos) -> - let key = to_bin ~pos ~depth in - (traverse Top tree depth key, depth) + if Int32.(equal (shift_left 1l depth) (of_int pos)) + then + let t_right = make_spine_with el depth in + (node_of tree t_right, depth + 1) + else + let key = to_bin ~pos ~depth in + (traverse Top tree depth key, depth) in {tree = tree'; depth = depth'; next_pos = t.next_pos + 1} let rec tree_to_list = function - | Empty -> [] + | Empty -> List.nil | Leaf h -> [h] | Node (_, t_left, t_right) -> tree_to_list t_left @ tree_to_list t_right @@ -282,10 +285,10 @@ struct match (tree, key) with | (Leaf _, []) -> ok acc | (Node (_, l, r), b :: key) -> - if b then aux (root l :: acc) r key else aux (root r :: acc) l key + if b then aux (root_aux l :: acc) r key else aux (root_aux r :: acc) l key | _ -> error Merkle_list_invalid_position in - aux [] tree key + aux List.nil tree key let check_path path pos el expected_root = let depth = List.length path in @@ -307,17 +310,15 @@ struct let path_depth path = List.length path let compute l = - let rec aux l = + let[@coq_struct "l_value"] rec aux l = let rec pairs acc = function | [] -> List.rev acc | [x] -> List.rev (hash2 x empty :: acc) - | x :: y :: xs -> pairs (hash2 x y :: acc) xs - in - match pairs [] l with [] -> empty | [h] -> h | pl -> aux pl - in + | x :: y :: xs -> pairs (hash2 x y :: acc) xs in + match pairs List.nil l with [] -> empty | [h] -> h | pl -> aux pl in aux (List.map hash_elt l) - let root t = root t.tree + let root t = root_aux t.tree module Internal_for_tests = struct let path_to_list x = x -- GitLab From e7b4dc39d10bfcdcdb26b2d85aabf3c1e25097b1 Mon Sep 17 00:00:00 2001 From: Daniel Hilst Date: Mon, 11 Apr 2022 17:11:55 -0300 Subject: [PATCH 072/105] Proto: Fixes in apply_results.ml for coq-of-ocaml --- src/proto_alpha/lib_protocol/apply_results.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index b6e3f22f3b908..c60339933ab17 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -830,7 +830,7 @@ module Manager_result = struct | Successful_manager_result (Transfer_ticket_result _ as op) -> Some op | _ -> None) ~kind:Kind.Transfer_ticket_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Transfer_ticket_result {balance_updates; consumed_gas; paid_storage_size_diff} -> ( balance_updates, -- GitLab From de63e662a8fcae79dbc8ff58d1a81b863f7860df Mon Sep 17 00:00:00 2001 From: Daniel Hilst Date: Tue, 12 Apr 2022 13:04:39 -0300 Subject: [PATCH 073/105] Proto : script_ir_translator, fixes for coq-of-ocaml --- .../lib_protocol/script_ir_translator.ml | 26 ++++++++++++------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 83814322c2bf7..8948ec6a90221 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1991,7 +1991,7 @@ let find_entrypoint (type full fullc error_trace) let+ x = (find_entrypoint tr right entrypoint [@coq_type_annotation]) in - match x with + match[@coq_match_gadt]x with | Ex_ty_cstr {ty; construct; original_type_expr} -> Ex_ty_cstr { @@ -1999,7 +1999,7 @@ let find_entrypoint (type full fullc error_trace) construct = (fun e -> R ((construct [@coq_type_annotation]) e)); original_type_expr; - })) + }))[@coq_cast] | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in @@ -5623,7 +5623,7 @@ type typechecked_code_internal = } -> typechecked_code_internal -let typecheck_code : +let typecheck_code_inner : legacy:bool -> show_types:bool -> context -> @@ -5971,7 +5971,7 @@ and[@coq_mutual_as_notation] unparse_items : ([], ctxt) items -and[@coq_struct "ctxt"] unparse_code_aux ctxt ~stack_depth mode code = +and[@coq_struct "ctxt"] unparse_code_aux (ctxt : context) ~(stack_depth : int) (mode : unparsing_mode) (code : Script.node) : (node * context, error trace) result Lwt.t = let legacy = true in Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> let non_terminal_recursion ctxt mode code = @@ -6026,14 +6026,22 @@ and[@coq_struct "ctxt"] unparse_code_aux ctxt ~stack_depth mode code = return (Prim (loc, prim, List.rev items, annot), ctxt) | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt) -let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage - mode ~normalize_types {code; storage} = +let parse_and_unparse_script_unaccounted + : context -> + legacy:bool -> + allow_forged_in_storage:bool -> + unparsing_mode -> + normalize_types:bool -> + Script.t -> + (Script.t * context) tzresult Lwt.t + = fun ctxt ~legacy ~allow_forged_in_storage + mode ~normalize_types {code; storage} -> Script.force_decode_in_context ~consume_deserialization_gas:When_needed ctxt code >>?= fun (code, ctxt) -> - typecheck_code ~legacy ~show_types:false ctxt code + typecheck_code_inner ~legacy ~show_types:false ctxt code >>=? fun ( Typechecked_code_internal { toplevel = @@ -6049,7 +6057,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage type_map = _; }, ctxt ) -> - parse_storage + (parse_storage [@coq_implicit "storage" "a"]) ctxt ~legacy ~allow_forged:allow_forged_in_storage @@ -6733,5 +6741,5 @@ let script_size (Saturation_repr.(add code_size storage_size |> to_int), cost) let typecheck_code ~legacy ~show_types ctxt code = - typecheck_code ~legacy ~show_types ctxt code + typecheck_code_inner ~legacy ~show_types ctxt code >|=? fun (Typechecked_code_internal {type_map; _}, ctxt) -> (type_map, ctxt) -- GitLab From 20949b07d656330eedf1f549e157bfa57629e2d7 Mon Sep 17 00:00:00 2001 From: Daniel Hilst Date: Tue, 12 Apr 2022 17:48:40 -0300 Subject: [PATCH 074/105] Proto : Fix tx_rollup_ticket.ml translation, add annotation to alpha_context.mli to achieve that --- src/proto_alpha/lib_protocol/alpha_context.mli | 1 + src/proto_alpha/lib_protocol/tx_rollup_ticket.ml | 7 ++++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 0251cac021fdb..1666e75899afc 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1675,6 +1675,7 @@ module Tx_rollup_withdraw : sig val encoding : t Data_encoding.t end +[@@coq_plain_module] module Tx_rollup_withdraw_list_hash : sig include S.HASH with type t = Tx_rollup_withdraw_list_hash_repr.t diff --git a/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml b/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml index 066549e158d09..a04e8a8eb4470 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml @@ -32,7 +32,7 @@ let parse_ticket ~consume_deserialization_gas ~ticketer ~contents ~ty ctxt = >>?= fun (contents, ctxt) -> Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) >>?= fun (Ex_comparable_ty contents_type, ctxt) -> - Script_ir_translator.parse_comparable_data + (Script_ir_translator.parse_comparable_data [@coq_implicit "a" "a"]) ctxt contents_type (Micheline.root contents) @@ -47,7 +47,7 @@ let parse_ticket_and_operation ~consume_deserialization_gas ~ticketer ~contents >>?= fun (contents, ctxt) -> Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) >>?= fun (Ex_comparable_ty contents_type, ctxt) -> - Script_ir_translator.parse_comparable_data + (Script_ir_translator.parse_comparable_data [@coq_implicit "a" "a"]) ctxt contents_type (Micheline.root contents) @@ -92,7 +92,8 @@ let parse_ticket_and_operation ~consume_deserialization_gas ~ticketer ~contents in return (ctxt, ticket_token, op) -let make_withdraw_order ctxt tx_rollup ex_ticket claimer amount = +let make_withdraw_order + = fun ctxt tx_rollup ex_ticket claimer amount -> Ticket_balance_key.of_ex_token ctxt ~owner:(Tx_rollup tx_rollup) ex_ticket >>=? fun (tx_rollup_ticket_hash, ctxt) -> let withdrawal = -- GitLab From 074e9bc0d982b4ba28a40707405048644171f6b6 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 15 Apr 2022 22:53:56 +0200 Subject: [PATCH 075/105] Proto: formatting --- src/proto_alpha/lib_protocol/merkle_list.ml | 22 +++++++++---------- src/proto_alpha/lib_protocol/storage.ml | 4 ++-- .../lib_protocol/tx_rollup_ticket.ml | 3 +-- 3 files changed, 14 insertions(+), 15 deletions(-) diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml index 1853932921d15..41aff5ffbea7f 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.ml +++ b/src/proto_alpha/lib_protocol/merkle_list.ml @@ -81,9 +81,9 @@ module type T = sig module Internal_for_tests : sig val path_to_list : path -> h list - + val equal : t -> t -> bool - + val to_list : t -> h list end end @@ -211,10 +211,8 @@ struct let (tree', depth') = match (t.tree, t.depth, t.next_pos) with | (Empty, 0, 0) -> (node_of (leaf_of el) Empty, 1) - | (tree, depth, pos) - -> - if Int32.(equal (shift_left 1l depth) (of_int pos)) - then + | (tree, depth, pos) -> + if Int32.(equal (shift_left 1l depth) (of_int pos)) then let t_right = make_spine_with el depth in (node_of tree t_right, depth + 1) else @@ -253,8 +251,7 @@ struct match (t.tree, t.depth, t.next_pos) with | (Empty, 0, 0) -> (node_of (leaf_of el) Empty, 1) | (tree, depth, pos) -> - if Int32.(equal (shift_left 1l depth) (of_int pos)) - then + if Int32.(equal (shift_left 1l depth) (of_int pos)) then let t_right = make_spine_with el depth in (node_of tree t_right, depth + 1) else @@ -285,7 +282,8 @@ struct match (tree, key) with | (Leaf _, []) -> ok acc | (Node (_, l, r), b :: key) -> - if b then aux (root_aux l :: acc) r key else aux (root_aux r :: acc) l key + if b then aux (root_aux l :: acc) r key + else aux (root_aux r :: acc) l key | _ -> error Merkle_list_invalid_position in aux List.nil tree key @@ -314,8 +312,10 @@ struct let rec pairs acc = function | [] -> List.rev acc | [x] -> List.rev (hash2 x empty :: acc) - | x :: y :: xs -> pairs (hash2 x y :: acc) xs in - match pairs List.nil l with [] -> empty | [h] -> h | pl -> aux pl in + | x :: y :: xs -> pairs (hash2 x y :: acc) xs + in + match pairs List.nil l with [] -> empty | [h] -> h | pl -> aux pl + in aux (List.map hash_elt l) let root t = root_aux t.tree diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index b9b48d1b1d37e..d808bd6172056 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1411,13 +1411,13 @@ module Ticket_balance = struct end) module Index = Make_index (Ticket_hash_repr.Index) + module Table : Non_iterable_indexed_carbonated_data_storage with type t := Raw_context.t and type key = Ticket_hash_repr.t and type value = Z.t = - Make_indexed_carbonated_data_storage (Table_context) (Index) - (Encoding.Z) + Make_indexed_carbonated_data_storage (Table_context) (Index) (Encoding.Z) end module Tx_rollup = struct diff --git a/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml b/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml index a04e8a8eb4470..17fd5f70fe161 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml @@ -92,8 +92,7 @@ let parse_ticket_and_operation ~consume_deserialization_gas ~ticketer ~contents in return (ctxt, ticket_token, op) -let make_withdraw_order - = fun ctxt tx_rollup ex_ticket claimer amount -> +let make_withdraw_order ctxt tx_rollup ex_ticket claimer amount = Ticket_balance_key.of_ex_token ctxt ~owner:(Tx_rollup tx_rollup) ex_ticket >>=? fun (tx_rollup_ticket_hash, ctxt) -> let withdrawal = -- GitLab From eda41dd08cec4ad605ca739d21f90885a84b44ad Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Fri, 15 Apr 2022 23:05:16 +0200 Subject: [PATCH 076/105] Proto: make the interpreter evaluate in Coq --- src/proto_alpha/lib_protocol/script_interpreter.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index e0758b8a87191..a291f1733d3a7 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -490,9 +490,9 @@ and[@coq_struct "gas"] iexec : let ks = KReturn (stack, KCons (k, ks)) in (step [@ocaml.tailcall]) g gas code ks arg (EmptyCell, EmptyCell) -and[@coq_struct "function_parameter"] step : - type a s b t r f. (a, s, b, t, r, f) step_type = - fun ((ctxt, sc) as g) gas i ks accu stack -> +and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = + fun g gas i ks accu stack -> + let (ctxt, sc) = g in match consume_instr gas i accu stack with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( -- GitLab From 69693e4d4e17b588324fe8d49b9cddc1b9d1806b Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 20 Apr 2022 15:49:21 +0200 Subject: [PATCH 077/105] Proto: split very long strings for Coq --- .../lib_protocol/legacy_script_patches_for_J.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/legacy_script_patches_for_J.ml b/src/proto_alpha/lib_protocol/legacy_script_patches_for_J.ml index e7355d3ebfc9b..d5b8622266025 100644 --- a/src/proto_alpha/lib_protocol/legacy_script_patches_for_J.ml +++ b/src/proto_alpha/lib_protocol/legacy_script_patches_for_J.ml @@ -162,7 +162,9 @@ let expru1ukk6ZqdA32rFYFG7j1eGjfsatbdUZWz8Mi1kXWZYRZm4FZVe = ]; patched_code = bin_expr_exn - "0200002f0405000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c05020200002b61055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001e3d072e0200000b73072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009a6051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000012be072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000009a7072e020000049c051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b034202000004ff051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d05700002031b034c031b03420200000c59072e0200000867072e0200000517051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103170317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342"; + ("0200002f0405000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c05020200002b61055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001e3d072e0200000b73072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009a6051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000012be072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000" + ^ "b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000009a7072e020000049c051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a000003130319032a072c0200000000020000002c074303680100000021416d6f756e74206d7573742062652067726561746572207468616e207a65726f2e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b034202000004ff051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d05700002031b034c031b03420200000c59072e0200000867072e0200000517051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103170317031607430362000003190337072c0200000000020000001d074303680100000012746f6b656e73536f6c64206973207a65726f0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004d032103170317031703170743036a000003190337072c0200000000020000002d07430368010000002278747a506f6f6c206d7573742062652067726561746572207468616e207a65726f2e0327051f020000004e0321031703170317031607430362000003190337072c0200000000020000002e074303680100000023746f6b656e506f6f6c206d7573742062652067726561746572207468616e207a65726f032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342" + ); } let exprubv5oQmAUP8BwktmDgMWqTizYDJVhzHhJESGZhJ2GkHESZ1VWg = @@ -173,7 +175,9 @@ let exprubv5oQmAUP8BwktmDgMWqTizYDJVhzHhJESGZhJ2GkHESZ1VWg = addresses = ["KT1CT7S2b9hXNRxRrEcany9sak1qe4aaFAZJ"]; patched_code = bin_expr_exn - "0200002c6905000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c050202000028c6055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001c86072e0200000b8d072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009c0051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e032703130743036a000003190337072c0200000000020000004607430368010000003b54686520616d6f756e74206f662058545a2073656e7420746f20446578746572206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000010ed072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000007d6072e02000003af051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b0342020000041b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b034c031b03420200000b75072e0200000783072e0200000433051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342"; + ("0200002c6905000764076407640865046e000000083a7370656e646572076504620000000a3a616c6c6f77616e63650462000000113a63757272656e74416c6c6f77616e63650000000825617070726f766508650765046e000000063a6f776e657204620000000d3a6d696e4c71744d696e74656407650462000000133a6d6178546f6b656e734465706f7369746564046b000000093a646561646c696e650000000d256164644c6971756964697479076408650765046e000000063a6f776e65720765046e000000033a746f04620000000a3a6c71744275726e65640765046a000000103a6d696e58747a57697468647261776e07650462000000133a6d696e546f6b656e7357697468647261776e046b000000093a646561646c696e65000000102572656d6f76654c697175696469747907640865046e000000033a746f07650462000000103a6d696e546f6b656e73426f75676874046b000000093a646561646c696e650000000b2578747a546f546f6b656e08650765046e000000063a6f776e6572046e000000033a746f076504620000000b3a746f6b656e73536f6c640765046a0000000d3a6d696e58747a426f75676874046b000000093a646561646c696e650000000b25746f6b656e546f58747a0764076408650765046e000000153a6f7574707574446578746572436f6e747261637407650462000000103a6d696e546f6b656e73426f75676874046e000000063a6f776e65720765046e000000033a746f076504620000000b3a746f6b656e73536f6c64046b000000093a646561646c696e650000000d25746f6b656e546f546f6b656e0764045d0000001025757064617465546f6b656e506f6f6c04620000001825757064617465546f6b656e506f6f6c496e7465726e616c076408650563035d0359000000092573657442616b65720764046e0000000b257365744d616e61676572046c000000082564656661756c74050107650861046e000000063a6f776e657207650462000000083a62616c616e63650760046e000000083a7370656e64657204620000000a3a616c6c6f77616e636500000009256163636f756e7473076507650459000000183a73656c6649735570646174696e67546f6b656e506f6f6c076504590000000c3a667265657a6542616b65720462000000093a6c7174546f74616c07650765046e000000083a6d616e61676572046e0000000d3a746f6b656e41646472657373076504620000000a3a746f6b656e506f6f6c046a000000083a78747a506f6f6c050202000028c6055707650764076407640765036e07650362036207650765036e036207650362036b076407650765036e0765036e03620765036a07650362036b07640765036e07650362036b07650765036e036e076503620765036a036b0764076407650765036e07650362036e0765036e07650362036b0764035d0362076407650563035d03590764036e036c07650761036e076503620760036e036207650765035907650359036207650765036e036e07650362036a03210316051f02000000020317072e0200001c86072e0200000b8d072e02000001c1051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031603480329072f020000000e0723036e03620743036200000342020000000003210317071f0002020000000203210570000203160329072f02000000060743036200000200000000071f000202000000020321057000020317031703190325072c020000000002000000630743036801000000585468652063757272656e7420616c6c6f77616e636520706172616d65746572206d75737420657175616c207468652073656e64657227732063757272656e7420616c6c6f77616e636520666f7220746865206f776e65722e0327032103170570000203210316051f02000000060317031603460350051f020000000d0321051f020000000203160317034c0320034c0342051f020000000403210316034603480350051f020000000d0321051f020000000203170316034c03200342053d036d034202000009c0051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003807430368010000002d6d6178546f6b656e734465706f7369746564206d7573742062652067726561746572207468616e207a65726f2e032703210316031707430362000003190337072c020000000002000000320743036801000000276d696e4c71744d696e746564206d7573742062652067726561746572207468616e207a65726f2e032703130743036a000003190337072c0200000000020000004607430368010000003b54686520616d6f756e74206f662058545a2073656e7420746f20446578746572206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c031703160317031703300325072c020000032f03130743036a0080897a03190332072c0200000000020000004f07430368010000004454686520696e697469616c206c697175696469747920616d6f756e74206d7573742062652067726561746572207468616e206f7220657175616c20746f20312058545a2e0327034c0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f0200000071051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342034c071f0002020000000203210570000203160316051f0200000004032103160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00030200000002032105700003031603160350051f020000000d0321051f020000000203170316034c032003420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000004e6051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321071f000402000000020321057000040317031703170316033a071f00020200000002032105700002034c0322072f020000001507430368010000000a64697642795a65726f2e0327020000002703210316051f02000000020317034c03300325072c020000000002000000080743036200010312032107430362000003190337072c02000000000200000023074303680100000018746f6b656e734465706f7369746564206973207a65726f2e0327034c071f000402000000020321057000040317031603170317033a051f0200000002034c0322072f0200000002032702000000020316071f0002020000000203210570000203160317051f0200000002032103190332072c020000000002000000430743036801000000386c71744d696e746564206d7573742062652067726561746572207468616e206f7220657175616c20746f206d696e4c71744d696e7465642e0327051f0200000066051f02000000020321034c03170316051f0200000002032103190328072c0200000000020000003e074303680100000033746f6b656e734465706f73697465642069732067726561746572207468616e206d6178546f6b656e734465706f73697465642e0327071f00030200000002032105700003071f0003020000000203210570000303160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000003210316071f000202000000020321057000020312051f020000000d0321051f020000000203170316034c032003420346071f0003020000000203210570000303160316051f020000000f051f020000000805700003032103160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317057000020312051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f000202000000020321057000020312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000b051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d051f0200000004053d036d031b034202000010ed072e020000090b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036a000003190337072c0200000000020000003507430368010000002a6d696e58747a57697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103170317031607430362000003190337072c0200000000020000003807430368010000002d6d696e546f6b656e7357697468647261776e206d7573742062652067726561746572207468616e207a65726f2e0327032103160317031707430362000003190337072c0200000000020000002f0743036801000000246c71744275726e6564206d7573742062652067726561746572207468616e207a65726f2e0327032103160316051f020000000d051f02000000020321034c03160329072f02000000220743036801000000176f776e657220686173206e6f206c69717569646974792e03270200000000034c0321031603170317071f00020200000002032105700002031603190328072c0200000000020000003507430368010000002a6c71744275726e65642069732067726561746572207468616e206f776e657227732062616c616e63652e0327032103160316034803190325072c0200000004034c03160200000132034c0321031703480329072f020000002a07430368010000001f73656e64657220686173206e6f20617070726f76616c2062616c616e63652e03270200000000051f0200000017034c0321031603170317051f02000000060743035b0000034b0321051f020000004b03190328072c0200000000020000003b07430368010000003073656e64657220617070726f76616c2062616c616e6365206973206c657373207468616e204c5154206275726e65642e03270311034605700002032103170570000203480350051f020000000d0321051f020000000203160317034c0320034c034203210316051f0200000043034605710001032103160316034c051f020000002e051f020000000b051f0200000004032103160350051f020000000d0321051f020000000203170316034c03200342051f02000000020321034c031603170317071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a051f0200000017071f0002020000000203210570000203170316031703170322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321071f000302000000020321057000030317031603190332072c0200000000020000003507430368010000002a78747a57697468647261776e206973206c657373207468616e206d696e58747a57697468647261776e2e0327071f00020200000002032105700002031603170317051f0200000023071f0003020000000203210570000303210317031603170317034c0317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321071f0004020000000203210570000403170317031603190332072c0200000000020000003b074303680100000030746f6b656e7357697468647261776e206973206c657373207468616e206d696e546f6b656e7357697468647261776e2e0327071f0003020000000203210570000303160317031705700003034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327057000040321071f0005020000000" + ^ "203210570000503160316051f020000000203160329072f020000000e0723036e03620743036200000342020000000005700002051f020000000d0321051f020000000203170316034c03200342051f0200000004032103160346071f00050200000002032105700005031603160350051f020000000d0321051f020000000203170316034c0320034203210317031603170317071f00040200000002032105700004031603170317034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c03420342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170316071f00020200000002032105700002034c034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00030200000002032105700003034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000302000000020321057000030316031703160555036c072f020000000403170327020000000005700003034f034d051f020000005f051f020000000d051f02000000060316031703160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a000005700003057000040342034903540342034d053d036d034c031b034c031b034202000007d6072e02000003af051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e03270200000000032103170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e032703210317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e0327051f02000000020321034c0317031703170317051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160743036200a80f033a0313051f02000000060743036a00010322072f020000000b0743036801000000000327020000000203160321051f020000000b0743036200a50f033a03120743036200a50f033a071f000302000000020321057000030317031703170316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160321051f0200000052051f020000000603210317031603190328072c0200000000020000003507430368010000002a746f6b656e73426f75676874206973206c657373207468616e206d696e546f6b656e73426f756768742e03270321071f000302000000020321057000030317031703170316034b03210743035b000003190332072c02000000020311020000000b0743036801000000000327051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342051f020000000d051f02000000060316034903540321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030570000505700005051f020000000203420342034d051f0200000004053d036d031b0342020000041b051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e032703210317031703160743036a000003190337072c020000000002000000320743036801000000276d696e58747a426f75676874206d7573742062652067726561746572207468616e207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e03270321031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a0321051f020000004e051f0200000008032103170317031603190328072c0200000000020000002f07430368010000002478747a426f75676874206973206c657373207468616e206d696e58747a426f756768742e0327051f0200000092034c03210317031703170316071f00020200000002032105700002031703160312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c03420321051f02000000ae051f020000000a03210317031703170317034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f00020200000002032105700002031603170555036c072f02000000020327020000000005700001034f034d051f020000006a051f0200000011032103170316051f0200000004031603160321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b034c031b03420200000b75072e0200000783072e0200000433051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e03270321031703170317034003190337072c0200000000020000002807430368010000001d4e4f572069732067726561746572207468616e20646561646c696e652e0327032103160317031607430362000003190337072c0200000000020000003507430368010000002a6d696e546f6b656e73426f75676874206d7573742062652067726561746572207468616e207a65726f2e032703210317031703160743036200a50f033a071f0002020000000203210570000203170317031703160743036200a80f033a0312051f02000000020321034c0317031703160743036200a50f033a071f000302000000020321057000030317031703170317051f02000000060743036a00010322072f020000000b074303680100000000032702000000020316033a0322072f020000001507430368010000000a64697642795a65726f2e0327020000000203160743036a0001033a051f02000000020321034c031703170316071f0003020000000203210570000303170317031703160312051f020000000405700002051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317031703170317071f00020200000002032105700002034c0393072f020000001a07430368010000000f6e65676174697665206d7574657a2103270200000000051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342071f000202000000020321057000020316031606550765036e07650362036b0000000b2578747a546f546f6b656e072f020000000403170327020000000005700002071f00030200000002032105700003032103170316051f02000000190321031603170316051f0200000008032103170317031703420342034c0320034d034c051f0200000017034c0321031703170316051f02000000060316031703170321031703170316031706550765036e0765036e036200000009257472616e73666572072f02000000040317032702000000000743036a0000057000030349035405700005051f020000000203420342034d053d036d034c031b051f0200000002034c034c031b03420200000344072e02000001720743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327031e0354034803190325072c02000000000200000020074303680100000015756e73616665557064617465546f6b656e506f6f6c03270321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031707430359030a051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c03420321031703170316031706550765036e055a03620000000b2567657442616c616e6365072f02000000040317032702000000000743036a000004490000001825757064617465546f6b656e506f6f6c496e7465726e616c034903540342034d051f0200000004053d036d031b034202000001c60743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c031703160316072c0200000000020000003207430368010000002744657874657220646964206e6f7420696e6974696174652074686973206f7065726174696f6e2e0327051f02000000020321034c0317031703160317034803190325072c0200000000020000004e0743036801000000435468652073656e646572206973206e6f742074686520746f6b656e20636f6e7472616374206173736f6369617465642077697468207468697320636f6e74726163742e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c034203210317074303590303051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000003e6072e02000001bd051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f02000000020321034c0317031603170316033f072c0200000000020000003d07430368010000003243616e6e6f74206368616e6765207468652062616b6572207768696c6520667265657a6542616b657220697320747275652e032703210316051f02000000020317034e051f0200000073051f020000000403210317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316034c03200342034c03420342051f020000000d0321051f020000000203160317034c0320034c0342053d036d031b0342020000021d072e0200000147051f02000000410321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000743036a0000031303190325072c0200000000020000001f074303680100000014416d6f756e74206d757374206265207a65726f2e0327051f02000000020321034c0317031703160316034803190325072c0200000000020000002e07430368010000002373656e646572206973206e6f742074686520636f6e7472616374206d616e616765722e0327051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203170316051f020000000d0321051f020000000203170316034c032003420342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d034202000000ca03200321031703160316072c020000002d07430368010000002273656c6649735570646174696e67546f6b656e206d7573742062652066616c73652e032702000000000321031703170317031703130312051f020000000403210317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317051f020000000d0321051f020000000203160317034c0320034c0342034c0342034c0342051f020000000d0321051f020000000203160317034c0320034c0342053d036d0342" + ); } let patches = -- GitLab From 281086cebb17f384134b1fd27204877b0753e10c Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Mon, 2 May 2022 14:09:11 +0200 Subject: [PATCH 078/105] Proto: translate the step function to a Coq version easier to execute --- .../lib_protocol/script_interpreter.ml | 85 ++++++++++--------- 1 file changed, 47 insertions(+), 38 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index a291f1733d3a7..2677cb49cb12f 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -258,20 +258,20 @@ let ifailwith : ifailwith_type = evaluation rules depending on the continuation at stake. *) -let[@coq_struct "gas"] rec kmap_exit : +let[@coq_mutual_as_notation] rec kmap_exit : type a b c d e f g h m n o. (a, b, c, d, e, f, g, h, m, n, o) kmap_exit_type = fun mk g gas (body, xs, ys, yk) ks accu stack -> let ys = Script_map.update yk (Some accu) ys in let ks = mk (KMap_enter_body (body, xs, ys, ks)) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_struct "gas"] kmap_enter : +and[@coq_mutual_as_notation] kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = fun mk g gas (body, xs, ys) ks accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks ys (accu, stack) | (xk, xv) :: xs -> let ks = mk (KMap_exit_body (body, xs, ys, xk, ks)) in @@ -280,18 +280,18 @@ and[@coq_struct "gas"] kmap_enter : (step [@ocaml.tailcall]) g gas body ks res stack [@@inline] -and[@coq_struct "gas"] klist_exit : +and[@coq_mutual_as_notation] klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type = fun mk g gas (body, xs, ys, len) ks accu stack -> let ks = mk (KList_enter_body (body, xs, accu :: ys, len, ks)) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_struct "gas"] klist_enter : +and[@coq_mutual_as_notation] klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type = fun mk g gas (body, xs, ys, len) ks' accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> let ys = {elements = List.rev ys; length = len} in (next [@ocaml.tailcall]) g gas ks' ys (accu, stack) @@ -300,32 +300,34 @@ and[@coq_struct "gas"] klist_enter : (step [@ocaml.tailcall]) g gas body ks x (accu, stack) [@@inline] -and[@coq_struct "gas"] kloop_in_left : +and[@coq_mutual_as_notation] kloop_in_left : type a b c d e f g. (a, b, c, d, e, f, g) kloop_in_left_type = fun g gas ks0 ki ks' accu stack -> - match accu with + match[@coq_type_annotation] accu with | L v -> (step [@ocaml.tailcall]) g gas ki ks0 v stack | R v -> (next [@ocaml.tailcall]) g gas ks' v stack [@@inline] -and[@coq_struct "gas"] kloop_in : +and[@coq_mutual_as_notation] kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type = fun g gas ks0 ki ks' accu stack -> let (accu', stack') = stack in - if accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' + if [@coq_type_annotation] accu then + (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' else (next [@ocaml.tailcall]) g gas ks' accu' stack' [@@inline] -and[@coq_struct "gas"] kiter : type a b s r f. (a, b, s, r, f) kiter_type = +and[@coq_mutual_as_notation] kiter : type a b s r f. (a, b, s, r, f) kiter_type + = fun mk g gas (body, xs) ks accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks accu stack | x :: xs -> let ks = mk (KIter (body, xs, ks)) in (step [@ocaml.tailcall]) g gas body ks x (accu, stack) [@@inline] -and[@coq_struct "function_parameter"] next : +and[@coq_struct "gas"] next : type a s r f. outdated_context * step_constants -> local_gas_counter -> @@ -333,7 +335,8 @@ and[@coq_struct "function_parameter"] next : a -> s -> (r * f * outdated_context * local_gas_counter) tzresult Lwt.t = - fun ((ctxt, _) as g) gas ks0 accu stack -> + fun g gas ks0 accu stack -> + let (ctxt, _) = g in match consume_control gas ks0 with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( @@ -385,7 +388,7 @@ and[@coq_struct "function_parameter"] next : instructions. *) -and[@coq_struct "gas"] ilist_map : +and[@coq_mutual_as_notation] ilist_map : type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = fun log_if_needed g gas (body, k) ks accu stack -> let xs = accu.elements in @@ -395,29 +398,29 @@ and[@coq_struct "gas"] ilist_map : log_if_needed (KList_enter_body (body, xs, ys, len, KCons (k, ks))) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_struct "gas"] ilist_iter : +and[@coq_mutual_as_notation] ilist_iter : type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type = fun log_if_needed g gas (body, k) ks accu stack -> let xs = accu.elements in let ks = log_if_needed (KIter (body, xs, KCons (k, ks))) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_struct "gas"] iset_iter : +and[@coq_mutual_as_notation] iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = fun log_if_needed g gas (body, k) ks accu stack -> let set = accu in let l = List.rev (Script_set.fold (fun e acc -> e :: acc) set []) in let ks = log_if_needed (KIter (body, l, KCons (k, ks))) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_struct "gas"] imap_map : +and[@coq_mutual_as_notation] imap_map : type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type = fun log_if_needed g gas (body, k) ks accu stack -> let map = accu in @@ -425,58 +428,58 @@ and[@coq_struct "gas"] imap_map : let ys = (Script_map.empty_from [@coq_type_annotation]) map in let ks = log_if_needed (KMap_enter_body (body, xs, ys, KCons (k, ks))) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_struct "gas"] imap_iter : +and[@coq_mutual_as_notation] imap_iter : type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = fun log_if_needed g gas (body, k) ks accu stack -> let map = accu in let l = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in let ks = log_if_needed (KIter (body, l, KCons (k, ks))) in let (accu, stack) = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_struct "gas"] imul_teznat : +and[@coq_mutual_as_notation] imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = fun logger g gas (kinfo, k) ks accu stack -> let x = accu in let (y, stack) = stack in - match Script_int.to_int64 y with + match[@coq_type_annotation] Script_int.to_int64 y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and[@coq_struct "gas"] imul_nattez : +and[@coq_mutual_as_notation] imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = fun logger g gas (kinfo, k) ks accu stack -> let y = accu in let (x, stack) = stack in - match Script_int.to_int64 y with + match[@coq_type_annotation] Script_int.to_int64 y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and[@coq_struct "gas"] ilsl_nat : +and[@coq_mutual_as_notation] ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = fun logger g gas (kinfo, k) ks accu stack -> let x = accu in let (y, stack) = stack in - match Script_int.shift_left_n x y with + match[@coq_type_annotation] Script_int.shift_left_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack -and[@coq_struct "gas"] ilsr_nat : +and[@coq_mutual_as_notation] ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = fun logger g gas (kinfo, k) ks accu stack -> let x = accu in let (y, stack) = stack in - match Script_int.shift_right_n x y with + match[@coq_type_annotation] Script_int.shift_right_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack -and[@coq_struct "gas"] iexec : +and[@coq_mutual_as_notation] iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = fun logger g gas k ks accu stack -> let arg = accu in @@ -488,7 +491,13 @@ and[@coq_struct "gas"] iexec : | Some logger -> log_kinstr logger code.kinstr in let ks = KReturn (stack, KCons (k, ks)) in - (step [@ocaml.tailcall]) g gas code ks arg (EmptyCell, EmptyCell) + ((step [@ocaml.tailcall]) + g + gas + code + ks + arg + (EmptyCell, EmptyCell) [@coq_type_annotation]) and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = fun g gas i ks accu stack -> @@ -1788,7 +1797,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = that starts the evaluation. *) -and[@coq_struct "function_parameter"] log : +and[@coq_axiom_with_reason "we ignore the logging operations"] log : type a s b t r f. logger * logging_event -> (a, s, b, t, r, f) step_type = fun (logger, event) ((ctxt, _) as g) gas k ks accu stack -> (match (k, event) with @@ -1852,7 +1861,7 @@ and[@coq_struct "function_parameter"] log : | _ -> (step [@ocaml.tailcall]) g gas k (with_log ks) accu stack [@@inline] -and[@coq_struct "gas"] klog : +and[@coq_axiom_with_reason "we ignore the logging operations"] klog : type a s r f. logger -> outdated_context * step_constants -> -- GitLab From 1073afed64dd772f4c335e925a7a1ba49ee8246b Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 24 May 2022 15:29:17 +0200 Subject: [PATCH 079/105] Proto: apply fmt-ocaml --- .../lib_protocol/script_ir_translator.ml | 62 +++++++++---------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 8948ec6a90221..055ca3cbdf6d9 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1974,32 +1974,31 @@ let find_entrypoint (type full fullc error_trace) | (_, {at_node = Some {name; original_type_expr}; _}) when Entrypoint.(name = entrypoint) -> return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) - | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _}) - -> ( + | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _}) -> Gas_monad.bind_recover - (find_entrypoint tl left entrypoint [@coq_type_annotation]) - @@ function[@coq_match_gadt] [@coq_cast] - | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> - return - (Ex_ty_cstr - { - ty; - construct = (fun e -> L (construct e)); - original_type_expr; - }) - | Error () -> ( - let+ x = - (find_entrypoint tr right entrypoint [@coq_type_annotation]) - in - match[@coq_match_gadt]x with - | Ex_ty_cstr {ty; construct; original_type_expr} -> - Ex_ty_cstr - { - ty; - construct = - (fun e -> R ((construct [@coq_type_annotation]) e)); - original_type_expr; - }))[@coq_cast] + (find_entrypoint tl left entrypoint) + (function [@coq_match_gadt] + | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> + return + (Ex_ty_cstr + { + ty; + construct = (fun e -> L (construct e)); + original_type_expr; + }) + | Error () -> ( + let+ x = + (find_entrypoint tr right entrypoint [@coq_type_annotation]) + in + match[@coq_match_gadt] x with + | Ex_ty_cstr {ty; construct; original_type_expr} -> + Ex_ty_cstr + { + ty; + construct = (fun e -> R (construct e)); + original_type_expr; + })) + [@coq_cast] | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in @@ -5971,7 +5970,9 @@ and[@coq_mutual_as_notation] unparse_items : ([], ctxt) items -and[@coq_struct "ctxt"] unparse_code_aux (ctxt : context) ~(stack_depth : int) (mode : unparsing_mode) (code : Script.node) : (node * context, error trace) result Lwt.t = +and[@coq_struct "ctxt"] unparse_code_aux (ctxt : context) ~(stack_depth : int) + (mode : unparsing_mode) (code : Script.node) : + (node * context, error trace) result Lwt.t = let legacy = true in Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> let non_terminal_recursion ctxt mode code = @@ -6026,16 +6027,15 @@ and[@coq_struct "ctxt"] unparse_code_aux (ctxt : context) ~(stack_depth : int) ( return (Prim (loc, prim, List.rev items, annot), ctxt) | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt) -let parse_and_unparse_script_unaccounted - : context -> +let parse_and_unparse_script_unaccounted : + context -> legacy:bool -> allow_forged_in_storage:bool -> unparsing_mode -> normalize_types:bool -> Script.t -> - (Script.t * context) tzresult Lwt.t - = fun ctxt ~legacy ~allow_forged_in_storage - mode ~normalize_types {code; storage} -> + (Script.t * context) tzresult Lwt.t = + fun ctxt ~legacy ~allow_forged_in_storage mode ~normalize_types {code; storage} -> Script.force_decode_in_context ~consume_deserialization_gas:When_needed ctxt -- GitLab From 9be9005830396c238362a7941b27532ebfd57b4a Mon Sep 17 00:00:00 2001 From: emarzion Date: Wed, 15 Jun 2022 17:20:17 -0500 Subject: [PATCH 080/105] last files --- .../lib_protocol/script_ir_translator.ml | 1219 +---------------- .../lib_protocol/script_ir_translator.mli | 10 +- 2 files changed, 25 insertions(+), 1204 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index ad237936968fa..525f71da0bd71 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -164,67 +164,6 @@ let check_kind kinds expr = (everything that cannot contain a lambda). The rest is located at the end of the file. *) -<<<<<<< HEAD -let rec ty_of_comparable_ty : - type a. a comparable_ty -> (a, Dependent_bool.yes) ty = - function[@coq_match_with_default] - | Unit_t -> Unit_t - | Never_t -> Never_t - | Int_t -> Int_t - | Nat_t -> Nat_t - | Signature_t -> Signature_t - | String_t -> String_t - | Bytes_t -> Bytes_t - | Mutez_t -> Mutez_t - | Bool_t -> Bool_t - | Key_hash_t -> Key_hash_t - | Key_t -> Key_t - | Timestamp_t -> Timestamp_t - | Address_t -> Address_t - | Tx_rollup_l2_address_t -> Tx_rollup_l2_address_t - | Chain_id_t -> Chain_id_t - | Pair_t (l, r, meta, YesYes) -> - Pair_t (ty_of_comparable_ty l, ty_of_comparable_ty r, meta, YesYes) - | Union_t (l, r, meta, YesYes) -> - Union_t (ty_of_comparable_ty l, ty_of_comparable_ty r, meta, YesYes) - | Option_t (t, meta, Yes) -> Option_t (ty_of_comparable_ty t, meta, Yes) - -let rec unparse_comparable_ty_uncarbonated : - type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = - fun ~loc -> function[@coq_match_with_default] - | Unit_t -> Prim (loc, T_unit, [], []) - | Never_t -> Prim (loc, T_never, [], []) - | Int_t -> Prim (loc, T_int, [], []) - | Nat_t -> Prim (loc, T_nat, [], []) - | Signature_t -> Prim (loc, T_signature, [], []) - | String_t -> Prim (loc, T_string, [], []) - | Bytes_t -> Prim (loc, T_bytes, [], []) - | Mutez_t -> Prim (loc, T_mutez, [], []) - | Bool_t -> Prim (loc, T_bool, [], []) - | Key_hash_t -> Prim (loc, T_key_hash, [], []) - | Key_t -> Prim (loc, T_key, [], []) - | Timestamp_t -> Prim (loc, T_timestamp, [], []) - | Address_t -> Prim (loc, T_address, [], []) - | Tx_rollup_l2_address_t -> Prim (loc, T_tx_rollup_l2_address, [], []) - | Chain_id_t -> Prim (loc, T_chain_id, [], []) - | Pair_t (l, r, _meta, YesYes) -> ( - let tl = unparse_comparable_ty_uncarbonated ~loc l in - let tr = unparse_comparable_ty_uncarbonated ~loc r in - (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *) - (* Note that the folding does not happen if the pair on the right has a - field annotation because this annotation would be lost *) - match tr with - | Prim (_, T_pair, ts, []) -> Prim (loc, T_pair, tl :: ts, []) - | _ -> Prim (loc, T_pair, [tl; tr], [])) - | Union_t (l, r, _meta, YesYes) -> - let tl = unparse_comparable_ty_uncarbonated ~loc l in - let tr = unparse_comparable_ty_uncarbonated ~loc r in - Prim (loc, T_or, [tl; tr], []) - | Option_t (t, _meta, Yes) -> - Prim (loc, T_option, [unparse_comparable_ty_uncarbonated ~loc t], []) - -======= ->>>>>>> master let unparse_memo_size ~loc memo_size = let z = Sapling.Memo_size.unparse_to_z memo_size in Int (loc, z) @@ -363,11 +302,7 @@ let serialize_ty_for_error ty = *) unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations -<<<<<<< HEAD -let rec comparable_ty_of_ty : -======= let[@coq_axiom_with_reason "gadt"] check_comparable : ->>>>>>> master type a ac. Script.location -> (a, ac) ty -> (ac, Dependent_bool.yes) eq tzresult = fun loc ty -> @@ -615,41 +550,7 @@ let[@coq_struct "ty"] rec unparse_comparable_data : [unparse_data_aux] for now. *) >>?= fun ctxt -> -<<<<<<< HEAD match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with - | (Unit_t, (v : unit)) -> Lwt.return @@ unparse_unit ~loc ctxt v - | (Int_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_int ~loc ctxt v - | (Nat_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_nat ~loc ctxt v - | (String_t, (s : Script_string.t)) -> - Lwt.return @@ unparse_string ~loc ctxt s - | (Bytes_t, (s : bytes)) -> Lwt.return @@ unparse_bytes ~loc ctxt s - | (Bool_t, (b : bool)) -> Lwt.return @@ unparse_bool ~loc ctxt b - | (Timestamp_t, (t : Script_timestamp.t)) -> - Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | (Address_t, (address : address)) -> - Lwt.return @@ unparse_address ~loc ctxt mode address - | (Tx_rollup_l2_address_t, (address : tx_rollup_l2_address)) -> - Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | (Signature_t, (s : signature)) -> - Lwt.return @@ unparse_signature ~loc ctxt mode s - | (Mutez_t, (v : Tez_repr.t)) -> Lwt.return @@ unparse_mutez ~loc ctxt v - | (Key_t, (k : public_key)) -> Lwt.return @@ unparse_key ~loc ctxt mode k - | (Key_hash_t, (k : public_key_hash)) -> - Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | (Chain_id_t, (chain_id : Script_chain_id.t)) -> - Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | (Pair_t (tl, tr, _, YesYes), (pair : _ * _)) -> - let r_witness = comparable_comb_witness2 tr in - let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in - let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in - unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | (Union_t (tl, tr, _, YesYes), (v : _ union)) -> - let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in - let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in - unparse_union ~loc unparse_l unparse_r ctxt v - | (Option_t (t, _, Yes), (v : _ option)) -> -======= - match (ty, a) with | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v @@ -676,7 +577,6 @@ let[@coq_struct "ty"] rec unparse_comparable_data : let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v | Option_t (t, _, Yes), v -> ->>>>>>> master let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in unparse_option ~loc unparse_v ctxt v | Never_t, _ -> . @@ -793,91 +693,7 @@ let type_metadata_eq : let default_ty_eq_error loc ty1 ty2 = let ty1 = serialize_ty_for_error ty1 in let ty2 = serialize_ty_for_error ty2 in -<<<<<<< HEAD - Inconsistent_types (None, ty1, ty2) - -(* Check that two comparable types are equal. - - The result is an equality witness between the types of the two inputs within - the gas monad (for gas consumption). - *) -let rec comparable_ty_eq : - type ta tb error_trace. - error_details:error_trace error_details -> - ta comparable_ty -> - tb comparable_ty -> - ((ta comparable_ty, tb comparable_ty) eq, error_trace) Gas_monad.t = - let open Gas_monad in - fun ~error_details ta tb -> - let open Gas_monad.Syntax in - let* () = Gas_monad.consume_gas Typecheck_costs.merge_cycle in - let type_metadata_eq meta_a meta_b = - of_result @@ type_metadata_eq ~error_details meta_a meta_b - in - let not_equal () = - of_result - @@ Error - (match[@coq_match_gadt_with_result] error_details with - | Fast -> (Inconsistent_types_fast : error_trace) - | Informative -> - trace_of_error - @@ default_ty_eq_error - (ty_of_comparable_ty ta) - (ty_of_comparable_ty tb)) - in - match[@coq_match_with_default] (ta, tb) with - | (Unit_t, Unit_t) -> return (Eq : (ta comparable_ty, tb comparable_ty) eq) - | (Unit_t, _) -> not_equal () - | (Never_t, Never_t) -> return Eq - | (Never_t, _) -> not_equal () - | (Int_t, Int_t) -> return Eq - | (Int_t, _) -> not_equal () - | (Nat_t, Nat_t) -> return Eq - | (Nat_t, _) -> not_equal () - | (Signature_t, Signature_t) -> return Eq - | (Signature_t, _) -> not_equal () - | (String_t, String_t) -> return Eq - | (String_t, _) -> not_equal () - | (Bytes_t, Bytes_t) -> return Eq - | (Bytes_t, _) -> not_equal () - | (Mutez_t, Mutez_t) -> return Eq - | (Mutez_t, _) -> not_equal () - | (Bool_t, Bool_t) -> return Eq - | (Bool_t, _) -> not_equal () - | (Key_hash_t, Key_hash_t) -> return Eq - | (Key_hash_t, _) -> not_equal () - | (Key_t, Key_t) -> return Eq - | (Key_t, _) -> not_equal () - | (Timestamp_t, Timestamp_t) -> return Eq - | (Timestamp_t, _) -> not_equal () - | (Chain_id_t, Chain_id_t) -> return Eq - | (Chain_id_t, _) -> not_equal () - | (Address_t, Address_t) -> return Eq - | (Address_t, _) -> not_equal () - | (Tx_rollup_l2_address_t, Tx_rollup_l2_address_t) -> return Eq - | (Tx_rollup_l2_address_t, _) -> not_equal () - | ( Pair_t (left_a, right_a, meta_a, YesYes), - Pair_t (left_b, right_b, meta_b, YesYes) ) -> - let* () = type_metadata_eq meta_a meta_b in - let* Eq = comparable_ty_eq ~error_details left_a left_b in - let+ Eq = comparable_ty_eq ~error_details right_a right_b in - (Eq : (ta comparable_ty, tb comparable_ty) eq) - | (Pair_t _, _) -> not_equal () - | ( Union_t (left_a, right_a, meta_a, YesYes), - Union_t (left_b, right_b, meta_b, YesYes) ) -> - let* () = type_metadata_eq meta_a meta_b in - let* Eq = comparable_ty_eq ~error_details left_a left_b in - let+ Eq = comparable_ty_eq ~error_details right_a right_b in - (Eq : (ta comparable_ty, tb comparable_ty) eq) - | (Union_t _, _) -> not_equal () - | (Option_t (ta, meta_a, Yes), Option_t (tb, meta_b, Yes)) -> - let* () = type_metadata_eq meta_a meta_b in - let+ Eq = comparable_ty_eq ~error_details ta tb in - (Eq : (ta comparable_ty, tb comparable_ty) eq) - | (Option_t _, _) -> not_equal () -======= Inconsistent_types (loc, ty1, ty2) ->>>>>>> master let memo_size_eq : type error_trace. @@ -913,9 +729,6 @@ let rec ty_eq : let memo_size_eq ms1 ms2 = Gas_monad.of_result (memo_size_eq ~error_details ms1 ms2) in -<<<<<<< HEAD - let rec help0 : -======= let rec help : type ta tac tb tbc. (ta, tac) ty -> @@ -926,7 +739,6 @@ let rec ty_eq : |> Gas_monad.record_trace_eval ~error_details (fun loc -> default_ty_eq_error loc ty1 ty2) and help0 : ->>>>>>> master type ta tac tb tbc. (ta, tac) ty -> (tb, tbc) ty -> @@ -1154,136 +966,6 @@ let parse_memo_size (n : (location, _) Micheline.node) : type ex_comparable_ty = | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty -<<<<<<< HEAD -let[@coq_struct "ty"] rec parse_comparable_ty_aux : - stack_depth:int -> - context -> - Script.node -> - (ex_comparable_ty * context) tzresult = - fun ~stack_depth ctxt ty -> - Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt -> - if Compare.Int.(stack_depth > 10000) then - error Typechecking_too_many_recursive_calls - else - match ty with - | Prim (loc, T_unit, [], annot) -> - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty unit_key, ctxt) - | Prim (loc, T_never, [], annot) -> - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty never_key, ctxt) - | Prim (loc, T_int, [], annot) -> - check_type_annot loc annot >|? fun () -> (Ex_comparable_ty int_key, ctxt) - | Prim (loc, T_nat, [], annot) -> - check_type_annot loc annot >|? fun () -> (Ex_comparable_ty nat_key, ctxt) - | Prim (loc, T_signature, [], annot) -> - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty signature_key, ctxt) - | Prim (loc, T_string, [], annot) -> - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty string_key, ctxt) - | Prim (loc, T_bytes, [], annot) -> - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty bytes_key, ctxt) - | Prim (loc, T_mutez, [], annot) -> - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty mutez_key, ctxt) - | Prim (loc, T_bool, [], annot) -> - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty bool_key, ctxt) - | Prim (loc, T_key_hash, [], annot) -> - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty key_hash_key, ctxt) - | Prim (loc, T_key, [], annot) -> - check_type_annot loc annot >|? fun () -> (Ex_comparable_ty key_key, ctxt) - | Prim (loc, T_timestamp, [], annot) -> - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty timestamp_key, ctxt) - | Prim (loc, T_chain_id, [], annot) -> - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty chain_id_key, ctxt) - | Prim (loc, T_address, [], annot) -> - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty address_key, ctxt) - | Prim (loc, T_tx_rollup_l2_address, [], annot) -> - if Constants.tx_rollup_enable ctxt then - check_type_annot loc annot >|? fun () -> - (Ex_comparable_ty tx_rollup_l2_address_key, ctxt) - else error @@ Tx_rollup_addresses_disabled loc - | Prim - ( loc, - (( T_unit | T_never | T_int | T_nat | T_string | T_bytes | T_mutez - | T_bool | T_key_hash | T_timestamp | T_address | T_chain_id - | T_signature | T_key ) as prim), - l, - _ ) -> - error (Invalid_arity (loc, prim, 0, List.length l)) - | Prim (loc, T_pair, left :: right, annot) -> - check_type_annot loc annot >>? fun () -> - remove_field_annot left >>? fun left -> - (match right with - | [right] -> remove_field_annot right - | right -> - (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) - ok (Prim (loc, T_pair, right, []))) - >>? fun right -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt right - >>? fun (Ex_comparable_ty right, ctxt) -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt left - >>? fun (Ex_comparable_ty left, ctxt) -> - pair_key loc left right >|? fun ty -> (Ex_comparable_ty ty, ctxt) - | Prim (loc, T_or, [left; right], annot) -> - check_type_annot loc annot >>? fun () -> - remove_field_annot left >>? fun left -> - remove_field_annot right >>? fun right -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt right - >>? fun (Ex_comparable_ty right, ctxt) -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt left - >>? fun (Ex_comparable_ty left, ctxt) -> - union_key loc left right >|? fun ty -> (Ex_comparable_ty ty, ctxt) - | Prim (loc, ((T_pair | T_or) as prim), l, _) -> - error (Invalid_arity (loc, prim, 2, List.length l)) - | Prim (loc, T_option, [t], annot) -> - check_type_annot loc annot >>? fun () -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t - >>? fun (Ex_comparable_ty t, ctxt) -> - option_key loc t >|? fun ty -> (Ex_comparable_ty ty, ctxt) - | Prim (loc, T_option, l, _) -> - error (Invalid_arity (loc, T_option, 1, List.length l)) - | Prim - ( loc, - (T_set | T_map | T_list | T_lambda | T_contract | T_operation), - _, - _ ) -> - error (Comparable_type_expected (loc, Micheline.strip_locations ty)) - | expr -> - error - @@ unexpected - expr - [] - Type_namespace - [ - T_unit; - T_never; - T_int; - T_nat; - T_string; - T_bytes; - T_mutez; - T_bool; - T_key_hash; - T_timestamp; - T_address; - T_pair; - T_or; - T_option; - T_chain_id; - T_signature; - T_key; - ] - -======= ->>>>>>> master type ex_ty = Ex_ty : ('a, _) ty -> ex_ty type ex_parameter_ty_and_entrypoints_node = @@ -1655,9 +1337,6 @@ let[@coq_struct "node_value"] rec parse_ty_aux : T_unit; ] -<<<<<<< HEAD -and[@coq_mutual_as_notation] parse_passable_ty_aux_with_ret : -======= and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_comparable_ty : context -> @@ -1683,7 +1362,6 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_compar (Comparable_type_expected (location node, Micheline.strip_locations node)) and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty : ->>>>>>> master type ret name. context -> stack_depth:int -> @@ -1908,13 +1586,6 @@ type ex_script = Ex_script : ('a, 'c) Script_typed_ir.script -> ex_script type ex_code = Ex_code : ('a, 'c) code -> ex_code -<<<<<<< HEAD -type 'storage ex_view = - | Ex_view : - ('input * 'storage, 'output) Script_typed_ir.lambda - -> 'storage ex_view -[@@coq_force_gadt] -======= type 'storage typed_view = | Typed_view : { input_ty : ('input, _) ty; @@ -1925,7 +1596,6 @@ type 'storage typed_view = -> 'storage typed_view type 'storage typed_view_map = (Script_string.t, 'storage typed_view) map ->>>>>>> master type (_, _) dig_proof_argument = | Dig_proof_argument : @@ -2058,44 +1728,12 @@ let find_entrypoint (type full fullc error_context error_trace) (t ex_ty_cstr, unit) Gas_monad.t = fun ty entrypoints entrypoint -> let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in -<<<<<<< HEAD match[@coq_match_gadt] [@coq_match_with_default] (ty, entrypoints) with - | (_, {at_node = Some {name; original_type_expr}; _}) - when Entrypoint.(name = entrypoint) -> - return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) - | (Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _}) -> - Gas_monad.bind_recover - (find_entrypoint tl left entrypoint) - (function [@coq_match_gadt] - | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> - return - (Ex_ty_cstr - { - ty; - construct = (fun e -> L (construct e)); - original_type_expr; - }) - | Error () -> ( - let+ x = - (find_entrypoint tr right entrypoint [@coq_type_annotation]) - in - match[@coq_match_gadt] x with - | Ex_ty_cstr {ty; construct; original_type_expr} -> - Ex_ty_cstr - { - ty; - construct = (fun e -> R (construct e)); - original_type_expr; - })) - [@coq_cast] - | (_, {nested = Entrypoints_None; _}) -> Gas_monad.of_result (Error ()) -======= - match (ty, entrypoints) with | _, {at_node = Some {name; original_type_expr}; _} when Entrypoint.(name = entrypoint) -> return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> ( - Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function + Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ (function [@coq_match_gadt] | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> return (Ex_ty_cstr @@ -2106,12 +1744,11 @@ let find_entrypoint (type full fullc error_context error_trace) }) | Error () -> let+ (Ex_ty_cstr {ty; construct; original_type_expr}) = - find_entrypoint tr right entrypoint + (find_entrypoint tr right entrypoint [@coq_type_annotation]) in Ex_ty_cstr - {ty; construct = (fun e -> R (construct e)); original_type_expr}) + {ty; construct = (fun e -> R (construct e)); original_type_expr})) | _, {nested = Entrypoints_None; _} -> Gas_monad.of_result (Error ()) ->>>>>>> master in let {root; original_type_expr} = entrypoints in Gas_monad.bind_recover (find_entrypoint full root entrypoint) @@ function @@ -2572,101 +2209,11 @@ let parse_option parse_v ctxt ~legacy = function fail @@ Invalid_arity (loc, D_None, 0, List.length l) | expr -> fail @@ unexpected expr [] Constant_namespace [D_Some; D_None] -<<<<<<< HEAD -(* -- parse data of comparable types -- *) - -let comparable_comb_witness1 : - type t. t comparable_ty -> (t, unit -> unit) comb_witness = function - | Pair_t _ -> Comb_Pair Comb_Any - | _ -> Comb_Any - -let[@coq_struct "ty"] rec parse_comparable_data : - type a. - ?type_logger:type_logger -> - context -> - a comparable_ty -> - Script.node -> - (a * context) tzresult Lwt.t = - fun ?type_logger ctxt ty script_data -> - (* No need for stack_depth here. Unlike [parse_data_aux], - [parse_comparable_data] doesn't call [parse_returning]. - The stack depth is bounded by the type depth, bounded by 1024. *) - let parse_data_error () = - let ty = serialize_ty_for_error (ty_of_comparable_ty ty) in - Invalid_constant (location script_data, strip_locations script_data, ty) - in - let traced_no_lwt body = record_trace_eval parse_data_error body in - let traced body = trace_eval parse_data_error body in - Gas.consume ctxt Typecheck_costs.parse_data_cycle - (* We could have a smaller cost but let's keep it consistent with - [parse_data_aux] for now. *) - >>?= - fun ctxt -> - let legacy = false in - match[@coq_match_gadt_with_result] [@coq_match_with_default] - (ty, script_data) - with - | (Unit_t, expr) -> - Lwt.return @@ traced_no_lwt - @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) - | (Bool_t, expr) -> - Lwt.return @@ traced_no_lwt @@ parse_bool ctxt ~legacy expr - | (String_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_string ctxt expr - | (Bytes_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_bytes ctxt expr - | (Int_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_int ctxt expr - | (Nat_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_nat ctxt expr - | (Mutez_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_mutez ctxt expr - | (Timestamp_t, expr) -> - Lwt.return @@ traced_no_lwt @@ parse_timestamp ctxt expr - | (Key_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_key ctxt expr - | (Key_hash_t, expr) -> - Lwt.return @@ traced_no_lwt @@ parse_key_hash ctxt expr - | (Signature_t, expr) -> - Lwt.return @@ traced_no_lwt @@ parse_signature ctxt expr - | (Chain_id_t, expr) -> - Lwt.return @@ traced_no_lwt @@ parse_chain_id ctxt expr - | (Address_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_address ctxt expr - | (Tx_rollup_l2_address_t, expr) -> - Lwt.return @@ traced_no_lwt @@ parse_tx_rollup_l2_address ctxt expr - | (Pair_t (tl, tr, _, YesYes), expr) -> - let r_witness = comparable_comb_witness1 tr in - let parse_l ctxt v = parse_comparable_data ?type_logger ctxt tl v in - let parse_r ctxt v = parse_comparable_data ?type_logger ctxt tr v in - traced @@ parse_pair parse_l parse_r ctxt ~legacy r_witness expr - | (Union_t (tl, tr, _, YesYes), expr) -> - let parse_l ctxt v = parse_comparable_data ?type_logger ctxt tl v in - let parse_r ctxt v = parse_comparable_data ?type_logger ctxt tr v in - traced @@ parse_union parse_l parse_r ctxt ~legacy expr - | (Option_t (t, _, Yes), expr) -> - let parse_v ctxt v = parse_comparable_data ?type_logger ctxt t v in - traced @@ parse_option parse_v ctxt ~legacy expr - | (Never_t, expr) -> Lwt.return @@ traced_no_lwt @@ parse_never expr - -(* -- parse data of any type -- *) - -======= ->>>>>>> master let comb_witness1 : type t tc. (t, tc) ty -> (t, unit -> unit) comb_witness = function | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -<<<<<<< HEAD -(* - Some values, such as operations, tickets, or big map ids, are used only - internally and are not allowed to be forged by users. - In [parse_data_aux], [allow_forged] should be [false] for: - - PUSH - - UNPACK - - user-provided script parameters - - storage on origination - And [true] for: - - internal calls parameters - - storage after origination -*) - -let[@coq_struct "ctxt"] rec parse_data_aux : -======= let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = function | String (loc, v) as expr -> @@ -2797,7 +2344,6 @@ let parse_toplevel : *) let[@coq_axiom_with_reason "gadt"] rec parse_data : ->>>>>>> master type a ac. ?type_logger:type_logger -> stack_depth:int -> @@ -2813,11 +2359,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : if Compare.Int.(stack_depth > 10_000) then fail Typechecking_too_many_recursive_calls else -<<<<<<< HEAD - parse_data_aux -======= parse_data ->>>>>>> master ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -2945,13 +2487,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : |> traced >|=? fun (_, map, ctxt) -> (map, ctxt) in -<<<<<<< HEAD match[@coq_match_gadt_with_result] (ty, script_data) with - | (Unit_t, expr) -> -======= - match (ty, script_data) with | Unit_t, expr -> ->>>>>>> master Lwt.return @@ traced_no_lwt @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) | Bool_t, expr -> Lwt.return @@ traced_no_lwt @@ parse_bool ctxt ~legacy expr @@ -2978,11 +2515,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : traced ( parse_address ctxt expr >>?= fun (address, ctxt) -> let loc = location expr in -<<<<<<< HEAD - parse_contract_aux -======= parse_contract_data ->>>>>>> master ~stack_depth:(stack_depth + 1) ctxt loc @@ -3021,14 +2554,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : ta tr script_instr -<<<<<<< HEAD - | (Lambda_t _, expr) -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) - (Invalid_kind (location expr, [Seq_kind], kind expr)) -======= | Lambda_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) ->>>>>>> master + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) | Option_t (t, _, _), expr -> let parse_v ctxt v = @@ -3044,14 +2571,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|=? fun (v, ctxt) -> (Script_list.cons v rest, ctxt)) items (Script_list.empty, ctxt) -<<<<<<< HEAD - | (List_t _, expr) -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) - (Invalid_kind (location expr, [Seq_kind], kind expr)) -======= | List_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) ->>>>>>> master + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Tickets *) | Ticket_t (t, _ty_name), expr -> if allow_forged then @@ -3059,17 +2580,9 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : non_terminal_recursion ?type_logger ctxt ~legacy ty expr >>=? fun (({destination; entrypoint = _}, (contents, amount)), ctxt) -> match destination with -<<<<<<< HEAD - | Contract ticketer -> - return - ( {ticketer; contents = contents [@coq_type_annotation]; amount}, - ctxt ) - | Tx_rollup _ -> fail (Unexpected_ticket_owner destination) -======= - | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) + | Contract ticketer -> return ({ticketer; contents [@coq_type_annotation]; amount}, ctxt) | Tx_rollup _ | Sc_rollup _ -> fail (Unexpected_ticket_owner destination) ->>>>>>> master else traced_fail (Unexpected_forged_value (location expr)) (* Sets *) | Set_t (t, _ty_name), (Seq (loc, vs) as expr) -> @@ -3103,35 +2616,14 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : (None, Script_set.empty t, ctxt) vs >|=? fun (_, set, ctxt) -> (set, ctxt) -<<<<<<< HEAD - | (Set_t _, expr) -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) - (Invalid_kind (location expr, [Seq_kind], kind expr)) - (* Maps *) - | (Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr)) -> - ((parse_items [@coq_type_annotation]) - ?type_logger - ctxt - expr - tk - tv - vs - (fun x -> x) - : (_ map * _) tzresult Lwt.t) - | (Map_t _, expr) -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) - (Invalid_kind (location expr, [Seq_kind], kind expr)) - | (Big_map_t (tk, tv, _ty_name), expr) -> -======= | Set_t _, expr -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Maps *) | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) -> - parse_items ?type_logger ctxt expr tk tv vs (fun x -> x) + (parse_items [@coq_type_annotation]) ?type_logger ctxt expr tk tv vs (fun x -> x) | Map_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Seq_kind], kind expr)) | Big_map_t (tk, tv, _ty_name), expr -> ->>>>>>> master (match expr with | Int (loc, id) -> return @@ -3193,30 +2685,16 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : match Script_bls.G1.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) -<<<<<<< HEAD - | (Bls12_381_g1_t, expr) -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) - (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | (Bls12_381_g2_t, Bytes (_, bs)) -> ( -======= | Bls12_381_g1_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Bls12_381_g2_t, Bytes (_, bs) -> ( ->>>>>>> master Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt -> match Script_bls.G2.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) -<<<<<<< HEAD - | (Bls12_381_g2_t, expr) -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) - (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | (Bls12_381_fr_t, Bytes (_, bs)) -> ( -======= | Bls12_381_g2_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Bls12_381_fr_t, Bytes (_, bs) -> ( ->>>>>>> master Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> match Script_bls.Fr.of_bytes_opt bs with | Some pt -> return (pt, ctxt) @@ -3224,14 +2702,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Bls12_381_fr_t, Int (_, v) -> Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> return (Script_bls.Fr.of_z v, ctxt) -<<<<<<< HEAD - | (Bls12_381_fr_t, expr) -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) - (Invalid_kind (location expr, [Bytes_kind], kind expr)) -======= | Bls12_381_fr_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) ->>>>>>> master + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) (* /!\ When adding new lazy storage kinds, you may want to guard the parsing of identifiers with [allow_forged]. @@ -3252,16 +2724,9 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : transac_memo_size >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) -<<<<<<< HEAD - | (Sapling_transaction_t _, expr) -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) - (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | (Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes)) -> ( -======= | Sapling_transaction_t _, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes) -> ( ->>>>>>> master match Data_encoding.Binary.of_bytes_opt Sapling.Legacy.transaction_encoding @@ -3278,16 +2743,9 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : transac_memo_size >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) -<<<<<<< HEAD - | (Sapling_transaction_deprecated_t _, expr) -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) - (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | (Sapling_state_t memo_size, Int (loc, id)) -> -======= | Sapling_transaction_deprecated_t _, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Sapling_state_t memo_size, Int (loc, id) -> ->>>>>>> master if allow_forged then let id = Sapling.Id.parse_z id in Sapling.state_from_id ctxt id >>=? fun (state, ctxt) -> @@ -3299,16 +2757,10 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : state.Sapling.memo_size >|? fun () -> (state, ctxt) ) else traced_fail (Unexpected_forged_value loc) -<<<<<<< HEAD - | (Sapling_state_t memo_size, Seq (_, [])) -> + | Sapling_state_t memo_size, Seq (_, []) -> ((return [@coq_type_annotation]) (Sapling.empty_state ~memo_size (), ctxt) : (Sapling.state * _) tzresult Lwt.t) - | (Sapling_state_t _, expr) -> -======= - | Sapling_state_t memo_size, Seq (_, []) -> - return (Sapling.empty_state ~memo_size (), ctxt) | Sapling_state_t _, expr -> ->>>>>>> master (* Do not allow to input diffs as they are untrusted and may not be the result of a verify_update. *) (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) @@ -3323,16 +2775,10 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : with | Some chest_key -> return (chest_key, ctxt) | None -> fail_parse_data ()) -<<<<<<< HEAD - | (Chest_key_t, expr) -> + | Chest_key_t, expr -> (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) - | (Chest_t, Bytes (_, bytes)) -> ( -======= - | Chest_key_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Chest_t, Bytes (_, bytes) -> ( ->>>>>>> master Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) >>?= fun ctxt -> match @@ -3340,18 +2786,10 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : with | Some chest -> return (chest, ctxt) | None -> fail_parse_data ()) -<<<<<<< HEAD - | (Chest_t, expr) -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) - (Invalid_kind (location expr, [Bytes_kind], kind expr)) - -and[@coq_struct "ctxt"] parse_view_returning : -======= | Chest_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) -and parse_view : ->>>>>>> master +and[@coq_struct "ctxt"] parse_view : type storage storagec. ?type_logger:type_logger -> context -> @@ -3373,15 +2811,9 @@ and parse_view : Ill_formed_type (Some "return of view", strip_locations output_ty, output_ty_loc)) (parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty) -<<<<<<< HEAD - >>?= fun (Ex_ty output_ty', ctxt) -> - pair_t input_ty_loc input_ty' storage_type >>?= fun (Ty_ex_c pair_ty) -> - parse_instr_aux -======= >>?= fun (Ex_ty output_ty, ctxt) -> pair_t input_ty_loc input_ty storage_type >>?= fun (Ty_ex_c pair_ty) -> parse_instr ->>>>>>> master ?type_logger ~stack_depth:0 Tc_context.view @@ -3421,11 +2853,7 @@ and parse_view : ctxt ) | _ -> error (ill_type_view aft loc)) -<<<<<<< HEAD -and[@coq_struct "ctxt"] typecheck_views : -======= and parse_views : ->>>>>>> master type storage storagec. ?type_logger:type_logger -> context -> @@ -3686,13 +3114,8 @@ and[@coq_struct "ctxt"] parse_instr_aux : check_var_type_annot loc annot >>?= fun () -> let cons_some = {apply = (fun kinfo k -> ICons_some (kinfo, k))} in option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest)) -<<<<<<< HEAD - | (Prim (loc, I_NONE, [t], annot), stack) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t -======= | Prim (loc, I_NONE, [t], annot), stack -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t ->>>>>>> master >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let cons_none = {apply = (fun kinfo k -> ICons_none (kinfo, k))} in @@ -3857,26 +3280,16 @@ and[@coq_struct "ctxt"] parse_instr_aux : let cdr = {apply = (fun kinfo k -> ICdr (kinfo, k))} in typed ctxt loc cdr (Item_t (b, rest)) (* unions *) -<<<<<<< HEAD - | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest)) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tr -======= | Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr ->>>>>>> master >>?= fun (Ex_ty tr, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_left = {apply = (fun kinfo k -> ICons_left (kinfo, k))} in union_t loc tl tr >>?= fun (Ty_ex_c ty) -> let stack_ty = Item_t (ty, rest) in typed ctxt loc cons_left stack_ty -<<<<<<< HEAD - | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest)) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tl -======= | Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest) -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl ->>>>>>> master >>?= fun (Ex_ty tl, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_right = {apply = (fun kinfo k -> ICons_right (kinfo, k))} in @@ -3920,13 +3333,8 @@ and[@coq_struct "ctxt"] parse_instr_aux : in Lwt.return @@ merge_branches ctxt loc btr bfr {branch} (* lists *) -<<<<<<< HEAD - | (Prim (loc, I_NIL, [t], annot), stack) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t -======= | Prim (loc, I_NIL, [t], annot), stack -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t ->>>>>>> master >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let nil = {apply = (fun kinfo k -> INil (kinfo, k))} in @@ -4046,13 +3454,8 @@ and[@coq_struct "ctxt"] parse_instr_aux : | Failed {descr} -> typed_no_lwt ctxt loc (mk_list_iter (descr rest)) rest ) (* sets *) -<<<<<<< HEAD - | (Prim (loc, I_EMPTY_SET, [t], annot), rest) -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t -======= | Prim (loc, I_EMPTY_SET, [t], annot), rest -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t ->>>>>>> master >>?= fun (Ex_comparable_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_set (kinfo, t, k))} in @@ -4111,13 +3514,8 @@ and[@coq_struct "ctxt"] parse_instr_aux : let instr = {apply = (fun kinfo k -> ISet_size (kinfo, k))} in typed ctxt loc instr (Item_t (nat_t, rest)) (* maps *) -<<<<<<< HEAD - | (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk -======= | Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk ->>>>>>> master >>?= fun (Ex_comparable_ty tk, ctxt) -> parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> @@ -4242,13 +3640,8 @@ and[@coq_struct "ctxt"] parse_instr_aux : let instr = {apply = (fun kinfo k -> IMap_size (kinfo, k))} in typed ctxt loc instr (Item_t (nat_t, rest)) (* big_map *) -<<<<<<< HEAD - | (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk -======= | Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk ->>>>>>> master >>?= fun (Ex_comparable_ty tk, ctxt) -> parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> @@ -4486,13 +3879,8 @@ and[@coq_struct "ctxt"] parse_instr_aux : in let stack = Item_t (tr, rest) in typed_no_lwt ctxt loc instr stack) -<<<<<<< HEAD - | (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy arg -======= | Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg ->>>>>>> master >>?= fun (Ex_ty arg, ctxt) -> parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ret >>?= fun (Ex_ty ret, ctxt) -> @@ -4962,13 +4350,8 @@ and[@coq_struct "ctxt"] parse_instr_aux : let instr = {apply = (fun kinfo k -> IPack (kinfo, t, k))} in let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack -<<<<<<< HEAD - | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest)) -> - parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty -======= | Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest) -> parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty ->>>>>>> master >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> option_t loc t >>?= fun res_ty -> @@ -4981,13 +4364,8 @@ and[@coq_struct "ctxt"] parse_instr_aux : let instr = {apply = (fun kinfo k -> IAddress (kinfo, k))} in let stack = Item_t (address_t, rest) in typed ctxt loc instr stack -<<<<<<< HEAD - | (Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest)) -> - parse_passable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty -======= | Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest) -> parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty ->>>>>>> master >>?= fun (Ex_ty t, ctxt) -> contract_t loc t >>?= fun contract_ty -> option_t loc contract_ty >>?= fun res_ty -> @@ -5180,19 +4558,11 @@ and[@coq_struct "ctxt"] parse_instr_aux : (Forbidden_instr_in_context (loc, Script_tc_errors.View, prim)) | Toplevel {param_type; entrypoints; storage_type = _} -> Gas_monad.run ctxt -<<<<<<< HEAD @@ (find_entrypoint - ~error_details:Informative - param_type - entrypoints - entrypoint [@coq_type_annotation]) -======= - @@ find_entrypoint ~error_details:(Informative ()) param_type entrypoints - entrypoint ->>>>>>> master + entrypoint [@coq_type_annotation]) >>? fun (r, ctxt) -> r >>? fun (Ex_ty_cstr {ty = param_type; _}) -> contract_t loc param_type >>? fun res_ty -> @@ -5573,11 +4943,7 @@ and[@coq_struct "ctxt"] parse_instr_aux : I_XOR; ] -<<<<<<< HEAD -and[@coq_mutual_as_notation] parse_contract_aux : -======= and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract_data : ->>>>>>> master type arg argc. stack_depth:int -> context -> @@ -5649,39 +5015,6 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra (Invalid_contract (loc, contract)) ( Contract.get_script_code ctxt contract >>=? fun (ctxt, code) -> Lwt.return -<<<<<<< HEAD - ( Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - code - >>? fun (code, ctxt) -> - (* can only fail because of gas *) - parse_toplevel_aux ctxt ~legacy:true code - >>? fun ({arg_type; _}, ctxt) -> - parse_parameter_ty_and_entrypoints_aux - ctxt - ~stack_depth:(stack_depth + 1) - ~legacy:true - arg_type - >>? fun [@coq_match_gadt] ( Ex_parameter_ty_and_entrypoints - {arg_type = targ; entrypoints}, - ctxt ) -> - (* we don't check targ size here because it's a legacy contract code *) - Gas_monad.run ctxt - @@ (find_entrypoint_for_type - [@coq_implicit - "full" "__Ex_parameter_ty_and_entrypoints_'a1"]) - ~error_details:Informative - ~full:targ - ~expected:arg - entrypoints - entrypoint - loc - >>? fun (entrypoint_arg, ctxt) -> - entrypoint_arg >|? fun (entrypoint, arg_ty) -> - let address = {destination; entrypoint} in - (ctxt, Typed_contract {arg_ty; address}) ))) -======= (match code with | None -> ok @@ -5704,7 +5037,9 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra {arg_type = targ; entrypoints}, ctxt ) -> Gas_monad.run ctxt - @@ find_entrypoint_for_type + @@ (find_entrypoint_for_type + [@coq_implicit + "full" "__Ex_parameter_ty_and_entrypoints_'a1"]) ~error_details ~full:targ ~expected:arg @@ -5715,7 +5050,6 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra entrypoint_arg >|? fun (entrypoint, arg_ty) -> let address = {destination; entrypoint} in Typed_contract {arg_ty; address} )) )) ->>>>>>> master | Tx_rollup tx_rollup -> Tx_rollup_state.assert_exist ctxt tx_rollup >|=? fun ctxt -> if Entrypoint.(entrypoint = Tx_rollup.deposit_entrypoint) then @@ -5726,73 +5060,6 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra let address = {destination; entrypoint} in (ctxt, ok @@ Typed_contract {arg_ty = arg; address}) | _ -> -<<<<<<< HEAD - fail - @@ Tx_rollup_bad_deposit_parameter (loc, serialize_ty_for_error arg) - else fail (No_such_entrypoint entrypoint) - -and[@coq_struct "ctxt"] parse_view_name ctxt : - Script.node -> (Script_string.t * context) tzresult = function - | String (loc, v) as expr -> - (* The limitation of length of string is same as entrypoint *) - if Compare.Int.(String.length v > 31) then error (View_name_too_long v) - else - let rec check_char i = - if Compare.Int.(i < 0) then ok v - else if Script_ir_annot.is_allowed_char v.[i] then check_char (i - 1) - else error (Bad_view_name loc) - in - Gas.consume ctxt (Typecheck_costs.check_printable v) >>? fun ctxt -> - record_trace - (Invalid_syntactic_constant - ( loc, - strip_locations expr, - "string [a-zA-Z0-9_.%@] and the maximum string length of 31 \ - characters" )) - ( check_char (String.length v - 1) >>? fun v -> - Script_string.of_string v >|? fun s -> (s, ctxt) ) - | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr) - -and[@coq_struct "ctxt"] parse_toplevel_aux : - context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult = - fun ctxt ~legacy toplevel -> - record_trace (Ill_typed_contract (toplevel, [])) - @@ - match root toplevel with - | Int (loc, _) -> error (Invalid_kind (loc, [Seq_kind], Int_kind)) - | String (loc, _) -> error (Invalid_kind (loc, [Seq_kind], String_kind)) - | Bytes (loc, _) -> error (Invalid_kind (loc, [Seq_kind], Bytes_kind)) - | Prim (loc, _, _, _) -> error (Invalid_kind (loc, [Seq_kind], Prim_kind)) - | Seq (_, fields) -> ( - let rec find_fields ctxt p s c views fields = - match fields with - | [] -> ok (ctxt, (p, s, c, views)) - | Int (loc, _) :: _ -> error (Invalid_kind (loc, [Prim_kind], Int_kind)) - | String (loc, _) :: _ -> - error (Invalid_kind (loc, [Prim_kind], String_kind)) - | Bytes (loc, _) :: _ -> - error (Invalid_kind (loc, [Prim_kind], Bytes_kind)) - | Seq (loc, _) :: _ -> error (Invalid_kind (loc, [Prim_kind], Seq_kind)) - | Prim (loc, K_parameter, [arg], annot) :: rest -> ( - match p with - | None -> find_fields ctxt (Some (arg, loc, annot)) s c views rest - | Some _ -> error (Duplicate_field (loc, K_parameter))) - | Prim (loc, K_storage, [arg], annot) :: rest -> ( - match s with - | None -> find_fields ctxt p (Some (arg, loc, annot)) c views rest - | Some _ -> error (Duplicate_field (loc, K_storage))) - | Prim (loc, K_code, [arg], annot) :: rest -> ( - match c with - | None -> find_fields ctxt p s (Some (arg, loc, annot)) views rest - | Some _ -> error (Duplicate_field (loc, K_code))) - | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _) :: _ - -> - error (Invalid_arity (loc, name, 1, List.length args)) - | Prim (loc, K_view, [name; input_ty; output_ty; view_code], _) :: rest - -> - parse_view_name ctxt name >>? fun (str, ctxt) -> - Gas.consume -======= error ctxt (fun loc -> Tx_rollup_bad_deposit_parameter (loc, serialize_ty_for_error arg)) else error ctxt (fun _loc -> No_such_entrypoint entrypoint) @@ -5808,7 +5075,6 @@ and[@coq_struct "ctxt"] parse_toplevel_aux : | Some parameters_type -> Script.force_decode_in_context ~consume_deserialization_gas:When_needed ->>>>>>> master ctxt parameters_type >>? fun (parameters_type, ctxt) -> @@ -5845,94 +5111,6 @@ let parse_contract_for_script : Destination.t -> entrypoint:Entrypoint.t -> (context * arg typed_contract option) tzresult Lwt.t = -<<<<<<< HEAD - fun ctxt loc arg contract ~entrypoint -> - match contract with - | Contract contract -> ( - match Contract.is_implicit contract with - | Some _ -> - if Entrypoint.is_default entrypoint then - (* An implicit account on the "default" entrypoint always exists and has type unit. *) - Lwt.return - ( Gas_monad.run ctxt @@ ty_eq ~error_details:Fast loc arg unit_t - >|? fun (eq, ctxt) -> - match eq with - | Ok Eq -> - let destination : Destination.t = Contract contract in - let address = {destination; entrypoint} in - let contract = Typed_contract {arg_ty = arg; address} in - (ctxt, Some contract) - | Error Inconsistent_types_fast -> (ctxt, None) ) - else - Lwt.return - ( Gas.consume ctxt Typecheck_costs.parse_instr_cycle - >|? fun ctxt -> - (* An implicit account on any other entrypoint is not a valid contract. *) - (ctxt, None) ) - | None -> ( - (* Originated account *) - trace (Invalid_contract (loc, contract)) - @@ Contract.get_script_code ctxt contract - >>=? fun (ctxt, code) -> - match code with - | None -> return (ctxt, None) - | Some code -> - Lwt.return - ( Script.force_decode_in_context - ~consume_deserialization_gas:When_needed - ctxt - code - >>? fun (code, ctxt) -> - (* can only fail because of gas *) - match parse_toplevel_aux ctxt ~legacy:true code with - | Error _ -> error (Invalid_contract (loc, contract)) - | Ok ({arg_type; _}, ctxt) -> ( - match[@coq_match_gadt] - parse_parameter_ty_and_entrypoints_aux - ctxt - ~stack_depth:0 - ~legacy:true - arg_type - with - | Error _ -> error (Invalid_contract (loc, contract)) - | Ok - ( Ex_parameter_ty_and_entrypoints - {arg_type = targ; entrypoints}, - ctxt ) -> ( - (* we don't check targ size here because it's a legacy contract code *) - Gas_monad.run ctxt - @@ (find_entrypoint_for_type - [@coq_implicit - "full" "__Ex_parameter_ty_and_entrypoints_'a"]) - ~error_details:Fast - ~full:targ - ~expected:arg - entrypoints - entrypoint - loc - >|? fun (entrypoint_arg, ctxt) -> - match entrypoint_arg with - | Ok (entrypoint, arg_ty) -> - let destination = Destination.Contract contract in - let address = {destination; entrypoint} in - let contract = Typed_contract {arg_ty; address} in - (ctxt, Some contract) - | Error Inconsistent_types_fast -> (ctxt, None))) ))) - | Tx_rollup tx_rollup -> ( - (* /!\ This pattern matching needs to remain in sync with - [parse_contract_for_script] and - [parse_tx_rollup_deposit_parameters]. *) - match arg with - | Pair_t (Ticket_t (_, _), Tx_rollup_l2_address_t, _, _) - when Entrypoint.( - entrypoint = Alpha_context.Tx_rollup.deposit_entrypoint) -> ( - Tx_rollup_state.find ctxt tx_rollup >|=? function - | (ctxt, Some _) -> - let address = {destination = contract; entrypoint} in - (ctxt, Some (Typed_contract {arg_ty = arg; address})) - | (ctxt, None) -> (ctxt, None)) - | _ -> return (ctxt, None)) -======= fun ctxt loc arg destination ~entrypoint -> parse_contract ~stack_depth:0 @@ -5945,7 +5123,6 @@ let parse_contract_for_script : >|=? fun (ctxt, res) -> ( ctxt, match res with Ok res -> Some res | Error Inconsistent_types_fast -> None ) ->>>>>>> master let view_size view = let open Script_typed_ir_size in @@ -6211,17 +5388,7 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) (* -- Unparsing data of any type -- *) -<<<<<<< HEAD -let comb_witness2 : - type t tc. (t, tc) ty -> (t, unit -> unit -> unit) comb_witness = function - | Pair_t (_, Pair_t _, _, _) -> Comb_Pair (Comb_Pair Comb_Any) - | Pair_t _ -> Comb_Pair Comb_Any - | _ -> Comb_Any - -let[@coq_struct "ctxt"] rec unparse_data_aux : -======= let[@coq_axiom_with_reason "gadt"] rec unparse_data : ->>>>>>> master type a ac. context -> stack_depth:int -> @@ -6237,42 +5404,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : else unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode ty a in let loc = Micheline.dummy_location in -<<<<<<< HEAD match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with - | (Unit_t, (v : unit)) -> Lwt.return @@ unparse_unit ~loc ctxt v - | (Int_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_int ~loc ctxt v - | (Nat_t, (v : _ Script_int.num)) -> Lwt.return @@ unparse_nat ~loc ctxt v - | (String_t, (s : Script_string.t)) -> - Lwt.return @@ unparse_string ~loc ctxt s - | (Bytes_t, (s : bytes)) -> Lwt.return @@ unparse_bytes ~loc ctxt s - | (Bool_t, (b : bool)) -> Lwt.return @@ unparse_bool ~loc ctxt b - | (Timestamp_t, (t : Script_timestamp.t)) -> - Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | (Address_t, (address : address)) -> - Lwt.return @@ unparse_address ~loc ctxt mode address - | (Tx_rollup_l2_address_t, (address : tx_rollup_l2_address)) -> - Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | (Contract_t _, (contract : _ typed_contract)) -> - Lwt.return @@ unparse_contract ~loc ctxt mode contract - | (Signature_t, (s : signature)) -> - Lwt.return @@ unparse_signature ~loc ctxt mode s - | (Mutez_t, (v : Tez_repr.t)) -> Lwt.return @@ unparse_mutez ~loc ctxt v - | (Key_t, (k : public_key)) -> Lwt.return @@ unparse_key ~loc ctxt mode k - | (Key_hash_t, (k : public_key_hash)) -> - Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | (Operation_t, (operation : operation)) -> - Lwt.return @@ unparse_operation ~loc ctxt operation - | (Chain_id_t, (chain_id : Script_chain_id.t)) -> - Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | (Bls12_381_g1_t, (x : Script_bls.G1.t)) -> - Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x - | (Bls12_381_g2_t, (x : Script_bls.G2.t)) -> - Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x - | (Bls12_381_fr_t, (x : Script_bls.Fr.t)) -> - Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x - | (Pair_t (tl, tr, _, _), (pair : _ * _)) -> -======= - match (ty, a) with | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v @@ -6297,21 +5429,10 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : | Bls12_381_g2_t, x -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x | Bls12_381_fr_t, x -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x | Pair_t (tl, tr, _, _), pair -> ->>>>>>> master let r_witness = comb_witness2 tr in let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair -<<<<<<< HEAD - | (Union_t (tl, tr, _, _), (v : _ union)) -> - let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in - let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in - unparse_union ~loc unparse_l unparse_r ctxt v - | (Option_t (t, _, _), (v : _ option)) -> - let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in - unparse_option ~loc unparse_v ctxt v - | (List_t (t, _), (items : _ boxed_list)) -> -======= | Union_t (tl, tr, _, _), v -> let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in @@ -6320,7 +5441,6 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in unparse_option ~loc unparse_v ctxt v | List_t (t, _), items -> ->>>>>>> master List.fold_left_es (fun (l, ctxt) element -> non_terminal_recursion ctxt mode t element @@ -6328,12 +5448,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ([], ctxt) items.elements >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) -<<<<<<< HEAD - | (Ticket_t (t, _), (x : _ ticket)) -> - let {ticketer; contents; amount} = x in -======= | Ticket_t (t, _), {ticketer; contents; amount} -> ->>>>>>> master (* ideally we would like to allow a little overhead here because it is only used for unparsing *) opened_ticket_type loc t >>?= fun t -> let destination : Destination.t = Contract ticketer in @@ -6344,11 +5459,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : mode t (addr, (contents, amount)) -<<<<<<< HEAD - | (Set_t (t, _), (set : _ set)) -> -======= | Set_t (t, _), set -> ->>>>>>> master List.fold_left_es (fun (l, ctxt) item -> unparse_comparable_data ~loc ctxt mode t item >|=? fun (item, ctxt) -> @@ -6356,76 +5467,6 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ([], ctxt) (Script_set.fold (fun e acc -> e :: acc) set []) >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) -<<<<<<< HEAD - | (Map_t (kt, vt, _), (map : _ map)) -> - let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | (Big_map_t (kt, vt, _), (x : _ big_map)) -> ( - match[@coq_match_gadt] x with - | Big_map {id; diff = {map; size; _}; _} -> ( - match id with - | Some id -> - if Compare.Int.( = ) size 0 then - return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) - else - let items = - Big_map_overlay.fold - (fun _ (k, v) acc -> (k, v) :: acc) - map - [] - in - let items = - (* Sort the items in Michelson comparison order and not in key - hash order. This code path is only exercised for tracing, - so we don't bother carbonating this sort operation - precisely. Also, the sort uses a reverse compare because - [unparse_items] will reverse the result. *) - List.sort - (fun (a, _) (b, _) -> - Script_comparable.compare_comparable kt b a) - items - in - (* this can't fail if the original type is well-formed - because [option vt] is always strictly smaller than [big_map kt vt] *) - option_t loc vt >>?= fun vt -> - unparse_items - ctxt - ~stack_depth:(stack_depth + 1) - mode - kt - vt - items - >|=? fun (items, ctxt) -> - ( Micheline.Prim - ( loc, - D_Pair, - [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], - [] ), - ctxt ) - | None -> - let items = - Big_map_overlay.fold - (fun _ (k, v) acc -> - match v with None -> acc | Some v -> (k, v) :: acc) - map - [] - in - let items = - (* See note above. *) - List.sort - (fun (a, _) (b, _) -> - Script_comparable.compare_comparable kt b a) - items - in - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt))) - | (Lambda_t _, (x : _ lambda)) -> - let (Lam (_, original_code)) = x in - unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code - | (Never_t, _) -> . - | (Sapling_transaction_t _, (s : Sapling.transaction)) -> -======= | Map_t (kt, vt, _), map -> let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items @@ -6478,19 +5519,13 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code | Never_t, _ -> . | Sapling_transaction_t _, s -> ->>>>>>> master Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) >|? fun ctxt -> let bytes = Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s in (Bytes (loc, bytes), ctxt) ) -<<<<<<< HEAD - | (Sapling_transaction_deprecated_t _, (s : Sapling_repr.legacy_transaction)) - -> -======= | Sapling_transaction_deprecated_t _, s -> ->>>>>>> master Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) >|? fun ctxt -> @@ -6500,12 +5535,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : s in (Bytes (loc, bytes), ctxt) ) -<<<<<<< HEAD - | (Sapling_state_t _, (x : Sapling.state)) -> - let {Sapling.id; diff; _} = x in -======= | Sapling_state_t _, {id; diff; _} -> ->>>>>>> master Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> ( (match diff with @@ -6527,22 +5557,14 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : Micheline.Prim (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), ctxt ) ) -<<<<<<< HEAD - | (Chest_key_t, (s : Script_timelock.chest_key)) -> -======= | Chest_key_t, s -> ->>>>>>> master unparse_with_data_encoding ~loc ctxt s Unparse_costs.chest_key Script_timelock.chest_key_encoding -<<<<<<< HEAD - | (Chest_t, (s : Script_timelock.chest)) -> -======= | Chest_t, s -> ->>>>>>> master unparse_with_data_encoding ~loc ctxt @@ -6736,78 +5758,6 @@ let hash_data ctxt ty data = let pack_data ctxt ty data = pack_data_with_mode ctxt ty data ~mode:Optimized_legacy -<<<<<<< HEAD -(* ---------------- Big map -------------------------------------------------*) - -let empty_big_map key_type value_type : ('a, 'b) big_map = - Big_map - { - id = None; - diff = {map = Big_map_overlay.empty; size = 0} [@coq_type_annotation]; - key_type; - value_type; - } - -let big_map_mem ctxt key (Big_map {id; diff; key_type; _}) = - hash_comparable_data ctxt key_type key >>=? fun (key, ctxt) -> - match (Big_map_overlay.find key diff.map, id) with - | (None, None) -> return (false, ctxt) - | (None, Some id) -> - Alpha_context.Big_map.mem ctxt id key >|=? fun (ctxt, res) -> (res, ctxt) - | (Some (_, None), _) -> return (false, ctxt) - | (Some (_, Some _), _) -> return (true, ctxt) - -let big_map_get_by_hash ctxt key big_map = - match[@coq_match_gadt] big_map with - | Big_map {id; diff; value_type; _} -> ( - match (Big_map_overlay.find key diff.map, id) with - | (Some (_, x), _) -> return (x, ctxt) - | (None, None) -> return (None, ctxt) - | (None, Some id) -> ( - Alpha_context.Big_map.get_opt ctxt id key >>=? function - | (ctxt, None) -> return (None, ctxt) - | (ctxt, Some value) -> - parse_data_aux - ~stack_depth:0 - ctxt - ~legacy:true - ~allow_forged:true - value_type - (Micheline.root value) - >|=? fun (x, ctxt) -> (Some x, ctxt))) - -let big_map_get ctxt key (Big_map {key_type; _} as map) = - hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - (big_map_get_by_hash [@coq_implicit "B" "A"]) ctxt key_hash map - -let big_map_update_by_hash ctxt key_hash key value map = - match[@coq_match_gadt] map with - | Big_map map -> - let contains = Big_map_overlay.mem key_hash map.diff.map in - return - ( Big_map - { - map with - diff = - { - map = Big_map_overlay.add key_hash (key, value) map.diff.map; - size = (if contains then map.diff.size else map.diff.size + 1); - }; - }, - ctxt ) - -let big_map_update ctxt key value (Big_map {key_type; _} as map) = - hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - big_map_update_by_hash ctxt key_hash key value map - -let big_map_get_and_update ctxt key value (Big_map {key_type; _} as map) = - hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - big_map_update_by_hash ctxt key_hash key value map >>=? fun (map', ctxt) -> - (big_map_get_by_hash [@coq_implicit "B" "B"]) ctxt key_hash map - >>=? fun (old_value, ctxt) -> return ((old_value, map'), ctxt) - -======= ->>>>>>> master (* ---------------- Lazy storage---------------------------------------------*) type lazy_storage_ids = Lazy_storage.IdSet.t @@ -6992,18 +5942,9 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t = fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> -<<<<<<< HEAD - match[@coq_match_gadt_with_result] [@coq_match_with_default] - (has_lazy_storage, ty, x) - with - | (False_f, _, _) -> - return (ctxt, x, ids_to_copy, acc) [@coq_type_annotation] - | (Big_map_f, Big_map_t (_, _, _), (map : _ big_map)) -> -======= - match (has_lazy_storage, ty, x) with - | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc) + match[@coq_match_gadt_with_result] [@coq_match_with_default] (has_lazy_storage, ty, x) with + | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc) [@coq_type_annotation] | Big_map_f, Big_map_t (_, _, _), map -> ->>>>>>> master diff_of_big_map ctxt mode ~temporary ~ids_to_copy map >|=? fun (diff, id, ctxt) -> let map = @@ -7018,11 +5959,7 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = let diff = Lazy_storage.make Big_map id diff in let ids_to_copy = Lazy_storage.IdSet.add Big_map id ids_to_copy in (ctxt, map, ids_to_copy, diff :: acc) -<<<<<<< HEAD - | (Sapling_state_f, Sapling_state_t _, (sapling_state : Sapling.state)) -> -======= | Sapling_state_f, Sapling_state_t _, sapling_state -> ->>>>>>> master diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state >|=? fun (diff, id, ctxt) -> let sapling_state = @@ -7031,54 +5968,12 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = let diff = Lazy_storage.make Sapling_state id diff in let ids_to_copy = Lazy_storage.IdSet.add Sapling_state id ids_to_copy in (ctxt, sapling_state, ids_to_copy, diff :: acc) -<<<<<<< HEAD - | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ * _)) -> - let (xl, xr) = x in -======= | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> ->>>>>>> master aux ctxt mode ~temporary ids_to_copy acc tyl xl ~has_lazy_storage:hl >>=? fun (ctxt, xl, ids_to_copy, acc) -> aux ctxt mode ~temporary ids_to_copy acc tyr xr ~has_lazy_storage:hr >|=? fun (ctxt, xr, ids_to_copy, acc) -> (ctxt, (xl, xr), ids_to_copy, acc) -<<<<<<< HEAD - | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), - Union_t (tyl, tyr, _, _), - (x : _ union) ) -> ( - match x with - | L x -> - aux - ctxt - mode - ~temporary - ids_to_copy - acc - tyl - x - ~has_lazy_storage:has_lazy_storage_l - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) - | R x -> - aux - ctxt - mode - ~temporary - ids_to_copy - acc - tyr - x - ~has_lazy_storage:has_lazy_storage_r - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) - ) - | (Option_f has_lazy_storage, Option_t (ty, _, _), (x : _ option)) -> ( - match x with - | Some x -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> - (ctxt, Some x, ids_to_copy, acc) - | None -> return (ctxt, None, ids_to_copy, acc)) - | (List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list)) -> -======= | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x -> aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) @@ -7089,7 +5984,6 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, Some x, ids_to_copy, acc) | List_f has_lazy_storage, List_t (ty, _), l -> ->>>>>>> master List.fold_left_es (fun (ctxt, l, ids_to_copy, acc) x -> aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage @@ -7100,11 +5994,7 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = >|=? fun (ctxt, l, ids_to_copy, acc) -> let reversed = {length = l.length; elements = List.rev l.elements} in (ctxt, reversed, ids_to_copy, acc) -<<<<<<< HEAD - | (Map_f has_lazy_storage, Map_t (_, ty, _), (map : _ map)) -> -======= | Map_f has_lazy_storage, Map_t (_, ty, _), map -> ->>>>>>> master let (module M) = Script_map.get_module map in let bindings m = M.OPS.fold (fun k v bs -> (k, v) :: bs) m [] in List.fold_left_es @@ -7136,10 +6026,7 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = and type value = M.value), ids_to_copy, acc ) -<<<<<<< HEAD -======= | _, Option_t (_, _, _), None -> return (ctxt, None, ids_to_copy, acc) ->>>>>>> master in let has_lazy_storage = has_lazy_storage ty in aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage @@ -7166,27 +6053,7 @@ let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : (('acc, error) Fold_lazy_storage.result * context) tzresult = fun ~f ~init ctxt ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> -<<<<<<< HEAD - match[@coq_match_gadt] [@coq_match_with_default] - (has_lazy_storage, ty, x) - with - | (Big_map_f, Big_map_t (_, _, _), (x : _ big_map)) -> ( - match x with - | Big_map {id = Some id; _} -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) - | Big_map {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) - | (Sapling_state_f, Sapling_state_t _, (x : Alpha_context.Sapling.state)) -> ( - match x with - | {id = Some id; _} -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) - | {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) - | (False_f, _, _) -> ok (Fold_lazy_storage.Ok init, ctxt) - | (Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ * _)) -> ( - let (xl, xr) = x in -======= - match (has_lazy_storage, ty, x) with + match[@coq_match_gadt] [@coq_match_with_default] (has_lazy_storage, ty, x) with | Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _} -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) @@ -7199,40 +6066,12 @@ let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : | Sapling_state_f, Sapling_state_t _, {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt) | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> ( ->>>>>>> master fold_lazy_storage ~f ~init ctxt tyl xl ~has_lazy_storage:hl >>? fun (init, ctxt) -> match init with | Fold_lazy_storage.Ok init -> fold_lazy_storage ~f ~init ctxt tyr xr ~has_lazy_storage:hr | Fold_lazy_storage.Error -> ok (init, ctxt)) -<<<<<<< HEAD - | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), - Union_t (tyl, tyr, _, _), - (x : _ union) ) -> ( - match x with - | L x -> - fold_lazy_storage - ~f - ~init - ctxt - tyl - x - ~has_lazy_storage:has_lazy_storage_l - | R x -> - fold_lazy_storage - ~f - ~init - ctxt - tyr - x - ~has_lazy_storage:has_lazy_storage_r) - | (Option_f has_lazy_storage, Option_t (ty, _, _), (o : _ option)) -> ( - match o with - | None -> ok (Fold_lazy_storage.Ok init, ctxt) - | Some x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage) - | (List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list)) -> -======= | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage | Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x -> @@ -7241,7 +6080,6 @@ let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : | Option_f has_lazy_storage, Option_t (ty, _, _), Some x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage | List_f has_lazy_storage, List_t (ty, _), l -> ->>>>>>> master List.fold_left_e (fun ((init, ctxt) : ('acc, error) Fold_lazy_storage.result * context) x -> match init with @@ -7250,11 +6088,7 @@ let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : | Fold_lazy_storage.Error -> ok (init, ctxt)) (Fold_lazy_storage.Ok init, ctxt) l.elements -<<<<<<< HEAD - | (Map_f has_lazy_storage, Map_t (_, ty, _), (m : _ map)) -> -======= | Map_f has_lazy_storage, Map_t (_, ty, _), m -> ->>>>>>> master Script_map.fold (fun _ v @@ -7341,13 +6175,8 @@ let unparse_code ctxt mode code = Global_constants_storage.expand ctxt (strip_locations code) >>=? fun (ctxt, code) -> unparse_code_aux ~stack_depth:0 ctxt mode (root code) -<<<<<<< HEAD -let parse_contract context loc arg_ty contract ~entrypoint = - parse_contract_aux ~stack_depth:0 context loc arg_ty contract ~entrypoint -======= let parse_contract_data context loc arg_ty contract ~entrypoint = parse_contract_data ~stack_depth:0 context loc arg_ty contract ~entrypoint ->>>>>>> master let parse_toplevel ctxt ~legacy toplevel = Global_constants_storage.expand ctxt toplevel >>=? fun (ctxt, toplevel) -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index fbb7713c2d05d..9c6780c014bcd 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -115,13 +115,6 @@ type ('arg, 'storage) code = type ex_code = Ex_code : ('a, 'c) code -> ex_code -<<<<<<< HEAD -type 'storage ex_view = - | Ex_view : - ('input * 'storage, 'output) Script_typed_ir.lambda - -> 'storage ex_view -[@@coq_force_gadt] -======= type 'storage typed_view = | Typed_view : { input_ty : ('input, _) Script_typed_ir.ty; @@ -135,10 +128,9 @@ type 'storage typed_view = original_code_expr : Script.node; } -> 'storage typed_view - +[@@coq_force_gadt] type 'storage typed_view_map = (Script_string.t, 'storage typed_view) Script_typed_ir.map ->>>>>>> master type ('a, 's, 'b, 'u) cinstr = { apply : -- GitLab From 06f469a154034d0dc85563f2a645caf78c423a70 Mon Sep 17 00:00:00 2001 From: emarzion Date: Sun, 19 Jun 2022 21:14:03 -0500 Subject: [PATCH 081/105] more work --- .../lib_protocol/alpha_context.mli | 29 +- src/proto_alpha/lib_protocol/apply.ml | 6 +- src/proto_alpha/lib_protocol/apply_results.ml | 1 - src/proto_alpha/lib_protocol/merkle_list.ml | 2 +- .../lib_protocol/operation_repr.ml | 78 +-- .../lib_protocol/operation_repr.mli | 136 +--- src/proto_alpha/lib_protocol/raw_context.ml | 4 +- .../lib_protocol/sc_rollup_arith.ml | 8 +- .../lib_protocol/sc_rollup_stake_storage.ml | 14 +- .../lib_protocol/sc_rollup_storage.ml | 15 + .../lib_protocol/sc_rollup_tick_repr.ml | 2 +- .../lib_protocol/script_comparable.ml | 15 +- .../lib_protocol/script_interpreter.ml | 31 +- .../lib_protocol/script_ir_translator.ml | 595 ++++++++---------- src/proto_alpha/lib_protocol/script_map.ml | 2 + .../lib_protocol/script_typed_ir_size.ml | 14 +- src/proto_alpha/lib_protocol/storage.ml | 2 +- .../lib_protocol/ticket_scanner.ml | 2 +- src/proto_alpha/lib_protocol/token.mli | 2 +- 19 files changed, 347 insertions(+), 611 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 367feb5acb4da..72c4b4bc9b065 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -3626,9 +3626,9 @@ module Operation : sig | Preendorsement of Chain_id.t | Dal_slot_availability of Chain_id.t - val to_watermark : Consensus_watermark.t -> Signature.watermark + val to_watermark : consensus_watermark -> Signature.watermark - val of_watermark : Signature.watermark -> Consensus_watermark.t option + val of_watermark : Signature.watermark -> consensus_watermark option val protocol_data_encoding : packed_protocol_data Data_encoding.t @@ -4030,12 +4030,12 @@ end (** See 'token.mli' for more explanation. *) module Token : sig type container = - | Contract of Contract.t + | Contract of Contract_repr.t | Collected_commitments of Blinded_public_key_hash.t | Delegate_balance of Signature.Public_key_hash.t | Frozen_deposits of Signature.Public_key_hash.t | Block_fees - | Frozen_bonds of Contract.t * Bond_id.t + | Frozen_bonds of Contract_repr.t * Bond_id_repr.t type infinite_source = | Invoice @@ -4051,27 +4051,18 @@ module Token : sig | Tx_rollup_rejection_rewards type source = - | Invoice - | Bootstrap - | Initial_commitments - | Revelation_rewards - | Double_signing_evidence_rewards - | Endorsing_rewards - | Baking_rewards - | Baking_bonuses - | Minted - | Liquidity_baking_subsidies - | Tx_rollup_rejection_rewards - | container + | Source_infinite of infinite_source + | Source_container of container - type sink = + type infinite_sink = | Storage_fees | Double_signing_punishments | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool - | Burned | Tx_rollup_rejection_punishments | Sc_rollup_refutation_punishments - | container + | Burned + + type sink = Sink_infinite of infinite_sink | Sink_container of container val allocated : context -> container -> (context * bool) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index e616febe510b4..1c4347be4c823 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -830,7 +830,7 @@ let apply_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~parameter (* If the implicit contract is not yet allocated at this point then the next transfer of tokens will allocate it. *) Contract.allocated ctxt contract >>= fun already_allocated -> - Token.transfer ctxt (`Contract source) (`Contract contract) amount + Token.transfer ctxt (Source_container (Contract source)) (Sink_container (assert false) (* (Contract contract) *)) amount >>=? fun (ctxt, balance_updates) -> let is_unit = match parameter with @@ -874,7 +874,7 @@ let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount does not exist, [Script_cache.find] will signal that by returning [None] and we'll fail. *) - Token.transfer ctxt (Source_container (Contract source)) (Sink_container (Contract contract)) amount + Token.transfer ctxt (Source_container (Contract source)) (Sink_container (assert false) (*(Contract contract)*)) amount >>=? fun (ctxt, balance_updates) -> Script_cache.find ctxt contract_hash >>=? fun (ctxt, cache_key, script) -> match script with @@ -891,7 +891,7 @@ let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount let step_constants = let open Script_interpreter in { - source; + (*source;*) source = assert false; payer = Contract.Implicit payer; self = contract_hash; amount; diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index af8ef88c287e5..37a8ff97898a7 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -2339,7 +2339,6 @@ let contents_and_result_list_encoding = | _ -> Error "cannot decode ill-formed combined operation result") in conv_with_guard to_list of_list (Variable.list contents_and_result_encoding) ->>>>>>> master type 'kind operation_metadata = {contents : 'kind contents_result_list} diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml index e26ffa080109a..f1ee3601e7d45 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.ml +++ b/src/proto_alpha/lib_protocol/merkle_list.ml @@ -282,7 +282,7 @@ struct match (tree, key) with | Leaf _, [] -> ok acc | Node (_, l, r), b :: key -> - if b then aux (root l :: acc) r key else aux (root r :: acc) l key + if b then aux (root_aux l :: acc) r key else aux (root_aux r :: acc) l key | _ -> error Merkle_list_invalid_position in aux List.nil tree key diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 75638c40970c0..62cf4e627d57a 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -199,7 +199,7 @@ type consensus_watermark = | Dal_slot_availability of Chain_id.t let bytes_of_consensus_watermark = function - | Consensus_watermark.Preendorsement chain_id -> + | Preendorsement chain_id -> Bytes.cat (Bytes.of_string "\x12") (Chain_id.to_bytes chain_id) | Endorsement chain_id -> Bytes.cat (Bytes.of_string "\x13") (Chain_id.to_bytes chain_id) @@ -214,11 +214,11 @@ let of_watermark = function match Bytes.get b 0 with | '\x12' -> Option.map - (fun chain_id -> Consensus_watermark.Endorsement chain_id) + (fun chain_id -> Endorsement chain_id) (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1))) | '\x13' -> Option.map - (fun chain_id -> Consensus_watermark.Preendorsement chain_id) + (fun chain_id -> Preendorsement chain_id) (Chain_id.of_bytes_opt (Bytes.sub b 1 (Bytes.length b - 1))) | '\x14' -> Option.map @@ -238,6 +238,8 @@ type origination = { credit : Tez_repr.tez; } +type counter = Z.t + type 'kind operation = { shell : Operation.shell_header; protocol_data : 'kind protocol_data; @@ -435,76 +437,6 @@ and _ manager_operation = } -> Kind.sc_rollup_recover_bond manager_operation -type counter = Z.t - -type 'kind operation = { - shell : Operation.shell_header; - protocol_data : 'kind protocol_data; -} - -and 'kind protocol_data = { - contents : 'kind contents_list; - signature : Signature.t option; -} - -and _ contents_list = - | Single : 'kind contents -> 'kind contents_list - | Cons : - 'kind Kind.manager contents * 'rest Kind.manager contents_list - -> ('kind * 'rest) Kind.manager contents_list - -and _ contents = - | Preendorsement : consensus_content -> Kind.preendorsement contents - | Endorsement : consensus_content -> Kind.endorsement contents - | Seed_nonce_revelation : { - level : Raw_level_repr.t; - nonce : Seed_repr.nonce; - } - -> Kind.seed_nonce_revelation contents - | Double_preendorsement_evidence : { - op1 : Kind.preendorsement operation; - op2 : Kind.preendorsement operation; - } - -> Kind.double_preendorsement_evidence contents - | Double_endorsement_evidence : { - op1 : Kind.endorsement operation; - op2 : Kind.endorsement operation; - } - -> Kind.double_endorsement_evidence contents - | Double_baking_evidence : { - bh1 : Block_header_repr.t; - bh2 : Block_header_repr.t; - } - -> Kind.double_baking_evidence contents - | Activate_account : { - id : Ed25519.Public_key_hash.t; - activation_code : Blinded_public_key_hash.activation_code; - } - -> Kind.activate_account contents - | Proposals : { - source : Signature.Public_key_hash.t; - period : int32; - proposals : Protocol_hash.t list; - } - -> Kind.proposals contents - | Ballot : { - source : Signature.Public_key_hash.t; - period : int32; - proposal : Protocol_hash.t; - ballot : Vote_repr.ballot; - } - -> Kind.ballot contents - | Failing_noop : string -> Kind.failing_noop contents - | Manager_operation : { - source : Signature.public_key_hash; - fee : Tez_repr.tez; - counter : counter; - operation : 'kind manager_operation; - gas_limit : Gas_limit_repr.Arith.integral; - storage_limit : Z.t; - } - -> 'kind Kind.manager contents - let manager_kind : type kind. kind manager_operation -> kind Kind.manager = function | Reveal _ -> Kind.Reveal_manager_kind diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index de1cbded437a3..44ec4ee11110a 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -199,9 +199,9 @@ type consensus_watermark = | Preendorsement of Chain_id.t | Dal_slot_availability of Chain_id.t -val to_watermark : Consensus_watermark.t -> Signature.watermark +val to_watermark : consensus_watermark -> Signature.watermark -val of_watermark : Signature.watermark -> Consensus_watermark.t option +val of_watermark : Signature.watermark -> consensus_watermark option type raw = Operation.t = {shell : Operation.shell_header; proto : bytes} @@ -213,120 +213,12 @@ type origination = { credit : Tez_repr.tez; } -(** An [operation] contains the operation header information in [shell] - and all data related to the operation itself in [protocol_data]. *) -type 'kind operation = { - shell : Operation.shell_header; - protocol_data : 'kind protocol_data; -} - -(** A [protocol_data] wraps together a signature for the operation and - the contents of the operation itself. *) -and 'kind protocol_data = { - contents : 'kind contents_list; - signature : Signature.t option; -} - -(** A [contents_list] is a list of contents, the GADT guarantees two - invariants: - - the list is not empty, and - - if the list has several elements then it only contains manager - operations. *) -and _ contents_list = - | Single : 'kind contents -> 'kind contents_list - | Cons : - 'kind Kind.manager contents * 'rest Kind.manager contents_list - -> ('kind * 'rest) Kind.manager contents_list - -(** A value of type [contents] an operation related to whether - consensus, governance or contract management. *) -and _ contents = - (* Preendorsement: About consensus, preendorsement of a block held by a - validator (specific to Tenderbake). *) - | Preendorsement : consensus_content -> Kind.preendorsement contents - (* Endorsement: About consensus, endorsement of a block held by a - validator. *) - | Endorsement : consensus_content -> Kind.endorsement contents - (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3115 - - Temporary operation to avoid modifying endorsement encoding. *) - | Dal_slot_availability : - Signature.Public_key_hash.t * Dal_endorsement_repr.t - -> Kind.dal_slot_availability contents - (* Seed_nonce_revelation: Nonces are created by bakers and are - combined to create pseudo-random seeds. Bakers are urged to reveal their - nonces after a given number of cycles to keep their block rewards - from being forfeited. *) - | Seed_nonce_revelation : { - level : Raw_level_repr.t; - nonce : Seed_repr.nonce; - } - -> Kind.seed_nonce_revelation contents - (* Double_preendorsement_evidence: Double-preendorsement is a - kind of malicious attack where a byzantine attempts to fork - the chain by preendorsing blocks with different - contents (at the same level and same round) - twice. This behavior may be reported and the byzantine will have - its security deposit forfeited. *) - | Double_preendorsement_evidence : { - op1 : Kind.preendorsement operation; - op2 : Kind.preendorsement operation; - } - -> Kind.double_preendorsement_evidence contents - (* Double_endorsement_evidence: Similar to double-preendorsement but - for endorsements. *) - | Double_endorsement_evidence : { - op1 : Kind.endorsement operation; - op2 : Kind.endorsement operation; - } - -> Kind.double_endorsement_evidence contents - (* Double_baking_evidence: Similarly to double-endorsement but the - byzantine attempts to fork by signing two different blocks at the - same level. *) - | Double_baking_evidence : { - bh1 : Block_header_repr.t; - bh2 : Block_header_repr.t; - } - -> Kind.double_baking_evidence contents - (* Activate_account: Account activation allows to register a public - key hash on the blockchain. *) - | Activate_account : { - id : Ed25519.Public_key_hash.t; - activation_code : Blinded_public_key_hash.activation_code; - } - -> Kind.activate_account contents - (* Proposals: A candidate protocol can be proposed for voting. *) - | Proposals : { - source : Signature.Public_key_hash.t; - period : int32; - proposals : Protocol_hash.t list; - } - -> Kind.proposals contents - (* Ballot: The validators of the chain will then vote on proposals. *) - | Ballot : { - source : Signature.Public_key_hash.t; - period : int32; - proposal : Protocol_hash.t; - ballot : Vote_repr.ballot; - } - -> Kind.ballot contents - (* Failing_noop: An operation never considered by the state machine - and which will always fail at [apply]. This allows end-users to - sign arbitrary messages which have no computational semantics. *) - | Failing_noop : string -> Kind.failing_noop contents - (* Manager_operation: Operations, emitted and signed by - a (revealed) implicit account, that describe management and - interactions between contracts (whether implicit or - smart). *) - | Manager_operation : { - source : Signature.Public_key_hash.t; - fee : Tez_repr.tez; - counter : counter; - operation : 'kind manager_operation; - gas_limit : Gas_limit_repr.Arith.integral; - storage_limit : Z.t; - } - -> 'kind Kind.manager contents +(** Counters are used as anti-replay protection mechanism in + manager operations: each manager account stores a counter and + each manager operation declares a value for the counter. When + a manager operation is applied, the value of the counter of + its manager is checked and incremented. *) +type counter = Z.t (** A [manager_operation] describes management and interactions between contracts (whether implicit or smart). *) @@ -508,12 +400,6 @@ type _ manager_operation = } -> Kind.sc_rollup_recover_bond manager_operation -(** Counters are used as anti-replay protection mechanism in - manager operations: each manager account stores a counter and - each manager operation declares a value for the counter. When - a manager operation is applied, the value of the counter of - its manager is checked and incremented. *) -type counter = Z.t (** An [operation] contains the operation header information in [shell] and all data related to the operation itself in [protocol_data]. *) @@ -549,6 +435,12 @@ and _ contents = (* Endorsement: About consensus, endorsement of a block held by a validator. *) | Endorsement : consensus_content -> Kind.endorsement contents + (* DAL/FIXME https://gitlab.com/tezos/tezos/-/issues/3115 + + Temporary operation to avoid modifying endorsement encoding. *) + | Dal_slot_availability : + Signature.Public_key_hash.t * Dal_endorsement_repr.t + -> Kind.dal_slot_availability contents (* Seed_nonce_revelation: Nonces are created by bakers and are combined to create pseudo-random seeds. Bakers are urged to reveal their nonces after a given number of cycles to keep their block rewards diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index 82828f40f9d65..8d18cdb66f499 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -1118,7 +1118,7 @@ let fold ?depth ctxt k ~order ~init ~f = let config ctxt = Context.config (context ctxt) -module Proof = Context.Proof +(* module Proof = Context.Proof *) let length ctxt key = Context.length (context ctxt) key @@ -1533,6 +1533,8 @@ module M : T with type t = root = struct let check_enough_gas = check_enough_gas let description : t Storage_description.t = description + + let length = length end module Dal = struct diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 8f5beae6343a1..4170587b47588 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -370,9 +370,7 @@ module Make (Context : P) : val name : string val encoding : t Data_encoding.t - end - - module MakeDeque (P : P_MakeDeque) = struct + end) = struct (* A stateful deque. @@ -458,9 +456,7 @@ module Make (Context : P) : include Sc_rollup_tick_repr let name = "tick" - end - - module CurrentTick = MakeVar (Tick_with_name) + end) module Vars = MakeDict (struct type t = int diff --git a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml index 46ef8abf8d454..be64f754470bb 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml @@ -58,7 +58,7 @@ let deposit_stake ctxt rollup staker = let open Lwt_tzresult_syntax in let* lcc, ctxt = Commitment_storage.last_cemented_commitment ctxt rollup in let staker_contract, stake = get_contract_and_stake ctxt staker in - let* ctxt, staker_balance = Token.balance ctxt (`Contract staker_contract) in + let* ctxt, staker_balance = Token.balance ctxt (Contract staker_contract) in let* () = fail_when Tez_repr.(staker_balance < stake) @@ -74,8 +74,8 @@ let deposit_stake ctxt rollup staker = let* ctxt, balance_updates = Token.transfer ctxt - (`Contract staker_contract) - (`Frozen_bonds (staker_contract, bond_id)) + (Source_container (Contract staker_contract)) + (Sink_container (Frozen_bonds (staker_contract, bond_id))) stake in let* ctxt, _size = Store.Stakers.init (ctxt, rollup) staker lcc in @@ -99,8 +99,8 @@ let withdraw_stake ctxt rollup staker = let* ctxt, balance_updates = Token.transfer ctxt - (`Frozen_bonds (staker_contract, bond_id)) - (`Contract staker_contract) + (Source_container (Frozen_bonds (staker_contract, bond_id))) + (Sink_container (Contract staker_contract)) stake in let* ctxt, _size_freed = @@ -390,8 +390,8 @@ let remove_staker ctxt rollup staker = let* ctxt, balance_updates = Token.transfer ctxt - (`Frozen_bonds (staker_contract, bond_id)) - `Sc_rollup_refutation_punishments + (Source_container (Frozen_bonds (staker_contract, bond_id))) + (Sink_infinite Sc_rollup_refutation_punishments) stake in let* ctxt, _size_diff = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index b1ff8356a8833..06a0fea1999db 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml @@ -79,6 +79,21 @@ let parameters_type ctxt rollup = let open Lwt_result_syntax in let+ ctxt, res = Store.Parameters_type.find ctxt rollup in (res, ctxt) + +module Outbox = struct + let level_index ctxt level = + let max_active_levels = + Constants_storage.sc_rollup_max_active_outbox_levels ctxt + in + Int32.rem (Raw_level_repr.to_int32 level) max_active_levels + + let record_applied_message ctxt rollup level ~message_index = + let open Lwt_tzresult_syntax in + (* Check that the 0 <= message index < maximum number of outbox messages per + level. *) + let*? () = + let max_outbox_messages_per_level = + Constants_storage.sc_rollup_max_outbox_messages_per_level ctxt in error_unless Compare.Int.( diff --git a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml index c1d2bbccd3a63..75e2b1372f777 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml @@ -43,7 +43,7 @@ let to_int x = if Z.fits_int x then Some (Z.to_int x) else None let of_number_of_ticks x = Z.of_int (Int32.to_int (Sc_rollup_repr.Number_of_ticks.to_int32 x)) -let ( <= ) = leq +let ( <= ) = Z.leq let ( < ) = Z.lt diff --git a/src/proto_alpha/lib_protocol/script_comparable.ml b/src/proto_alpha/lib_protocol/script_comparable.ml index 465b331bcfb56..d570ef9bda766 100644 --- a/src/proto_alpha/lib_protocol/script_comparable.ml +++ b/src/proto_alpha/lib_protocol/script_comparable.ml @@ -42,11 +42,11 @@ type compare_comparable_cont = -> compare_comparable_cont | Compare_comparable_return : compare_comparable_cont -module Compare_comparable = struct - let[@coq_struct "kind_value"] rec compare_comparable : +let compare_comparable : type a. a comparable_ty -> a -> a -> int = + let rec compare_comparable : type a. a comparable_ty -> compare_comparable_cont -> a -> a -> int = fun kind k x y -> - match (kind, x, y)[@coq_match_gadt] [@coq_match_with_default] with + match (kind, x, y) with | Unit_t, (), () -> (apply [@tailcall]) 0 k | Never_t, _, _ -> . | Signature_t, x, y -> (apply [@tailcall]) (Script_signature.compare x y) k @@ -81,7 +81,7 @@ module Compare_comparable = struct | Option_t _, Some _, None -> 1 | Option_t (t, _, Yes), Some x, Some y -> (compare_comparable [@tailcall]) t k x y - and apply[@coq_mutual_as_notation] ret k = + and apply ret k = match (ret, k) with | 0, Compare_comparable (ty, x, y, k) -> (compare_comparable [@tailcall]) ty k x y @@ -89,7 +89,6 @@ module Compare_comparable = struct | ret, _ -> (* ret <> 0, we perform an early exit *) if Compare.Int.(ret > 0) then 1 else -1 -end - -let compare_comparable : type a. a comparable_ty -> a -> a -> int = - fun t -> Compare_comparable.compare_comparable t Compare_comparable_return + in + fun t -> compare_comparable t Compare_comparable_return + [@@coq_axiom_with_reason "non top-level mutually recursive function"] diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index eb7f0a19e55ae..f33ac98e6d669 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1540,7 +1540,7 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] log : | _, LogExit prev_kinfo -> log_exit logger ctxt gas prev_kinfo k accu stack) ; let k = log_next_kinstr logger k in let with_log k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match[@coq_match_gadt] k with + match k with | IList_map (_, body, k) -> (ilist_map [@ocaml.tailcall]) with_log g gas body k ks accu stack | IList_iter (_, body, k) -> @@ -1548,13 +1548,13 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] log : | ISet_iter (_, body, k) -> (iset_iter [@ocaml.tailcall]) with_log g gas body k ks accu stack | IMap_map (_, body, k) -> - (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c2"]) with_log g gas body k ks accu stack + (imap_map [@ocaml.tailcall]) with_log g gas body k ks accu stack | IMap_iter (_, body, k) -> (imap_iter [@ocaml.tailcall]) with_log g gas body k ks accu stack | ILoop (_, body, k) -> let ks = with_log (KLoop_in (body, KCons (k, ks))) in (next [@ocaml.tailcall]) g gas ks accu stack - | (ILoop_left (_, bl, br), _, _) -> + | ILoop_left (_, bl, br) -> let ks = with_log (KLoop_in_left (bl, KCons (br, ks))) in (next [@ocaml.tailcall]) g gas ks accu stack | IMul_teznat (kinfo, k) -> @@ -1568,11 +1568,12 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] log : | IFailwith (_, kloc, tv) -> let {ifailwith} = ifailwith in (ifailwith [@ocaml.tailcall]) (Some logger) g gas kloc tv accu - | (IExec (_, k), _, (stack : _ lambda * _)) -> + | IExec (_, k) -> (iexec [@ocaml.tailcall]) (Some logger) g gas k ks accu stack | _ -> (step [@ocaml.tailcall]) g gas k (with_log ks) accu stack [@@inline] + and[@coq_axiom_with_reason "we ignore the logging operations"] klog : type a s r f. logger -> @@ -1587,31 +1588,30 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] klog : (match ks with KLog _ -> () | _ -> log_control logger ks) ; let enable_log ki = log_kinstr logger ki in let mk k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match[@coq_match_gadt] (ks, accu, stack) with - | (KCons (ki, ks'), _, _) -> + match ks with + | KCons (ki, ks') -> let log = enable_log ki in let ks = mk ks' in (step [@ocaml.tailcall]) g gas log ks accu stack - | (KNil, _, _) -> (next [@ocaml.tailcall]) g gas ks accu stack - | (KLoop_in (ki, ks'), (accu : bool), (stack : _ * _)) -> + | KNil -> (next [@ocaml.tailcall]) g gas ks accu stack + | KLoop_in (ki, ks') -> let ks' = mk ks' in let ki = enable_log ki in (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | (KReturn (stack', ks'), _, _) -> + | KReturn (stack', ks') -> let ks' = mk ks' in let ks = KReturn (stack', ks') in (next [@ocaml.tailcall]) g gas ks accu stack - | (KMap_head (f, ks), _, _) -> - (next [@ocaml.tailcall]) g gas ks (f accu) stack - | (KLoop_in_left (ki, ks'), (accu : _ union), _) -> + | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack + | KLoop_in_left (ki, ks') -> let ks' = mk ks' in let ki = enable_log ki in (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | (KUndip (x, ks'), _, _) -> + | KUndip (x, ks') -> let ks' = mk ks' in let ks = KUndip (x, ks') in (next [@ocaml.tailcall]) g gas ks accu stack - | (KIter (body, xs, ks'), _, _) -> + | KIter (body, xs, ks') -> let ks' = mk ks' in let body = enable_log body in (kiter [@ocaml.tailcall]) mk g gas body xs ks' accu stack @@ -1630,11 +1630,12 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] klog : | KView_exit (orig_step_constants, ks') -> let g = (fst g, orig_step_constants) in (next [@ocaml.tailcall]) g gas ks' accu stack - | (KLog (_, _), _, _) -> + | KLog (_, _) -> (* This case should never happen. *) (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] + (* Entrypoints diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 525f71da0bd71..d192cc971250c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -532,7 +532,7 @@ let comb_witness2 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_struct "ty"] rec unparse_comparable_data : +let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : type a loc. loc:loc -> context -> @@ -541,16 +541,16 @@ let[@coq_struct "ty"] rec unparse_comparable_data : a -> (loc Script.michelson_node * context) tzresult Lwt.t = fun ~loc ctxt mode ty a -> - (* No need for stack_depth here. Unlike [unparse_data_aux], - [unparse_comparable_data] doesn't call [unparse_code_aux]. + (* No need for stack_depth here. Unlike [unparse_data], + [unparse_comparable_data] doesn't call [unparse_code]. The stack depth is bounded by the type depth, currently bounded by 1000 (michelson_maximum_type_size). *) Gas.consume ctxt Unparse_costs.unparse_data_cycle (* We could have a smaller cost but let's keep it consistent with - [unparse_data_aux] for now. *) + [unparse_data] for now. *) >>?= fun ctxt -> - match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + match (ty, a) with | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v @@ -610,8 +610,7 @@ let hash_comparable_data ctxt ty data = All comparable types are dupable, this function exists only to not forget checking this property when adding new types. *) -let check_dupable_comparable_ty : type a. a comparable_ty -> unit = - function[@coq_match_with_default] +let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t | Tx_rollup_l2_address_t | Pair_t _ | Union_t _ | Option_t _ -> @@ -705,7 +704,7 @@ let memo_size_eq : if Sapling.Memo_size.equal ms1 ms2 then Result.return_unit else Error - (match[@coq_match_gadt_with_result] error_details with + (match error_details with | Fast -> Inconsistent_types_fast | Informative _ -> trace_of_error @@ Inconsistent_memo_sizes (ms1, ms2)) @@ -744,22 +743,12 @@ let rec ty_eq : (tb, tbc) ty -> (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = fun ty1 ty2 -> - let help : - type ta tac tb tbc. - (ta, tac) ty -> - (tb, tbc) ty -> - (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = - fun ty1 ty2 -> - help0 ty1 ty2 - |> Gas_monad.record_trace_eval ~error_details (fun () -> - default_ty_eq_error ty1 ty2) - in let open Gas_monad.Syntax in let* () = Gas_monad.consume_gas Typecheck_costs.merge_cycle in let not_equal () = Gas_monad.of_result @@ Error - (match[@coq_match_gadt_with_result] error_details with + (match error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative loc -> trace_of_error @@ default_ty_eq_error loc ty1 ty2) @@ -878,9 +867,8 @@ let rec ty_eq : | Chest_key_t, Chest_key_t -> return Eq | Chest_key_t, _ -> not_equal () in - help0 ty1 ty2 - |> Gas_monad.record_trace_eval ~error_details (fun () -> - default_ty_eq_error ty1 ty2) + help ty1 ty2 + [@@coq_axiom_with_reason "non-top-level mutual recursion"] (* Same as ty_eq but for stacks. A single error monad is used here because there is no need to @@ -913,7 +901,6 @@ type ('a, 's) judgement = descr : 'b 'u. ('b, 'u) stack_ty -> ('a, 's, 'b, 'u) descr; } -> ('a, 's) judgement -[@@coq_force_gadt] (* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*) @@ -975,21 +962,21 @@ type ex_parameter_ty_and_entrypoints_node = } -> ex_parameter_ty_and_entrypoints_node -(** [parse_ty_aux] can be used to parse regular types as well as parameter types +(** [parse_ty] can be used to parse regular types as well as parameter types together with their entrypoints. - In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty_aux] will + In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty] will return an [ex_ty]. - In the second case, use [~ret:Parse_entrypoints], [parse_ty_aux] will return - an [ex_parameter_ty_and_entrypoints]. + In the second case, use [~ret:Parse_entrypoints], [parse_ty] will return + an [ex_parameter_ty_and_entrypoints_node]. *) type ('ret, 'name) parse_ty_ret = | Don't_parse_entrypoints : (ex_ty, unit) parse_ty_ret | Parse_entrypoints : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret -let[@coq_struct "node_value"] rec parse_ty_aux : +let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty : type ret name. context -> stack_depth:int -> @@ -1015,11 +1002,11 @@ let[@coq_struct "node_value"] rec parse_ty_aux : error Typechecking_too_many_recursive_calls else (match ret with - | Don't_parse_entrypoints -> ok (node, None) + | Don't_parse_entrypoints -> ok (node, (() : name)) | Parse_entrypoints -> extract_entrypoint_annot node) >>? fun (node, name) -> let return ctxt ty : ret * context = - match[@coq_match_gadt_with_result] ret with + match ret with | Don't_parse_entrypoints -> (Ex_ty ty, ctxt) | Parse_entrypoints -> let at_node = @@ -1082,7 +1069,7 @@ let[@coq_struct "node_value"] rec parse_ty_aux : check_type_annot loc annot >|? fun () -> return ctxt bls12_381_fr_t | Prim (loc, T_contract, [utl], annot) -> if allow_contract then - parse_passable_ty_aux_with_ret + parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1094,7 +1081,7 @@ let[@coq_struct "node_value"] rec parse_ty_aux : else error (Unexpected_contract loc) | Prim (loc, T_pair, utl :: utr, annot) -> remove_field_annot utl >>? fun utl -> - parse_ty_aux + parse_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1111,7 +1098,7 @@ let[@coq_struct "node_value"] rec parse_ty_aux : (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) ok (Prim (loc, T_pair, utr, []))) >>? fun utr -> - parse_ty_aux + parse_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1131,7 +1118,7 @@ let[@coq_struct "node_value"] rec parse_ty_aux : remove_field_annot utr >|? fun utr -> (utl, utr) | Parse_entrypoints -> ok (utl, utr)) >>? fun (utl, utr) -> - parse_ty_aux + parse_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1142,7 +1129,7 @@ let[@coq_struct "node_value"] rec parse_ty_aux : ~ret utl >>? fun (parsed_l, ctxt) -> - parse_ty_aux + parse_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1154,20 +1141,12 @@ let[@coq_struct "node_value"] rec parse_ty_aux : utr >>? fun (parsed_r, ctxt) -> check_type_annot loc annot >>? fun () -> - match[@coq_match_gadt_with_result] - ( ret, - (parsed_l [@coq_type_annotation]), - (parsed_r [@coq_type_annotation]) ) - with - | (Don't_parse_entrypoints, (parsed_l : ex_ty), (parsed_r : ex_ty)) -> + match ret with + | Don't_parse_entrypoints -> let (Ex_ty tl) = parsed_l in let (Ex_ty tr) = parsed_r in union_t loc tl tr >|? fun (Ty_ex_c ty) -> ((Ex_ty ty : ret), ctxt) - (* | Parse_entrypoints -> - * let (Ex_parameter_ty_and_entrypoints_node *) - | ( Parse_entrypoints, - (parsed_l : ex_parameter_ty_and_entrypoints_node), - (parsed_r : ex_parameter_ty_and_entrypoints_node) ) -> + | Parse_entrypoints -> let (Ex_parameter_ty_and_entrypoints_node {arg_type = tl; entrypoints = left}) = parsed_l @@ -1186,9 +1165,9 @@ let[@coq_struct "node_value"] rec parse_ty_aux : (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt) ) | Prim (loc, T_lambda, [uta; utr], annot) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy uta + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy uta >>? fun (Ex_ty ta, ctxt) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy utr + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr >>? fun (Ex_ty tr, ctxt) -> check_type_annot loc annot >>? fun () -> lambda_t loc ta tr >|? fun ty -> return ctxt ty @@ -1199,7 +1178,7 @@ let[@coq_struct "node_value"] rec parse_ty_aux : check_composed_type_annot loc annot >>? fun () -> ok ut else check_type_annot loc annot >>? fun () -> ok ut) >>? fun ut -> - parse_ty_aux + parse_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1212,7 +1191,7 @@ let[@coq_struct "node_value"] rec parse_ty_aux : >>? fun (Ex_ty t, ctxt) -> option_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_list, [ut], annot) -> - parse_ty_aux + parse_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1227,20 +1206,20 @@ let[@coq_struct "node_value"] rec parse_ty_aux : list_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_ticket, [ut], annot) -> if allow_ticket then - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> ticket_t loc t >|? fun ty -> return ctxt ty else error (Unexpected_ticket loc) | Prim (loc, T_set, [ut], annot) -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> set_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_map, [uta; utr], annot) -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt uta + parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> - parse_ty_aux + parse_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1370,40 +1349,41 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab Script.node -> (ret * context) tzresult = fun ctxt ~stack_depth ~legacy -> - ((parse_ty_aux [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:false - ~allow_contract:true - ~allow_ticket:true [@coq_type_annotation]) + (parse_ty [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:false + ~allow_contract:true + ~allow_ticket:true -and[@coq_mutual_as_notation] parse_any_ty_aux : +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty + : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = fun ctxt ~stack_depth ~legacy -> - ((parse_ty_aux [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:true - ~allow_contract:true - ~allow_ticket:true - ~ret:Don't_parse_entrypoints [@coq_type_annotation]) - -and[@coq_struct "args"] parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc - args map_annot = + (parse_ty [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:true + ~allow_contract:true + ~allow_ticket:true + ~ret:Don't_parse_entrypoints + +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_ty + ctxt ~stack_depth ~legacy big_map_loc args map_annot = Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt -> match args with | [key_ty; value_ty] -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt key_ty + parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt key_ty >>? fun (Ex_comparable_ty key_ty, ctxt) -> - parse_big_map_value_ty_aux + parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1414,21 +1394,21 @@ and[@coq_struct "args"] parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -and[@coq_mutual_as_notation] parse_big_map_value_ty_aux ctxt ~stack_depth - ~legacy value_ty = - ((parse_ty_aux [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:false - ~allow_operation:false - ~allow_contract:legacy - ~allow_ticket:true - ~ret:Don't_parse_entrypoints - value_ty [@coq_type_annotation]) - -let parse_packable_ty_aux ctxt ~stack_depth ~legacy node = - (parse_ty_aux [@tailcall]) +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty + ctxt ~stack_depth ~legacy value_ty = + (parse_ty [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:false + ~allow_operation:false + ~allow_contract:legacy + ~allow_ticket:true + ~ret:Don't_parse_entrypoints + value_ty + +let parse_packable_ty ctxt ~stack_depth ~legacy node = + (parse_ty [@tailcall]) ctxt ~stack_depth ~legacy @@ -1442,7 +1422,7 @@ let parse_packable_ty_aux ctxt ~stack_depth ~legacy node = node let parse_view_input_ty ctxt ~stack_depth ~legacy node = - (parse_ty_aux [@tailcall]) + (parse_ty [@tailcall]) ctxt ~stack_depth ~legacy @@ -1454,7 +1434,7 @@ let parse_view_input_ty ctxt ~stack_depth ~legacy node = node let parse_view_output_ty ctxt ~stack_depth ~legacy node = - (parse_ty_aux [@tailcall]) + (parse_ty [@tailcall]) ctxt ~stack_depth ~legacy @@ -1466,7 +1446,7 @@ let parse_view_output_ty ctxt ~stack_depth ~legacy node = node let parse_normal_storage_ty ctxt ~stack_depth ~legacy node = - (parse_ty_aux [@tailcall]) + (parse_ty [@tailcall]) ctxt ~stack_depth ~legacy @@ -1580,7 +1560,6 @@ type ('arg, 'storage) code = code_size : Cache_memory_helpers.sint; } -> ('arg, 'storage) code -[@@coq_force_gadt] type ex_script = Ex_script : ('a, 'c) Script_typed_ir.script -> ex_script @@ -1638,19 +1617,16 @@ type 'before comb_get_proof_argument = | Comb_get_proof_argument : ('before, 'after) comb_get_gadt_witness * ('after, _) ty -> 'before comb_get_proof_argument -[@@coq_force_gadt] type ('rest, 'before) comb_set_proof_argument = | Comb_set_proof_argument : ('rest, 'before, 'after) comb_set_gadt_witness * ('after, _) ty -> ('rest, 'before) comb_set_proof_argument -[@@coq_force_gadt] type 'before dup_n_proof_argument = | Dup_n_proof_argument : ('before, 'a) dup_n_gadt_witness * ('a, _) ty -> 'before dup_n_proof_argument -[@@coq_force_gadt] let rec make_dug_proof_argument : type a s x xc. @@ -1720,7 +1696,7 @@ let find_entrypoint (type full fullc error_context error_trace) (full : (full, fullc) ty) (entrypoints : full entrypoints) entrypoint : (full ex_ty_cstr, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let[@coq_struct "ty"] rec find_entrypoint : + let rec find_entrypoint : type t tc. (t, tc) ty -> t entrypoints_node -> @@ -1728,12 +1704,12 @@ let find_entrypoint (type full fullc error_context error_trace) (t ex_ty_cstr, unit) Gas_monad.t = fun ty entrypoints entrypoint -> let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in - match[@coq_match_gadt] [@coq_match_with_default] (ty, entrypoints) with + match (ty, entrypoints) with | _, {at_node = Some {name; original_type_expr}; _} when Entrypoint.(name = entrypoint) -> return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> ( - Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ (function [@coq_match_gadt] + Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> return (Ex_ty_cstr @@ -1744,10 +1720,10 @@ let find_entrypoint (type full fullc error_context error_trace) }) | Error () -> let+ (Ex_ty_cstr {ty; construct; original_type_expr}) = - (find_entrypoint tr right entrypoint [@coq_type_annotation]) + find_entrypoint tr right entrypoint in Ex_ty_cstr - {ty; construct = (fun e -> R (construct e)); original_type_expr})) + {ty; construct = (fun e -> R (construct e)); original_type_expr}) | _, {nested = Entrypoints_None; _} -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in @@ -1760,7 +1736,7 @@ let find_entrypoint (type full fullc error_context error_trace) else Gas_monad.of_result @@ Error - (match[@coq_match_gadt_with_result] error_details with + (match error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative _ -> trace_of_error @@ No_such_entrypoint entrypoint) @@ -1769,13 +1745,7 @@ let find_entrypoint_for_type (type full fullc exp expc error_trace) entrypoints entrypoint : (Entrypoint.t * (exp, expc) ty, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let* res = - (find_entrypoint - ~error_details - full - entrypoints - entrypoint [@coq_type_annotation]) - in + let* res = find_entrypoint ~error_details full entrypoints entrypoint in match res with | Ex_ty_cstr {ty; _} -> ( match entrypoints.root.at_node with @@ -1853,14 +1823,14 @@ type ex_parameter_ty_and_entrypoints = } -> ex_parameter_ty_and_entrypoints -let parse_parameter_ty_and_entrypoints_aux : +let parse_parameter_ty_and_entrypoints : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_parameter_ty_and_entrypoints * context) tzresult = fun ctxt ~stack_depth ~legacy node -> - parse_passable_ty_aux_with_ret + parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1874,8 +1844,7 @@ let parse_parameter_ty_and_entrypoints_aux : let entrypoints = {root = entrypoints; original_type_expr = node} in (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -let parse_passable_ty_aux = - parse_passable_ty_aux_with_ret ~ret:Don't_parse_entrypoints +let parse_passable_ty = parse_passable_ty ~ret:Don't_parse_entrypoints let parse_uint ~nb_bits = assert (Compare.Int.(nb_bits >= 0 && nb_bits <= 30)) ; @@ -2487,7 +2456,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : |> traced >|=? fun (_, map, ctxt) -> (map, ctxt) in - match[@coq_match_gadt_with_result] (ty, script_data) with + match (ty, script_data) with | Unit_t, expr -> Lwt.return @@ traced_no_lwt @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) @@ -2555,7 +2524,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : tr script_instr | Lambda_t _, expr -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Seq_kind], kind expr)) + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) | Option_t (t, _, _), expr -> let parse_v ctxt v = @@ -2572,7 +2541,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : items (Script_list.empty, ctxt) | List_t _, expr -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Seq_kind], kind expr)) + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Tickets *) | Ticket_t (t, _ty_name), expr -> if allow_forged then @@ -2580,7 +2549,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : non_terminal_recursion ?type_logger ctxt ~legacy ty expr >>=? fun (({destination; entrypoint = _}, (contents, amount)), ctxt) -> match destination with - | Contract ticketer -> return ({ticketer; contents [@coq_type_annotation]; amount}, ctxt) + | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) | Tx_rollup _ | Sc_rollup _ -> fail (Unexpected_ticket_owner destination) else traced_fail (Unexpected_forged_value (location expr)) @@ -2620,15 +2589,13 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Maps *) | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) -> - (parse_items [@coq_type_annotation]) ?type_logger ctxt expr tk tv vs (fun x -> x) + parse_items ?type_logger ctxt expr tk tv vs (fun x -> x) | Map_t _, expr -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Seq_kind], kind expr)) + traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) | Big_map_t (tk, tv, _ty_name), expr -> (match expr with | Int (loc, id) -> - return - (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) - [@coq_type_annotation] + return (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) | Seq (_, vs) -> parse_big_map_items ?type_logger ctxt expr tk tv vs (fun x -> Some x) >|=? fun (diff, ctxt) -> (None, diff, ctxt) @@ -2656,12 +2623,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | _, None -> traced_fail (Invalid_big_map (loc, id)) | ctxt, Some (btk, btv) -> Lwt.return - ( parse_comparable_ty_aux + ( parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt (Micheline.root btk) >>? fun (Ex_comparable_ty btk, ctxt) -> - parse_big_map_value_ty_aux + parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -2686,14 +2653,14 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | Bls12_381_g1_t, expr -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Bls12_381_g2_t, Bytes (_, bs) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt -> match Script_bls.G2.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | Bls12_381_g2_t, expr -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Bls12_381_fr_t, Bytes (_, bs) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> match Script_bls.Fr.of_bytes_opt bs with @@ -2703,7 +2670,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> return (Script_bls.Fr.of_z v, ctxt) | Bls12_381_fr_t, expr -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) (* /!\ When adding new lazy storage kinds, you may want to guard the parsing of identifiers with [allow_forged]. @@ -2725,7 +2692,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | Sapling_transaction_t _, expr -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes) -> ( match Data_encoding.Binary.of_bytes_opt @@ -2744,7 +2711,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | Sapling_transaction_deprecated_t _, expr -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Sapling_state_t memo_size, Int (loc, id) -> if allow_forged then let id = Sapling.Id.parse_z id in @@ -2758,12 +2725,11 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : >|? fun () -> (state, ctxt) ) else traced_fail (Unexpected_forged_value loc) | Sapling_state_t memo_size, Seq (_, []) -> - ((return [@coq_type_annotation]) (Sapling.empty_state ~memo_size (), ctxt) - : (Sapling.state * _) tzresult Lwt.t) + return (Sapling.empty_state ~memo_size (), ctxt) | Sapling_state_t _, expr -> (* Do not allow to input diffs as they are untrusted and may not be the result of a verify_update. *) - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + traced_fail (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) | Chest_key_t, Bytes (_, bytes) -> ( @@ -2776,8 +2742,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some chest_key -> return (chest_key, ctxt) | None -> fail_parse_data ()) | Chest_key_t, expr -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) - (Invalid_kind (location expr, [Bytes_kind], kind expr)) + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Chest_t, Bytes (_, bytes) -> ( Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) >>?= fun ctxt -> @@ -2787,9 +2752,9 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some chest -> return (chest, ctxt) | None -> fail_parse_data ()) | Chest_t, expr -> - (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Bytes_kind], kind expr)) + traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) -and[@coq_struct "ctxt"] parse_view : +and parse_view : type storage storagec. ?type_logger:type_logger -> context -> @@ -2870,7 +2835,7 @@ and parse_views : in Script_map.map_es_in_context aux ctxt views -and[@coq_mutual_as_notation] parse_returning : +and[@coq_axiom_with_reason "gadt"] parse_returning : type arg argc ret retc. ?type_logger:type_logger -> stack_depth:int -> @@ -2882,7 +2847,7 @@ and[@coq_mutual_as_notation] parse_returning : Script.node -> ((arg, ret) lambda * context) tzresult Lwt.t = fun ?type_logger ~stack_depth tc_context ctxt ~legacy arg ret script_instr -> - parse_instr_aux + parse_instr ?type_logger tc_context ctxt @@ -2913,7 +2878,7 @@ and[@coq_mutual_as_notation] parse_returning : : (arg, ret) lambda), ctxt ) -and[@coq_struct "ctxt"] parse_instr_aux : +and[@coq_axiom_with_reason "gadt"] parse_instr : type a s. ?type_logger:type_logger -> stack_depth:int -> @@ -2959,7 +2924,7 @@ and[@coq_struct "ctxt"] parse_instr_aux : if Compare.Int.(stack_depth > 10000) then fail Typechecking_too_many_recursive_calls else - parse_instr_aux + parse_instr ?type_logger tc_context ctxt @@ -3090,9 +3055,9 @@ and[@coq_struct "ctxt"] parse_instr_aux : typed ctxt loc swap stack_ty | Prim (loc, I_PUSH, [t; d], annot), stack -> check_var_annot loc annot >>?= fun () -> - parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t - >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> - parse_data_aux + parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + >>?= fun (Ex_ty t, ctxt) -> + parse_data ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -3101,9 +3066,7 @@ and[@coq_struct "ctxt"] parse_instr_aux : t d >>=? fun (v, ctxt) -> - let const = - {apply = (fun kinfo k -> IConst (kinfo, (v [@coq_type_annotation]), k))} - in + let const = {apply = (fun kinfo k -> IConst (kinfo, v, k))} in typed ctxt loc const (Item_t (t, stack)) | Prim (loc, I_UNIT, [], annot), stack -> check_var_type_annot loc annot >>?= fun () -> @@ -3199,9 +3162,8 @@ and[@coq_struct "ctxt"] parse_instr_aux : ok (Comb_proof_argument (Comb_one, Item_t (a_ty, tl_ty))) | n, Item_t (a_ty, tl_ty) -> make_proof_argument (n - 1) tl_ty - >>? fun [@coq_match_with_default] (Comb_proof_argument - ( comb_witness, - Item_t (b_ty, tl_ty') )) -> + >>? fun (Comb_proof_argument (comb_witness, Item_t (b_ty, tl_ty'))) + -> pair_t loc a_ty b_ty >|? fun (Ty_ex_c pair_t) -> Comb_proof_argument (Comb_succ comb_witness, Item_t (pair_t, tl_ty')) | _ -> @@ -3218,7 +3180,7 @@ and[@coq_struct "ctxt"] parse_instr_aux : typed ctxt loc comb after_ty | Prim (loc, I_UNPAIR, [n], annot), stack_ty -> error_unexpected_annot loc annot >>?= fun () -> - let[@coq_struct "n_value"] rec make_proof_argument : + let rec make_proof_argument : type a s. int -> (a, s) stack_ty -> (a * s) uncomb_proof_argument tzresult = fun n stack_ty -> @@ -3517,7 +3479,7 @@ and[@coq_struct "ctxt"] parse_instr_aux : | Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_map (kinfo, tk, k))} in @@ -3643,7 +3605,7 @@ and[@coq_struct "ctxt"] parse_instr_aux : | Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack -> parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = @@ -3882,7 +3844,7 @@ and[@coq_struct "ctxt"] parse_instr_aux : | Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg >>?= fun (Ex_ty arg, ctxt) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ret + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret >>?= fun (Ex_ty ret, ctxt) -> check_kind [Seq_kind] code >>?= fun () -> check_var_annot loc annot >>?= fun () -> @@ -4326,7 +4288,7 @@ and[@coq_struct "ctxt"] parse_instr_aux : (* annotations *) | Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack) -> check_var_annot loc annot >>?= fun () -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t >>?= fun (Ex_ty cast_t, ctxt) -> Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) cast_t t >>?= fun (eq, ctxt) -> @@ -4424,11 +4386,11 @@ and[@coq_struct "ctxt"] parse_instr_aux : contracts but then we throw away the typed version, except for the storage type which is kept for efficiency in the ticket scanner. *) let canonical_code = Micheline.strip_locations code in - parse_toplevel_aux ctxt ~legacy canonical_code + parse_toplevel ctxt ~legacy canonical_code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> record_trace (Ill_formed_type (Some "parameter", canonical_code, location arg_type)) - (parse_parameter_ty_and_entrypoints_aux + (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -4457,14 +4419,10 @@ and[@coq_struct "ctxt"] parse_instr_aux : arg_type_full ret_type_full code_field) - >>=? fun [@coq_match_with_default] ( Lam - ( { - kbef = Item_t (arg, Bot_t); - kaft = Item_t (ret, Bot_t); - _; - }, - _ ), - ctxt ) -> + >>=? fun ( Lam + ( {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, + _ ), + ctxt ) -> let views_result = parse_views ctxt ?type_logger ~legacy storage_type views in @@ -4545,7 +4503,7 @@ and[@coq_struct "ctxt"] parse_instr_aux : Lwt.return ( parse_entrypoint_annot_lax loc annot >>? fun entrypoint -> let open Tc_context in - match[@coq_match_gadt] tc_context.callsite with + match tc_context.callsite with | _ when is_in_lambda tc_context -> error (Forbidden_instr_in_context (loc, Script_tc_errors.Lambda, prim)) @@ -4558,11 +4516,11 @@ and[@coq_struct "ctxt"] parse_instr_aux : (Forbidden_instr_in_context (loc, Script_tc_errors.View, prim)) | Toplevel {param_type; entrypoints; storage_type = _} -> Gas_monad.run ctxt - @@ (find_entrypoint + @@ find_entrypoint ~error_details:(Informative ()) param_type entrypoints - entrypoint [@coq_type_annotation]) + entrypoint >>? fun (r, ctxt) -> r >>? fun (Ex_ty_cstr {ty = param_type; _}) -> contract_t loc param_type >>? fun res_ty -> @@ -5037,9 +4995,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra {arg_type = targ; entrypoints}, ctxt ) -> Gas_monad.run ctxt - @@ (find_entrypoint_for_type - [@coq_implicit - "full" "__Ex_parameter_ty_and_entrypoints_'a1"]) + @@ find_entrypoint_for_type ~error_details ~full:targ ~expected:arg @@ -5099,7 +5055,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra let address = {destination; entrypoint} in Typed_contract {arg_ty; address} )) -(* Same as [parse_contract_aux], but does not fail when the contact is missing or +(* Same as [parse_contract], but does not fail when the contact is missing or if the expected type doesn't match the actual one. In that case None is returned and some overapproximation of the typechecking gas is consumed. This can still fail on gas exhaustion. *) @@ -5156,16 +5112,12 @@ let parse_code : code >>?= fun (code, ctxt) -> Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel_aux ctxt ~legacy code + parse_toplevel ctxt ~legacy code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints_aux - ctxt - ~stack_depth:0 - ~legacy - arg_type) + (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5213,7 +5165,7 @@ let parse_storage : (fun () -> let storage_type = serialize_ty_for_error storage_type in Ill_typed_data (None, storage, storage_type)) - (parse_data_aux + (parse_data ?type_logger ~stack_depth:0 ctxt @@ -5222,7 +5174,7 @@ let parse_storage : storage_type (root storage)) -let parse_script : +let[@coq_axiom_with_reason "gadt"] parse_script : ?type_logger:type_logger -> context -> legacy:bool -> @@ -5231,17 +5183,10 @@ let parse_script : (ex_script * context) tzresult Lwt.t = fun ?type_logger ctxt ~legacy ~allow_forged_in_storage {code; storage} -> parse_code ~legacy ctxt ?type_logger ~code - >>=? fun [@coq_match_gadt] ( Ex_code - (Code - { - code; - arg_type; - storage_type; - views; - entrypoints; - code_size; - }), - ctxt ) -> + >>=? fun ( Ex_code + (Code + {code; arg_type; storage_type; views; entrypoints; code_size}), + ctxt ) -> parse_storage ?type_logger ctxt @@ -5252,15 +5197,7 @@ let parse_script : >|=? fun (storage, ctxt) -> ( Ex_script (Script - { - code_size; - code; - arg_type; - storage = storage [@coq_type_annotation]; - storage_type; - views; - entrypoints; - }), + {code_size; code; arg_type; storage; storage_type; views; entrypoints}), ctxt ) type typechecked_code_internal = @@ -5274,26 +5211,22 @@ type typechecked_code_internal = } -> typechecked_code_internal -let typecheck_code_inner : +let typecheck_code : legacy:bool -> show_types:bool -> context -> Script.expr -> (typechecked_code_internal * context) tzresult Lwt.t = fun ~legacy ~show_types ctxt code -> - (* Constants need to be expanded or [parse_toplevel_aux] may fail. *) + (* Constants need to be expanded or [parse_toplevel] may fail. *) Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel_aux ctxt ~legacy code >>?= fun (toplevel, ctxt) -> + parse_toplevel ctxt ~legacy code >>?= fun (toplevel, ctxt) -> let {arg_type; storage_type; code_field; views} = toplevel in let type_map = ref [] in let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints_aux - ctxt - ~stack_depth:0 - ~legacy - arg_type) + (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5380,7 +5313,6 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) | Some {name; original_type_expr} -> (Entrypoint.Map.singleton name (Ex_ty full, original_type_expr), true) in - fold_tree full entrypoints.root [] reachable ([], init) [@@coq_axiom_with_reason "unsupported syntax"] @@ -5401,10 +5333,10 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : let non_terminal_recursion ctxt mode ty a = if Compare.Int.(stack_depth > 10_000) then fail Unparsing_too_many_recursive_calls - else unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode ty a + else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a in let loc = Micheline.dummy_location in - match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + match (ty, a) with | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v @@ -5453,7 +5385,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : opened_ticket_type loc t >>?= fun t -> let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in - (unparse_data_aux [@tailcall]) + (unparse_data [@tailcall]) ctxt ~stack_depth mode @@ -5573,7 +5505,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : ~plaintext_size:(Script_timelock.get_plaintext_size s)) Script_timelock.chest_encoding -and[@coq_mutual_as_notation] unparse_items : +and unparse_items : type k v vc. context -> stack_depth:int -> @@ -5587,25 +5519,23 @@ and[@coq_mutual_as_notation] unparse_items : (fun (l, ctxt) (k, v) -> let loc = Micheline.dummy_location in unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode vt v + unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v >|=? fun (value, ctxt) -> (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) ([], ctxt) items -and[@coq_struct "ctxt"] unparse_code_aux (ctxt : context) ~(stack_depth : int) - (mode : unparsing_mode) (code : Script.node) : - (node * context, error trace) result Lwt.t = +and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = let legacy = true in Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> let non_terminal_recursion ctxt mode code = if Compare.Int.(stack_depth > 10_000) then fail Unparsing_too_many_recursive_calls - else unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode code + else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code in match code with | Prim (loc, I_PUSH, [ty; data], annot) -> - parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty - >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> + parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + >>?= fun (Ex_ty t, ctxt) -> let allow_forged = false (* Forgeable in PUSH data are already forbidden at parsing, @@ -5613,7 +5543,7 @@ and[@coq_struct "ctxt"] unparse_code_aux (ctxt : context) ~(stack_depth : int) from APPLYing a non-forgeable but this cannot happen either as long as all packable values are also forgeable. *) in - parse_data_aux + parse_data ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -5621,12 +5551,7 @@ and[@coq_struct "ctxt"] unparse_code_aux (ctxt : context) ~(stack_depth : int) t data >>=? fun (data, ctxt) -> - unparse_data_aux - ctxt - ~stack_depth:(stack_depth + 1) - mode - t - (data [@coq_type_annotation]) + unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data >>=? fun (data, ctxt) -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) | Seq (loc, items) -> @@ -5649,21 +5574,14 @@ and[@coq_struct "ctxt"] unparse_code_aux (ctxt : context) ~(stack_depth : int) return (Prim (loc, prim, List.rev items, annot), ctxt) | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt) -let parse_and_unparse_script_unaccounted : - context -> - legacy:bool -> - allow_forged_in_storage:bool -> - unparsing_mode -> - normalize_types:bool -> - Script.t -> - (Script.t * context) tzresult Lwt.t = - fun ctxt ~legacy ~allow_forged_in_storage mode ~normalize_types {code; storage} -> +let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage + mode ~normalize_types {code; storage} = Script.force_decode_in_context ~consume_deserialization_gas:When_needed ctxt code >>?= fun (code, ctxt) -> - typecheck_code_inner ~legacy ~show_types:false ctxt code + typecheck_code ~legacy ~show_types:false ctxt code >>=? fun ( Typechecked_code_internal { toplevel = @@ -5680,15 +5598,15 @@ let parse_and_unparse_script_unaccounted : type_map = _; }, ctxt ) -> - (parse_storage [@coq_implicit "storage" "a"]) + parse_storage ctxt ~legacy ~allow_forged:allow_forged_in_storage storage_type ~storage >>=? fun (storage, ctxt) -> - unparse_code_aux ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> - unparse_data_aux ctxt ~stack_depth:0 mode storage_type storage + unparse_code ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> + unparse_data ctxt ~stack_depth:0 mode storage_type storage >>=? fun (storage, ctxt) -> let loc = Micheline.dummy_location in (if normalize_types then @@ -5748,7 +5666,7 @@ let parse_and_unparse_script_unaccounted : ctxt ) let pack_data_with_mode ctxt ty data ~mode = - unparse_data_aux ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> + unparse_data ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> Lwt.return @@ pack_node unparsed ctxt let hash_data ctxt ty data = @@ -5765,63 +5683,60 @@ type lazy_storage_ids = Lazy_storage.IdSet.t let no_lazy_storage_id = Lazy_storage.IdSet.empty let diff_of_big_map ctxt mode ~temporary ~ids_to_copy - (big_map : ('a, 'b) big_map) = - match[@coq_match_gadt] big_map with - | Big_map {id; key_type; value_type; diff} -> - (match id with - | Some id -> - if Lazy_storage.IdSet.mem Big_map id ids_to_copy then - Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> - (ctxt, Lazy_storage.Copy {src = id}, duplicate) - else - (* The first occurrence encountered of a big_map reuses the - ID. This way, the payer is only charged for the diff. - For this to work, this diff has to be put at the end of - the global diff, otherwise the duplicates will use the - updated version as a base. This is true because we add - this diff first in the accumulator of - `extract_lazy_storage_updates`, and this accumulator is not - reversed. *) - return (ctxt, Lazy_storage.Existing, id) - | None -> - Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> + (Big_map {id; key_type; value_type; diff}) = + (match id with + | Some id -> + if Lazy_storage.IdSet.mem Big_map id ids_to_copy then + Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> + (ctxt, Lazy_storage.Copy {src = id}, duplicate) + else + (* The first occurrence encountered of a big_map reuses the + ID. This way, the payer is only charged for the diff. + For this to work, this diff has to be put at the end of + the global diff, otherwise the duplicates will use the + updated version as a base. This is true because we add + this diff first in the accumulator of + `extract_lazy_storage_updates`, and this accumulator is not + reversed. *) + return (ctxt, Lazy_storage.Existing, id) + | None -> + Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> + Lwt.return + (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in + Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> + unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> + let key_type = Micheline.strip_locations kt in + let value_type = Micheline.strip_locations kv in + (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) + >>=? fun (ctxt, init, id) -> + let pairs = + Big_map_overlay.fold + (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) + diff.map + [] + in + List.fold_left_es + (fun (acc, ctxt) (key_hash, key, value) -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> + unparse_comparable_data ~loc:() ctxt mode key_type key + >>=? fun (key_node, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost key_node) >>?= fun ctxt -> + let key = Micheline.strip_locations key_node in + (match value with + | None -> return (None, ctxt) + | Some x -> + unparse_data ~stack_depth:0 ctxt mode value_type x + >>=? fun (node, ctxt) -> Lwt.return - (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in - Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> - unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> - let key_type = Micheline.strip_locations kt in - let value_type = Micheline.strip_locations kv in - (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) - >>=? fun (ctxt, init, id) -> - let pairs : (Script_expr_hash.t * 'a * 'b option) list = - Big_map_overlay.fold - (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) - diff.map - [] - in - List.fold_left_es - (fun (acc, ctxt) (key_hash, key, value) -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - unparse_comparable_data ~loc:() ctxt mode key_type key - >>=? fun (key_node, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost key_node) - >>?= fun ctxt -> - let key = Micheline.strip_locations key_node in - (match value with - | None -> return (None, ctxt) - | Some x -> - unparse_data_aux ~stack_depth:0 ctxt mode value_type x - >>=? fun (node, ctxt) -> - Lwt.return - ( Gas.consume ctxt (Script.strip_locations_cost node) - >|? fun ctxt -> (Some (Micheline.strip_locations node), ctxt) )) - >|=? fun (value, ctxt) -> - let diff_item = Big_map.{key; key_hash; value} in - (diff_item :: acc, ctxt)) - ([], ctxt) - (List.rev pairs) - >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) + ( Gas.consume ctxt (Script.strip_locations_cost node) >|? fun ctxt -> + (Some (Micheline.strip_locations node), ctxt) )) + >|=? fun (value, ctxt) -> + let diff_item = Big_map.{key; key_hash; value} in + (diff_item :: acc, ctxt)) + ([], ctxt) + (List.rev pairs) + >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) let diff_of_sapling_state ctxt ~temporary ~ids_to_copy ({id; diff; memo_size} : Sapling.state) = @@ -5928,8 +5843,9 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = storage diff to show on the receipt and apply on the storage. *) -let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = - let[@coq_struct "ctxt"] rec aux : +let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode + ~temporary ids_to_copy acc ty x = + let rec aux : type a ac. context -> unparsing_mode -> @@ -5942,8 +5858,8 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t = fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - match[@coq_match_gadt_with_result] [@coq_match_with_default] (has_lazy_storage, ty, x) with - | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc) [@coq_type_annotation] + match (has_lazy_storage, ty, x) with + | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc) | Big_map_f, Big_map_t (_, _, _), map -> diff_of_big_map ctxt mode ~temporary ~ids_to_copy map >|=? fun (diff, id, ctxt) -> @@ -6005,8 +5921,7 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = (ctxt, M.OPS.empty, ids_to_copy, acc) (bindings M.boxed) >|=? fun (ctxt, m, ids_to_copy, acc) -> - let module M : - Boxed_map with type key = M.key and type value = M.value = struct + let module M = struct module OPS = M.OPS type key = M.key @@ -6016,14 +5931,13 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = let boxed = m let size = M.size - - let boxed_map_tag = () end in ( ctxt, Script_map.make (module M : Boxed_map with type key = M.key - and type value = M.value), + and type value = M.value + and boxed_map_tag = ()), ids_to_copy, acc ) | _, Option_t (_, _, _), None -> return (ctxt, None, ids_to_copy, acc) @@ -6042,7 +5956,7 @@ end (** Prematurely abort if [f] generates an error. Use this function without the [unit] type for [error] if you are in a case where errors are impossible. *) -let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : +let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : type a ac error. f:('acc, error) Fold_lazy_storage.result Lazy_storage.IdSet.fold_f -> init:'acc -> @@ -6053,7 +5967,7 @@ let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : (('acc, error) Fold_lazy_storage.result * context) tzresult = fun ~f ~init ctxt ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - match[@coq_match_gadt] [@coq_match_with_default] (has_lazy_storage, ty, x) with + match (has_lazy_storage, ty, x) with | Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _} -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) @@ -6101,21 +6015,18 @@ let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : m (ok (Fold_lazy_storage.Ok init, ctxt)) -let collect_lazy_storage ctxt ty x = +let[@coq_axiom_with_reason "gadt"] collect_lazy_storage ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f kind id (acc : (_, never) Fold_lazy_storage.result) = - let acc = - match[@coq_match_with_default] acc with Fold_lazy_storage.Ok acc -> acc - in + let acc = match acc with Fold_lazy_storage.Ok acc -> acc in Fold_lazy_storage.Ok (Lazy_storage.IdSet.add kind id acc) in fold_lazy_storage ~f:{f} ~init:no_lazy_storage_id ctxt ty x ~has_lazy_storage >>? fun (ids, ctxt) -> - match[@coq_match_with_default] ids with - | Fold_lazy_storage.Ok ids -> ok (ids, ctxt) + match ids with Fold_lazy_storage.Ok ids -> ok (ids, ctxt) -let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v - = +let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode + ~temporary ~to_duplicate ~to_update ty v = (* Basically [to_duplicate] are ids from the argument and [to_update] are ids from the storage before execution (i.e. it is safe to reuse them since they @@ -6128,15 +6039,10 @@ let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v if temporary then diffs else let dead = Lazy_storage.IdSet.diff to_update alive in - let f kind id acc = - (Lazy_storage.make - [@coq_implicit "a" "unit"] [@coq_implicit "u" "unit"]) - kind - id - Remove - :: acc - in - Lazy_storage.IdSet.fold_all {f} dead diffs + Lazy_storage.IdSet.fold_all + {f = (fun kind id acc -> Lazy_storage.make kind id Remove :: acc)} + dead + diffs in match diffs with | [] -> (v, None, ctxt) @@ -6145,7 +6051,7 @@ let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v let list_of_big_map_ids ids = Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids [] -let parse_data = parse_data_aux ~stack_depth:0 +let parse_data = parse_data ~stack_depth:0 let parse_comparable_data = parse_data ~legacy:false ~allow_forged:false @@ -6159,7 +6065,7 @@ let parse_instr : (a, s) stack_ty -> ((a, s) judgement * context) tzresult Lwt.t = fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty -> - parse_instr_aux + parse_instr ~stack_depth:0 ?type_logger tc_context @@ -6168,41 +6074,41 @@ let parse_instr : script_instr stack_ty -let unparse_data = unparse_data_aux ~stack_depth:0 +let unparse_data = unparse_data ~stack_depth:0 let unparse_code ctxt mode code = - (* Constants need to be expanded or [unparse_code_aux] may fail. *) + (* Constants need to be expanded or [unparse_code] may fail. *) Global_constants_storage.expand ctxt (strip_locations code) - >>=? fun (ctxt, code) -> unparse_code_aux ~stack_depth:0 ctxt mode (root code) + >>=? fun (ctxt, code) -> unparse_code ~stack_depth:0 ctxt mode (root code) let parse_contract_data context loc arg_ty contract ~entrypoint = parse_contract_data ~stack_depth:0 context loc arg_ty contract ~entrypoint let parse_toplevel ctxt ~legacy toplevel = Global_constants_storage.expand ctxt toplevel >>=? fun (ctxt, toplevel) -> - Lwt.return @@ parse_toplevel_aux ctxt ~legacy toplevel + Lwt.return @@ parse_toplevel ctxt ~legacy toplevel -let parse_comparable_ty = parse_comparable_ty_aux ~stack_depth:0 +let parse_comparable_ty = parse_comparable_ty ~stack_depth:0 -let parse_big_map_value_ty = parse_big_map_value_ty_aux ~stack_depth:0 +let parse_big_map_value_ty = parse_big_map_value_ty ~stack_depth:0 -let parse_packable_ty = parse_packable_ty_aux ~stack_depth:0 +let parse_packable_ty = parse_packable_ty ~stack_depth:0 -let parse_passable_ty = parse_passable_ty_aux ~stack_depth:0 +let parse_passable_ty = parse_passable_ty ~stack_depth:0 -let parse_any_ty = parse_any_ty_aux ~stack_depth:0 +let parse_any_ty = parse_any_ty ~stack_depth:0 -let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints +let parse_ty = parse_ty ~stack_depth:0 ~ret:Don't_parse_entrypoints let parse_parameter_ty_and_entrypoints = - parse_parameter_ty_and_entrypoints_aux ~stack_depth:0 + parse_parameter_ty_and_entrypoints ~stack_depth:0 -let get_single_sapling_state ctxt ty x = +let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i) single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result = - match[@coq_match_gadt] (kind, id) with - | (Lazy_storage.Kind.Sapling_state, (id : Sapling.Id.t)) -> ( + match kind with + | Lazy_storage.Kind.Sapling_state -> ( match single_id_opt with | Fold_lazy_storage.Ok None -> Fold_lazy_storage.Ok (Some id) | Fold_lazy_storage.Ok (Some _) -> @@ -6262,5 +6168,6 @@ let script_size (Saturation_repr.(add code_size storage_size |> to_int), cost) let typecheck_code ~legacy ~show_types ctxt code = - typecheck_code_inner ~legacy ~show_types ctxt code + typecheck_code ~legacy ~show_types ctxt code >|=? fun (Typechecked_code_internal {type_map; _}, ctxt) -> (type_map, ctxt) + \ No newline at end of file diff --git a/src/proto_alpha/lib_protocol/script_map.ml b/src/proto_alpha/lib_protocol/script_map.ml index b07f35ef9cb27..70f2c38f91f8d 100644 --- a/src/proto_alpha/lib_protocol/script_map.ml +++ b/src/proto_alpha/lib_protocol/script_map.ml @@ -163,5 +163,7 @@ let map_es_in_context : let boxed = map let size = Box.size + + let boxed_map_tag = () end), ctxt ) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 316064dbd5d65..898d70e20e426 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -96,7 +96,7 @@ let ty_traverse_f = ({apply} : nodes_and_size ty_traverse) let ty_size : type a ac. (a, ac) ty -> nodes_and_size = - fun ty -> ty_traverse ty zero Ty_size.f + fun ty -> ty_traverse ty zero ty_traverse_f let stack_ty_size s = let apply : type a s. nodes_and_size -> (a, s) stack_ty -> nodes_and_size = @@ -309,12 +309,12 @@ and[@coq_mutual_as_notation] big_map_size_aux : (* The following recursive call cannot introduce a stack overflow because this would require a key of type big_map while big_map is not comparable. *) - let accu = value_size ~count_lambda_nodes accu cty key in + let accu = value_size_aux ~count_lambda_nodes accu cty key in match value with | None -> accu | Some value -> let accu = ret_succ_adding accu h1w in - (value_size [@ocaml.tailcall]) ~count_lambda_nodes accu ty' value) + (value_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu ty' value) diff.map accu in @@ -368,7 +368,7 @@ and[@coq_struct "t_value"] kinstr_size_aux : | IConst (kinfo, x, k) -> let accu = ret_succ_adding accu (base kinfo +! word_size) in let (Ty_ex_c top_ty) = stack_top_ty (kinfo_of_kinstr k).kstack_ty in - (value_size [@ocaml.tailcall]) ~count_lambda_nodes accu top_ty x + (value_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu top_ty x | ICons_pair (kinfo, _) -> ret_succ_adding accu (base kinfo) | ICar (kinfo, _) -> ret_succ_adding accu (base kinfo) | ICdr (kinfo, _) -> ret_succ_adding accu (base kinfo) @@ -623,7 +623,7 @@ let lambda_size lam = *) let lambda_nodes, lambda_size = - lambda_size ~count_lambda_nodes:true zero lam + lambda_size_aux ~count_lambda_nodes:true zero lam in let lambda_extra_size_nodes, lambda_extra_size = lambda_extra_size lam in let size = (lambda_size *? 157 /? 100) +! (lambda_extra_size *? 18 /? 100) in @@ -632,12 +632,12 @@ let lambda_size lam = let kinstr_size kinstr = let kinstr_extra_size_nodes, kinstr_extra_size = kinstr_extra_size kinstr in let kinstr_nodes, kinstr_size = - kinstr_size ~count_lambda_nodes:true zero kinstr + kinstr_size_aux ~count_lambda_nodes:true zero kinstr in let size = (kinstr_size *? 157 /? 100) +! (kinstr_extra_size *? 18 /? 100) in (Nodes.add kinstr_nodes kinstr_extra_size_nodes, size) -let value_size ty x = value_size ~count_lambda_nodes:true zero ty x +let value_size ty x = value_size_aux ~count_lambda_nodes:true zero ty x module Internal_for_tests = struct let ty_size = ty_size diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index d9cfce579a326..219ad6927861d 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1608,7 +1608,7 @@ module Sc_rollup = struct module Stakers : Non_iterable_indexed_carbonated_data_storage with type key = Signature.Public_key_hash.t - and type value = Sc_rollup_repr.Commitment_hash.t + and type value = Sc_rollup_commitment_repr.Hash.t and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) diff --git a/src/proto_alpha/lib_protocol/ticket_scanner.ml b/src/proto_alpha/lib_protocol/ticket_scanner.ml index dc41ec1ac2a2c..67be20314fbe2 100644 --- a/src/proto_alpha/lib_protocol/ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/ticket_scanner.ml @@ -337,7 +337,7 @@ module Ticket_collection = struct | False_ht, _ -> (k [@ocaml.tailcall]) ctxt acc | Pair_ht (hty1, hty2), Pair_t (ty1, ty2, _, _) -> let l, r = x in - (tickets_of_value [@ocaml.tailcall]) + (tickets_of_value_aux [@ocaml.tailcall]) ~include_lazy ~allow_zero_amount_tickets ctxt diff --git a/src/proto_alpha/lib_protocol/token.mli b/src/proto_alpha/lib_protocol/token.mli index d2e733e9eb185..d6e72933ab8c1 100644 --- a/src/proto_alpha/lib_protocol/token.mli +++ b/src/proto_alpha/lib_protocol/token.mli @@ -77,7 +77,7 @@ type infinite_sink = | Lost_endorsing_rewards of Signature.Public_key_hash.t * bool * bool | Tx_rollup_rejection_punishments | Sc_rollup_refutation_punishments - | Burned ] + | Burned (** [sink] is the type of token receivers. Token receivers that are not containers are considered to have infinite capacity. *) -- GitLab From 9c535735fa9298857d68d81d15bcea67bd1be33e Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 21 Jun 2022 16:11:48 -0500 Subject: [PATCH 082/105] more rebase fixes --- src/proto_alpha/lib_plugin/RPC.ml | 16 ++-- .../lib_protocol/alpha_context.mli | 8 +- src/proto_alpha/lib_protocol/apply.ml | 14 +-- src/proto_alpha/lib_protocol/apply_results.ml | 47 ++------- .../lib_protocol/apply_results.mli | 2 + .../lib_protocol/script_ir_translator.ml | 4 +- .../test/integration/test_frozen_bonds.ml | 18 ++-- .../test/integration/test_token.ml | 95 +++++++++++-------- .../test/unit/test_sc_rollup_storage.ml | 16 ++-- 9 files changed, 104 insertions(+), 116 deletions(-) diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 03c8f89a1e060..2c9c71aac4d1a 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -50,7 +50,7 @@ module Registration = struct let register0_fullctxt ~chunked s f = patched_services := RPC_directory.register ~chunked !patched_services s (fun ctxt q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let register0 ~chunked s f = @@ -60,7 +60,7 @@ module Registration = struct patched_services := RPC_directory.register ~chunked !patched_services s (fun ctxt q i -> let mode = - if q#successor_level then `Successor_level else `Head_level + if q#successor_level then Services_registration.Successor_level else Head_level in Services_registration.rpc_init ctxt mode >>=? fun ctxt -> f ctxt q i) @@ -75,7 +75,7 @@ module Registration = struct let opt_register0_fullctxt ~chunked s f = patched_services := RPC_directory.opt_register ~chunked !patched_services s (fun ctxt q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt q i) let opt_register0 ~chunked s f = @@ -88,7 +88,7 @@ module Registration = struct !patched_services s (fun (ctxt, arg) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let opt_register1_fullctxt ~chunked s f = @@ -98,7 +98,7 @@ module Registration = struct !patched_services s (fun (ctxt, arg) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg q i) let register1 ~chunked s f = @@ -114,7 +114,7 @@ module Registration = struct !patched_services s (fun ((ctxt, arg1), arg2) q i -> - Services_registration.rpc_init ctxt `Head_level >>=? fun ctxt -> + Services_registration.rpc_init ctxt Head_level >>=? fun ctxt -> f ctxt arg1 arg2 q i) let register2 ~chunked s f = @@ -915,8 +915,8 @@ module Scripts = struct Token.transfer ~origin:Simulation ctxt - `Minted - (`Contract dummy_contract) + (Source_infinite Minted) + (Sink_container (Contract dummy_contract)) balance >>=? fun (ctxt, _) -> return (ctxt, dummy_contract_hash) in diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 72c4b4bc9b065..16d9790e2a647 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -1518,7 +1518,7 @@ module Ticket_hash : sig end module Contract : sig - type t = + type t = Contract_repr.t = | Implicit of Signature.Public_key_hash.t | Originated of Contract_hash.t @@ -1658,7 +1658,7 @@ end (** This module re-exports definitions from {!Tx_rollup_repr} and {!Tx_rollup_storage}. *) module Tx_rollup : sig - include BASIC_DATA + include BASIC_DATA with type t = Tx_rollup_repr.t val rpc_arg : t RPC_arg.arg @@ -2180,13 +2180,13 @@ end TODO : find a better way to resolve the circular dependency https://gitlab.com/tezos/tezos/-/issues/3147 *) module Sc_rollup_repr : sig - module Address : S.HASH + module Address : S.HASH with type t = Sc_rollup_repr.t type t = Address.t end module Bond_id : sig - type t = + type t = Bond_id_repr.t = | Tx_rollup_bond_id of Tx_rollup.t | Sc_rollup_bond_id of Sc_rollup_repr.t diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 1c4347be4c823..10a96181c3a30 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -830,7 +830,7 @@ let apply_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~parameter (* If the implicit contract is not yet allocated at this point then the next transfer of tokens will allocate it. *) Contract.allocated ctxt contract >>= fun already_allocated -> - Token.transfer ctxt (Source_container (Contract source)) (Sink_container (assert false) (* (Contract contract) *)) amount + Token.transfer ctxt (Source_container (Contract source)) (Sink_container (Contract contract)) amount >>=? fun (ctxt, balance_updates) -> let is_unit = match parameter with @@ -874,7 +874,7 @@ let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount does not exist, [Script_cache.find] will signal that by returning [None] and we'll fail. *) - Token.transfer ctxt (Source_container (Contract source)) (Sink_container (assert false) (*(Contract contract)*)) amount + Token.transfer ctxt (Source_container (Contract source)) (Sink_container (Contract contract)) amount >>=? fun (ctxt, balance_updates) -> Script_cache.find ctxt contract_hash >>=? fun (ctxt, cache_key, script) -> match script with @@ -891,7 +891,7 @@ let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount let step_constants = let open Script_interpreter in { - (*source;*) source = assert false; + source; payer = Contract.Implicit payer; self = contract_hash; amount; @@ -1029,7 +1029,7 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~payer in Tx_rollup_state.get ctxt dst_rollup >>=? fun (ctxt, state) -> Tx_rollup_state.burn_cost ~limit:None state message_size >>?= fun cost -> - Token.transfer ctxt (Source_container (Contract (Contract.Implicit payer))) (Sink_container Burned) cost + Token.transfer ctxt (Source_container (Contract (Contract.Implicit payer))) (Sink_infinite Burned) cost >>=? fun (ctxt, balance_updates) -> Tx_rollup_inbox.append_message ctxt dst_rollup state deposit >>=? fun (ctxt, state, paid_storage_size_diff) -> @@ -2147,7 +2147,7 @@ let burn_manager_storage_fees : 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 + let payer = Token.Source_container (Contract (Contract.Implicit payer)) in match smopr with | Transaction_result transaction_result -> burn_transaction_storage_fees @@ -2257,7 +2257,7 @@ let burn_internal_storage_fees : (context * Z.t * kind successful_internal_manager_operation_result) tzresult Lwt.t = fun ctxt smopr ~storage_limit ~payer -> - let payer = `Contract (Contract.Implicit payer) in + let payer = Token.Source_container (Contract (Contract.Implicit payer)) in match smopr with | ITransaction_result transaction_result -> burn_transaction_storage_fees @@ -2887,7 +2887,7 @@ let punish_delegate ctxt delegate level mistake mk_result ~payload_producer = Token.transfer ctxt (Source_infinite Double_signing_evidence_rewards) - (Source_container (Contract (Contract.Implicit payload_producer))) + (Sink_container (Contract (Contract.Implicit payload_producer))) reward | Error _ -> (* reward is Tez.zero *) return (ctxt, [])) >|=? fun (ctxt, reward_balance_updates) -> diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 37a8ff97898a7..f05a27100ce5d 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -2255,25 +2255,12 @@ let rec packed_contents_result_list_of_list = function Ok (Contents_result_list (Cons_result (o, os))) | _ -> Error "cannot decode ill-formed operation result") +let rec to_list = function + | Contents_result_list (Single_result o) -> [Contents_result o] + | Contents_result_list (Cons_result (o, os)) -> + Contents_result o :: to_list (Contents_result_list os) + let contents_result_list_encoding = - let rec to_list = function - | Contents_result_list (Single_result o) -> [Contents_result o] - | Contents_result_list (Cons_result (o, os)) -> - Contents_result o :: to_list (Contents_result_list os) - in - let rec of_list = function - | [] -> Error "cannot decode empty operation result" - | [Contents_result o] -> Ok (Contents_result_list (Single_result o)) - | Contents_result o :: os -> ( - of_list os >>? fun (Contents_result_list os) -> - match (o, os) with - | Manager_operation_result _, Single_result (Manager_operation_result _) - -> - Ok (Contents_result_list (Cons_result (o, os))) - | Manager_operation_result _, Cons_result _ -> - Ok (Contents_result_list (Cons_result (o, os))) - | _ -> Error "cannot decode ill-formed operation result") - in def "operation.alpha.contents_list_result" @@ conv_with_guard packed_contents_result_list_to_list @@ -2319,26 +2306,10 @@ let rec packed_contents_and_result_list_of_list = function | _ -> Error "cannot decode ill-formed combined operation result") let contents_and_result_list_encoding = - let rec to_list = function - | Contents_and_result_list (Single_and_result (op, res)) -> - [Contents_and_result (op, res)] - | Contents_and_result_list (Cons_and_result (op, res, rest)) -> - Contents_and_result (op, res) :: to_list (Contents_and_result_list rest) - in - let rec of_list = function - | [] -> Error "cannot decode empty combined operation result" - | [Contents_and_result (op, res)] -> - Ok (Contents_and_result_list (Single_and_result (op, res))) - | Contents_and_result (op, res) :: rest -> ( - of_list rest >>? fun (Contents_and_result_list rest) -> - match (op, rest) with - | Manager_operation _, Single_and_result (Manager_operation _, _) -> - Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | Manager_operation _, Cons_and_result (_, _, _) -> - Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | _ -> Error "cannot decode ill-formed combined operation result") - in - conv_with_guard to_list of_list (Variable.list contents_and_result_encoding) + conv_with_guard + packed_contents_and_result_list_to_list + packed_contents_and_result_list_of_list + (Variable.list contents_and_result_encoding) type 'kind operation_metadata = {contents : 'kind contents_result_list} diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index e59d318e5930c..eddf70d4ff658 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -404,6 +404,8 @@ val unpack_contents_list : val packed_contents_result_list_to_list : packed_contents_result_list -> packed_contents_result list +val to_list : packed_contents_result_list -> packed_contents_result list + type ('a, 'b) eq = Eq : ('a, 'a) eq val kind_equal_list : diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index d192cc971250c..ad92c60ddb173 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5931,13 +5931,15 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode let boxed = m let size = M.size + + let boxed_map_tag = () end in ( ctxt, Script_map.make (module M : Boxed_map with type key = M.key and type value = M.value - and boxed_map_tag = ()), + ), ids_to_copy, acc ) | _, Option_t (_, _, _), None -> return (ctxt, None, ids_to_copy, acc) diff --git a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml index b4d9c1e0feea8..e731c5edcdfef 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml @@ -367,9 +367,9 @@ let test_scenario scenario = >>=? fun (ctxt, user_contract, user_account, delegate1) -> let delegate2, delegate_pk2, _ = Signature.generate_key () in let delegate_contract2 = Contract.Implicit delegate2 in - let delegate_account2 = `Contract delegate_contract2 in + let delegate_account2 = Token.Contract delegate_contract2 in let delegate_balance2 = big_random_amount () in - Token.transfer ctxt `Minted delegate_account2 delegate_balance2 + Token.transfer ctxt (Source_infinite Minted) (Sink_container delegate_account2) delegate_balance2 >>>=? fun (ctxt, _) -> (* Configure delegate, as a delegate by self-delegation, for which revealing its manager key is a prerequisite. *) @@ -380,8 +380,8 @@ let test_scenario scenario = let bond_id1 = Bond_id.Tx_rollup_bond_id tx_rollup1 in let bond_id2 = Bond_id.Tx_rollup_bond_id tx_rollup2 in let deposit_amount = Tez.of_mutez_exn 1000L in - let deposit_account1 = `Frozen_bonds (user_contract, bond_id1) in - let deposit_account2 = `Frozen_bonds (user_contract, bond_id2) in + let deposit_account1 = Token.Frozen_bonds (user_contract, bond_id1) in + let deposit_account2 = Token.Frozen_bonds (user_contract, bond_id2) in let do_delegate ?(delegate = delegate1) ctxt = (* Fetch staking balance before delegation *) Delegate.staking_balance ctxt delegate >>>=? fun staking_balance -> @@ -403,7 +403,7 @@ let test_scenario scenario = Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1 -> Delegate.staking_balance ctxt delegate2 >>>=? fun staking_balance2 -> (* Freeze a tx-rollup deposit. *) - Token.transfer ctxt user_account deposit_account deposit_amount + Token.transfer ctxt (Source_container user_account) (Sink_container deposit_account) deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after freeze. *) Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1' -> @@ -419,7 +419,7 @@ let test_scenario scenario = Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1 -> Delegate.staking_balance ctxt delegate2 >>>=? fun staking_balance2 -> (* Unfreeze the deposit *) - Token.transfer ctxt deposit_account user_account deposit_amount + Token.transfer ctxt (Source_container deposit_account) (Sink_container user_account) deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after unfreeze. *) Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1' -> @@ -440,8 +440,8 @@ let test_scenario scenario = (* Slash the deposit *) Token.transfer ctxt - deposit_account - `Tx_rollup_rejection_punishments + (Source_container deposit_account) + (Sink_infinite Tx_rollup_rejection_punishments) deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after slash. *) @@ -504,6 +504,8 @@ let test_scenario scenario = ~do_unfreeze ~do_slash + + let test_delegate_freeze_unfreeze_undelegate () = test_scenario (fun diff --git a/src/proto_alpha/lib_protocol/test/integration/test_token.ml b/src/proto_alpha/lib_protocol/test/integration/test_token.ml index dda20dffbfdee..cb0ed4917efb9 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_token.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_token.ml @@ -60,9 +60,9 @@ let mk_rollup () = Tx_rollup.Internal_for_tests.originated_tx_rollup nonce let test_simple_balances () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - let src = Contract (Contract.Implicit pkh) in + let src = Token.Contract (Contract.Implicit pkh) in let pkh, _pk, _sk = Signature.generate_key () in - let dest = Contract (Contract.Implicit pkh) in + let dest = Token.Contract (Contract.Implicit pkh) in let amount = Tez.one in wrap (Token.transfer ctxt (Source_container src) (Sink_container dest) amount) >>=? fun (ctxt', _) -> @@ -144,7 +144,7 @@ let test_allocated () = let dest = Token.Delegate_balance pkh in test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ -> let pkh, _pk, _sk = Signature.generate_key () in - let dest = Contract (Contract.Implicit pkh) in + let dest = Token.Contract (Contract.Implicit pkh) in test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ -> let dest = Token.Collected_commitments Blinded_public_key_hash.zero in test_allocated_and_deallocated_when_empty ctxt dest >>=? fun _ -> @@ -154,7 +154,7 @@ let test_allocated () = test_allocated_and_still_allocated_when_empty ctxt dest true >>=? fun _ -> let dest = let bond_id = Bond_id.Tx_rollup_bond_id (mk_rollup ()) in - Frozen_bonds (Contract.Implicit pkh, bond_id) + Token.Frozen_bonds (Contract.Implicit pkh, bond_id) in test_allocated_and_deallocated_when_empty ctxt dest @@ -169,9 +169,9 @@ let check_sink_balances ctxt ctxt' dest amount = (`Contract pkh) instead. *) let force_allocation_if_need_be ctxt account = match account with - | Delegate_balance pkh -> - let account = Contract (Contract.Implicit pkh) in - wrap (Token.transfer ctxt Minted account Tez.one_mutez) >|=? fst + | Token.Delegate_balance pkh -> + let account = Token.Contract (Contract.Implicit pkh) in + wrap (Token.transfer ctxt (Source_infinite Minted) (Sink_container account) Tez.one_mutez) >|=? fst | _ -> return ctxt let test_transferring_to_sink ctxt sink amount expected_bupds = @@ -308,7 +308,7 @@ let test_transferring_to_burned ctxt = ]) true >>=? fun () -> - wrap (Token.transfer ctxt `Minted `Sc_rollup_refutation_punishments amount) + wrap (Token.transfer ctxt (Source_infinite Minted) (Sink_infinite Sc_rollup_refutation_punishments) amount) >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ @@ -582,23 +582,23 @@ let cast_to_container_type x = (** Generates all combinations of constructors. *) let build_test_cases () = create_context () >>=? fun (ctxt, pkh) -> - let origin = Contract (Contract.Implicit pkh) in + let origin = Token.Contract (Contract.Implicit pkh) in let user1, _, _ = Signature.generate_key () in - let user1c = Contract (Contract.Implicit user1) in + let user1c = Token.Contract (Contract.Implicit user1) in let user2, _, _ = Signature.generate_key () in - let user2c = Contract (Contract.Implicit user2) in + let user2c = Token.Contract (Contract.Implicit user2) in let baker1, baker1_pk, _ = Signature.generate_key () in - let baker1c = Contract (Contract.Implicit baker1) in + let baker1c = Token.Contract (Contract.Implicit baker1) in let baker2, baker2_pk, _ = Signature.generate_key () in - let baker2c = Contract (Contract.Implicit baker2) in + let baker2c = Token.Contract (Contract.Implicit baker2) in (* Allocate contracts for user1, user2, baker1, and baker2. *) - wrap (Token.transfer ctxt origin (Sink_container user1c) (random_amount ())) + wrap (Token.transfer ctxt (Source_container origin) (Sink_container user1c) (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin (Sink_container user2c) (random_amount ())) + wrap (Token.transfer ctxt (Source_container origin) (Sink_container user2c) (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin (Sink_container baker1c) (random_amount ())) + wrap (Token.transfer ctxt (Source_container origin) (Sink_container baker1c) (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin (Sink_container baker2c) (random_amount ())) + wrap (Token.transfer ctxt (Source_container origin) (Sink_container baker2c) (random_amount ())) >>=? fun (ctxt, _) -> (* Configure baker1, and baker2 as delegates by self-delegation, for which revealing their manager key is a prerequisite. *) @@ -655,29 +655,40 @@ let build_test_cases () = return (ctxt, List.product src_list dest_list) let rec check_balances ctxt ctxt' src dest amount = - match (cast_to_container_type src, cast_to_container_type dest) with - | None, None -> return_unit - | ( Some (`Delegate_balance d), - Some (`Contract (Contract.Implicit c) as contract) ) - | ( Some (`Contract (Contract.Implicit c) as contract), - Some (`Delegate_balance d) ) - when d = c -> + match (src, dest) with + | ( Token.Source_container (Delegate_balance d), + Token.Sink_container (Contract c as contract) ) + when Contract.Implicit d = c -> (* src and dest are in fact referring to the same contract *) - check_balances ctxt ctxt' contract contract amount - | Some src, Some dest when src = dest -> + check_balances + ctxt + ctxt' + (Source_container contract) + (Sink_container contract) + amount + | ( Source_container (Contract c as contract), + Sink_container (Delegate_balance d) ) + when Contract.Implicit d = c -> + (* src and dest are in fact referring to the same contract *) + check_balances + ctxt + ctxt' + (Source_container contract) + (Sink_container contract) + amount + | (Source_container src, Sink_container dest) when src = dest -> (* src and dest are the same contract *) wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) -> wrap (Token.balance ctxt' dest) >>=? fun (_, bal_dest') -> Assert.equal_tez ~loc:__LOC__ bal_dest bal_dest' - | Some src, None -> check_src_balances ctxt ctxt' src amount - | None, Some dest -> check_sink_balances ctxt ctxt' dest amount - | Some src, Some dest -> + | (Source_container src, Sink_container dest) -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> check_sink_balances ctxt ctxt' dest amount | (Source_container src, _) -> check_src_balances ctxt ctxt' src amount | (_, Sink_container dest) -> check_sink_balances ctxt ctxt' dest amount | (_, _) -> return_unit + let test_all_combinations_of_sources_and_sinks () = Random.init 0 ; build_test_cases () >>=? fun (ctxt, cases) -> @@ -687,10 +698,10 @@ let test_all_combinations_of_sources_and_sinks () = | Token.Source_container src -> wrap (Token.transfer - ctxt - (Source_infinite Minted) - (Sink_container src) - amount) + ctxt + (Source_infinite Minted) + (Sink_container src) + amount) >>=? fun (ctxt, _) -> return ctxt | _ -> return ctxt) >>=? fun ctxt -> @@ -796,26 +807,26 @@ let test_transfer_n_with_empty_source () = let test_transfer_n_with_non_empty_source () = Random.init 0 ; create_context () >>=? fun (ctxt, pkh) -> - let origin = Contract (Contract.Implicit pkh) in + let origin = Token.Contract (Contract.Implicit pkh) in let user1, _, _ = Signature.generate_key () in - let user1c = Contract (Contract.Implicit user1) in + let user1c = Token.Contract (Contract.Implicit user1) in let user2, _, _ = Signature.generate_key () in - let user2c = Contract (Contract.Implicit user2) in + let user2c = Token.Contract (Contract.Implicit user2) in let user3, _, _ = Signature.generate_key () in - let user3c = Contract (Contract.Implicit user3) in + let user3c = Token.Contract (Contract.Implicit user3) in let user4, _, _ = Signature.generate_key () in - let user4c = Contract (Contract.Implicit user4) in + let user4c = Token.Contract (Contract.Implicit user4) in (* Allocate contracts for user1, user2, user3, and user4. *) let amount = match Tez.of_mutez 1000L with None -> assert false | Some x -> x in - wrap (Token.transfer ctxt origin (Sink_container user1c) amount) + wrap (Token.transfer ctxt (Source_container origin) (Sink_container user1c) amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin (Sink_container user2c) amount) + wrap (Token.transfer ctxt (Source_container origin) (Sink_container user2c) amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin (Sink_container user3c) amount) + wrap (Token.transfer ctxt (Source_container origin) (Sink_container user3c) amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt origin (Sink_container user4c) (random_amount ())) + wrap (Token.transfer ctxt (Source_container origin) (Sink_container user4c) (random_amount ())) >>=? fun (ctxt, _) -> let sources = [ diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml index 306ecf4be37f1..d124c8a81a684 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml @@ -71,7 +71,7 @@ let new_context () = let contract = Contract_repr.Implicit pkh in let+ ctxt, _ = lift - @@ Token.transfer ctxt `Minted (`Contract contract) initial_staker_balance + @@ Token.transfer ctxt (Source_infinite Minted) (Sink_container (Contract contract)) initial_staker_balance in ctxt in @@ -139,10 +139,10 @@ let deposit_stake_and_check_balances ctxt rollup staker = staker in let* () = - assert_balance_decreased ctxt ctxt' (`Contract staker_contract) stake + assert_balance_decreased ctxt ctxt' (Contract staker_contract) stake in let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in - let bonds_account = `Frozen_bonds (staker_contract, bond_id) in + let bonds_account = Token.Frozen_bonds (staker_contract, bond_id) in let+ () = assert_balance_increased ctxt ctxt' bonds_account stake in ctxt') @@ -267,7 +267,7 @@ let test_deposit_by_underfunded_staker () = let staker_contract = Contract_repr.Implicit staker in let* ctxt, _ = lift - @@ Token.transfer ctxt `Minted (`Contract staker_contract) staker_balance + @@ Token.transfer ctxt (Source_infinite Minted) (Sink_container (Contract staker_contract)) staker_balance in assert_fails_with ~loc:__LOC__ @@ -306,10 +306,10 @@ let remove_staker_and_check_balances ctxt rollup staker = lift @@ Sc_rollup_stake_storage.remove_staker ctxt rollup staker in let* () = - assert_balance_unchanged ctxt ctxt' (`Contract staker_contract) + assert_balance_unchanged ctxt ctxt' (Contract staker_contract) in let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in - let bonds_account = `Frozen_bonds (staker_contract, bond_id) in + let bonds_account = Token.Frozen_bonds (staker_contract, bond_id) in let+ () = assert_balance_decreased ctxt ctxt' bonds_account stake in ctxt') @@ -330,10 +330,10 @@ let withdraw_stake_and_check_balances ctxt rollup staker = lift @@ Sc_rollup_stake_storage.withdraw_stake ctxt rollup staker in let* () = - assert_balance_increased ctxt ctxt' (`Contract staker_contract) stake + assert_balance_increased ctxt ctxt' (Contract staker_contract) stake in let bond_id = Bond_id_repr.Sc_rollup_bond_id rollup in - let bonds_account = `Frozen_bonds (staker_contract, bond_id) in + let bonds_account = Token.Frozen_bonds (staker_contract, bond_id) in let+ () = assert_balance_decreased ctxt ctxt' bonds_account stake in ctxt') -- GitLab From 6bac5fd9eb7a9c87f236b15e088b58a2e903fea0 Mon Sep 17 00:00:00 2001 From: emarzion Date: Wed, 22 Jun 2022 12:15:38 -0500 Subject: [PATCH 083/105] formatting --- src/proto_alpha/lib_plugin/RPC.ml | 3 +- .../lib_protocol/alpha_context.mli | 2 +- src/proto_alpha/lib_protocol/apply.ml | 34 +++++-- src/proto_alpha/lib_protocol/apply_results.ml | 15 ++-- .../lib_protocol/delegate_storage.ml | 6 +- .../lib_protocol/dependent_bool.ml | 8 +- src/proto_alpha/lib_protocol/indexable.ml | 4 +- src/proto_alpha/lib_protocol/merkle_list.ml | 5 +- .../lib_protocol/operation_repr.mli | 1 - .../lib_protocol/sc_rollup_arith.ml | 3 +- .../lib_protocol/script_interpreter.ml | 47 ++++++---- .../lib_protocol/script_interpreter_defs.ml | 4 +- .../lib_protocol/script_ir_translator.ml | 4 +- .../lib_protocol/script_ir_translator.mli | 1 + .../lib_protocol/script_typed_ir_size.ml | 76 ++++++++-------- .../test/integration/test_frozen_bonds.ml | 24 +++-- .../test/integration/test_token.ml | 90 ++++++++++++++----- .../test/unit/test_sc_rollup_storage.ml | 12 ++- .../lib_protocol/tx_rollup_parameters.ml | 2 +- 19 files changed, 225 insertions(+), 116 deletions(-) diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 2c9c71aac4d1a..04dbe97d23037 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -60,7 +60,8 @@ module Registration = struct patched_services := RPC_directory.register ~chunked !patched_services s (fun ctxt q i -> let mode = - if q#successor_level then Services_registration.Successor_level else Head_level + if q#successor_level then Services_registration.Successor_level + else Head_level in Services_registration.rpc_init ctxt mode >>=? fun ctxt -> f ctxt q i) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 16d9790e2a647..4ae678ddcc161 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2186,7 +2186,7 @@ module Sc_rollup_repr : sig end module Bond_id : sig - type t = Bond_id_repr.t = + type t = Bond_id_repr.t = | Tx_rollup_bond_id of Tx_rollup.t | Sc_rollup_bond_id of Sc_rollup_repr.t diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 10a96181c3a30..b1be1de66e2d3 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -830,7 +830,11 @@ let apply_transaction_to_implicit ~ctxt ~source ~amount ~pkh ~parameter (* If the implicit contract is not yet allocated at this point then the next transfer of tokens will allocate it. *) Contract.allocated ctxt contract >>= fun already_allocated -> - Token.transfer ctxt (Source_container (Contract source)) (Sink_container (Contract contract)) amount + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, balance_updates) -> let is_unit = match parameter with @@ -874,7 +878,11 @@ let apply_transaction_to_smart_contract ~ctxt ~source ~contract_hash ~amount does not exist, [Script_cache.find] will signal that by returning [None] and we'll fail. *) - Token.transfer ctxt (Source_container (Contract source)) (Sink_container (Contract contract)) amount + Token.transfer + ctxt + (Source_container (Contract source)) + (Sink_container (Contract contract)) + amount >>=? fun (ctxt, balance_updates) -> Script_cache.find ctxt contract_hash >>=? fun (ctxt, cache_key, script) -> match script with @@ -1029,7 +1037,11 @@ let apply_transaction_to_tx_rollup ~ctxt ~parameters_ty ~parameters ~payer in Tx_rollup_state.get ctxt dst_rollup >>=? fun (ctxt, state) -> Tx_rollup_state.burn_cost ~limit:None state message_size >>?= fun cost -> - Token.transfer ctxt (Source_container (Contract (Contract.Implicit payer))) (Sink_infinite Burned) cost + Token.transfer + ctxt + (Source_container (Contract (Contract.Implicit payer))) + (Sink_infinite Burned) + cost >>=? fun (ctxt, balance_updates) -> Tx_rollup_inbox.append_message ctxt dst_rollup state deposit >>=? fun (ctxt, state, paid_storage_size_diff) -> @@ -2067,7 +2079,11 @@ let precheck_manager_contents (type kind) ctxt (op : kind Kind.manager contents) return ctxt) >>=? fun ctxt -> Contract.increment_counter ctxt source >>=? fun ctxt -> - Token.transfer ctxt (Source_container (Contract source_contract)) (Sink_container Block_fees) fee + Token.transfer + ctxt + (Source_container (Contract source_contract)) + (Sink_container Block_fees) + fee let burn_transaction_storage_fees ctxt trr ~storage_limit ~payer = match trr with @@ -2912,8 +2928,8 @@ let punish_double_endorsement_or_preendorsement (type kind) ctxt ~chain_id match[@coq_match_with_default] (op1.protocol_data.contents, op2.protocol_data.contents) with - | (Single (Preendorsement e1), Single (Preendorsement e2)) - | (Single (Endorsement e1), Single (Endorsement e2)) -> + | Single (Preendorsement e1), Single (Preendorsement e2) + | Single (Endorsement e1), Single (Endorsement e2) -> let kind = if preendorsement then Preendorsement else Endorsement in let op1_hash = Operation.hash op1 in let op2_hash = Operation.hash op2 in @@ -3119,7 +3135,11 @@ let apply_contents_list (type kind) ctxt chain_id (apply_mode : apply_mode) mode Nonce.reveal ctxt level nonce >>=? fun ctxt -> let tip = Constants.seed_nonce_revelation_tip ctxt in let contract = Contract.Implicit payload_producer in - Token.transfer ctxt (Source_infinite Revelation_rewards) (Sink_container (Contract contract)) tip + Token.transfer + ctxt + (Source_infinite Revelation_rewards) + (Sink_container (Contract contract)) + tip >|=? fun (ctxt, balance_updates) -> (ctxt, Single_result (Seed_nonce_revelation_result balance_updates)) | Single (Double_preendorsement_evidence {op1; op2}) -> diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index f05a27100ce5d..4c8c931facb5d 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -918,7 +918,8 @@ module Manager_result = struct Some op | _ -> None) ~proj:(function[@coq_match_with_default] - | Sc_rollup_publish_result {consumed_gas; staked_hash; published_at_level; balance_updates} -> + | Sc_rollup_publish_result + {consumed_gas; staked_hash; published_at_level; balance_updates} -> (consumed_gas, staked_hash, published_at_level, balance_updates)) ~kind:Kind.Sc_rollup_publish_manager_kind ~inj: @@ -2248,10 +2249,10 @@ let rec packed_contents_result_list_of_list = function packed_contents_result_list_of_list os >>? fun (Contents_result_list os) -> match (o, os) with - | (Manager_operation_result _, Single_result (Manager_operation_result _)) + | Manager_operation_result _, Single_result (Manager_operation_result _) -> Ok (Contents_result_list (Cons_result (o, os))) - | (Manager_operation_result _, Cons_result _) -> + | Manager_operation_result _, Cons_result _ -> Ok (Contents_result_list (Cons_result (o, os))) | _ -> Error "cannot decode ill-formed operation result") @@ -2299,9 +2300,9 @@ let rec packed_contents_and_result_list_of_list = function packed_contents_and_result_list_of_list rest >>? fun (Contents_and_result_list rest) -> match (op, rest) with - | (Manager_operation _, Single_and_result (Manager_operation _, _)) -> + | Manager_operation _, Single_and_result (Manager_operation _, _) -> Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) - | (Manager_operation _, Cons_and_result (_, _, _)) -> + | Manager_operation _, Cons_and_result (_, _, _) -> Ok (Contents_and_result_list (Cons_and_result (op, res, rest))) | _ -> Error "cannot decode ill-formed combined operation result") @@ -3020,8 +3021,8 @@ let rec pack_contents_list : kind contents_and_result_list = fun contents res -> match[@coq_match_with_default] (contents, res) with - | (Single op, Single_result res) -> Single_and_result (op, res) - | (Cons (op, ops), Cons_result (res, ress)) -> + | Single op, Single_result res -> Single_and_result (op, res) + | Cons (op, ops), Cons_result (res, ress) -> Cons_and_result (op, res, pack_contents_list ops ress) | ( Single (Manager_operation _), Cons_result (Manager_operation_result _, Single_result _) ) -> diff --git a/src/proto_alpha/lib_protocol/delegate_storage.ml b/src/proto_alpha/lib_protocol/delegate_storage.ml index afbb50150559b..73ae8537e4ed1 100644 --- a/src/proto_alpha/lib_protocol/delegate_storage.ml +++ b/src/proto_alpha/lib_protocol/delegate_storage.ml @@ -953,7 +953,11 @@ let record_baking_activity_and_pay_rewards_and_fees ctxt ~payload_producer in let pay_block_producer ctxt delegate bonus = let contract = Contract_repr.Implicit delegate in - Token.transfer ctxt (Source_infinite Baking_bonuses) (Sink_container (Contract contract)) bonus + Token.transfer + ctxt + (Source_infinite Baking_bonuses) + (Sink_container (Contract contract)) + bonus in pay_payload_producer ctxt payload_producer >>=? fun (ctxt, balance_updates_payload_producer) -> diff --git a/src/proto_alpha/lib_protocol/dependent_bool.ml b/src/proto_alpha/lib_protocol/dependent_bool.ml index bea051c708fb2..e82e863c8822d 100644 --- a/src/proto_alpha/lib_protocol/dependent_bool.ml +++ b/src/proto_alpha/lib_protocol/dependent_bool.ml @@ -58,7 +58,7 @@ let merge_dand : type a b c1 c2. (a, b, c1) dand -> (a, b, c2) dand -> (c1, c2) eq = fun w1 w2 -> match[@coq_match_with_default] (w1, w2) with - | (NoNo, NoNo) -> Eq - | (NoYes, NoYes) -> Eq - | (YesNo, YesNo) -> Eq - | (YesYes, YesYes) -> Eq + | NoNo, NoNo -> Eq + | NoYes, NoYes -> Eq + | YesNo, YesNo -> Eq + | YesYes, YesYes -> Eq diff --git a/src/proto_alpha/lib_protocol/indexable.ml b/src/proto_alpha/lib_protocol/indexable.ml index f2286f98877e5..670450c0d98d9 100644 --- a/src/proto_alpha/lib_protocol/indexable.ml +++ b/src/proto_alpha/lib_protocol/indexable.ml @@ -150,12 +150,12 @@ let compare : let compare_values c : 'a value -> 'a value -> int = fun x y -> - match[@coq_match_with_default] (x, y) with (Value x, Value y) -> c x y + match[@coq_match_with_default] (x, y) with Value x, Value y -> c x y let compare_indexes : 'a index -> 'a index -> int = fun x y -> match[@coq_match_with_default] (x, y) with - | (Index x, Index y) -> Compare.Int32.compare x y + | Index x, Index y -> Compare.Int32.compare x y module type VALUE = sig type t diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml index f1ee3601e7d45..6b6e8823195b0 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.ml +++ b/src/proto_alpha/lib_protocol/merkle_list.ml @@ -167,7 +167,7 @@ struct Post-condition: len(to_bin pos depth) = depth *) let to_bin ~pos ~depth = let[@coq_struct "depth"] rec aux acc pos depth = - let (pos', dir) = (pos / 2, pos mod 2) in + let pos', dir = (pos / 2, pos mod 2) in match depth with | 0 -> acc | d -> aux (Compare.Int.(dir = 1) :: acc) pos' (d - 1) @@ -282,7 +282,8 @@ struct match (tree, key) with | Leaf _, [] -> ok acc | Node (_, l, r), b :: key -> - if b then aux (root_aux l :: acc) r key else aux (root_aux r :: acc) l key + if b then aux (root_aux l :: acc) r key + else aux (root_aux r :: acc) l key | _ -> error Merkle_list_invalid_position in aux List.nil tree key diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 44ec4ee11110a..903f77bfb2409 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -400,7 +400,6 @@ type _ manager_operation = } -> Kind.sc_rollup_recover_bond manager_operation - (** An [operation] contains the operation header information in [shell] and all data related to the operation itself in [protocol_data]. *) type 'kind operation = { diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 4170587b47588..46ce48cd1383e 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -370,7 +370,8 @@ module Make (Context : P) : val name : string val encoding : t Data_encoding.t - end) = struct + end) = + struct (* A stateful deque. diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index f33ac98e6d669..1ec5c2e6cca11 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -286,7 +286,8 @@ and klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type = (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] -and[@coq_mutual_as_notation] klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type = +and[@coq_mutual_as_notation] klist_enter : + type a b c d e j. (a, b, c, d, e, j) klist_enter_type = fun mk g gas body xs ys len ks' accu stack -> match xs with | [] -> @@ -308,8 +309,9 @@ and[@coq_mutual_as_notation] kloop_in_left : and[@coq_mutual_as_notation] kloop_in : type a b c r f s. (a, b, c, r, f, s) kloop_in_type = fun g gas ks0 ki ks' accu stack -> - let (accu', stack') = stack in - if [@coq_type_annotation] accu then (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' + let accu', stack' = stack in + if [@coq_type_annotation] accu then + (step [@ocaml.tailcall]) g gas ki ks0 accu' stack' else (next [@ocaml.tailcall]) g gas ks' accu' stack' [@@inline] @@ -331,7 +333,7 @@ and[@coq_struct "gas"] next : s -> (r * f * outdated_context * local_gas_counter) tzresult Lwt.t = fun g gas ks0 accu stack -> - let (ctxt, _) = g in + let ctxt, _ = g in match consume_control gas ks0 with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( @@ -374,7 +376,8 @@ and[@coq_struct "gas"] next : instructions. *) -and[@coq_mutual_as_notation] ilist_map : type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = +and[@coq_mutual_as_notation] ilist_map : + type a b c d e f g h. (a, b, c, d, e, f, g, h) ilist_map_type = fun log_if_needed g gas body k ks accu stack -> let xs = accu.elements in let ys = (([] [@coq_type_annotation]) : f list) in @@ -386,7 +389,8 @@ and[@coq_mutual_as_notation] ilist_map : type a b c d e f g h. (a, b, c, d, e, f ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_mutual_as_notation] ilist_iter : type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type = +and[@coq_mutual_as_notation] ilist_iter : + type a b c d e f g. (a, b, c, d, e, f, g) ilist_iter_type = fun log_if_needed g gas body k ks accu stack -> let xs = accu.elements in let ks = log_if_needed (KIter (body, xs, KCons (k, ks))) in @@ -394,7 +398,8 @@ and[@coq_mutual_as_notation] ilist_iter : type a b c d e f g. (a, b, c, d, e, f, ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_mutual_as_notation] iset_iter : type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = +and[@coq_mutual_as_notation] iset_iter : + type a b c d e f g. (a, b, c, d, e, f, g) iset_iter_type = fun log_if_needed g gas body k ks accu stack -> let set = accu in let l = List.rev (Script_set.fold (fun e acc -> e :: acc) set []) in @@ -403,8 +408,8 @@ and[@coq_mutual_as_notation] iset_iter : type a b c d e f g. (a, b, c, d, e, f, ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_mutual_as_notation] imap_map : type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type - = +and[@coq_mutual_as_notation] imap_map : + type a b c d e f g h i. (a, b, c, d, e, f, g, h, i) imap_map_type = fun log_if_needed g gas body k ks accu stack -> let map = accu in let xs = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in @@ -414,7 +419,8 @@ and[@coq_mutual_as_notation] imap_map : type a b c d e f g h i. (a, b, c, d, e, ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_mutual_as_notation] imap_iter : type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = +and[@coq_mutual_as_notation] imap_iter : + type a b c d e f g h. (a, b, c, d, e, f, g, h) imap_iter_type = fun log_if_needed g gas body k ks accu stack -> let map = accu in let l = List.rev (Script_map.fold (fun k v a -> (k, v) :: a) map []) in @@ -423,7 +429,8 @@ and[@coq_mutual_as_notation] imap_iter : type a b c d e f g h. (a, b, c, d, e, f ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_mutual_as_notation] imul_teznat : type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = +and[@coq_mutual_as_notation] imul_teznat : + type a b c d e f. (a, b, c, d, e, f) imul_teznat_type = fun logger g gas kinfo k ks accu stack -> let x = accu in let y, stack = stack in @@ -441,14 +448,16 @@ and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and[@coq_mutual_as_notation] ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = +and[@coq_mutual_as_notation] ilsl_nat : + type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = fun logger g gas kinfo k ks accu stack -> let x = accu and y, stack = stack in match[@coq_type_annotation] Script_int.shift_left_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack -and[@coq_mutual_as_notation] ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = +and[@coq_mutual_as_notation] ilsr_nat : + type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = fun logger g gas kinfo k ks accu stack -> let x = accu and y, stack = stack in match[@coq_type_annotation] Script_int.shift_right_n x y with @@ -476,7 +485,7 @@ and[@coq_mutual_as_notation] iexec : and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = fun g gas i ks accu stack -> - let (ctxt, sc) = g in + let ctxt, sc = g in match consume_instr gas i accu stack with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( @@ -1573,7 +1582,6 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] log : | _ -> (step [@ocaml.tailcall]) g gas k (with_log ks) accu stack [@@inline] - and[@coq_axiom_with_reason "we ignore the logging operations"] klog : type a s r f. logger -> @@ -1635,7 +1643,6 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] klog : (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] - (* Entrypoints @@ -1745,8 +1752,12 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal >>?= fun (r, ctxt) -> let self_contract = Contract.Originated step_constants.self in record_trace (Bad_contract_parameter self_contract) (r [@coq_type_annotation]) - >>?= fun [@coq_match_gadt] (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _}) - -> + >>?= fun [@coq_match_gadt] (Ex_ty_cstr + { + ty = entrypoint_ty; + construct; + original_type_expr = _; + }) -> trace (Bad_contract_parameter self_contract) (lift_execution_arg ctxt ~internal entrypoint_ty construct arg) diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index c6ae5fbb1ea9b..e94a5de023c68 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -469,11 +469,11 @@ let[@coq_struct "w_value"] rec kundip : a * s * (e, z, b, t) kinstr = fun w accu stack k -> match[@coq_match_gadt] (w, accu, stack) with - | (KPrefix (kinfo, w), _, (stack : _ * _)) -> + | KPrefix (kinfo, w), _, (stack : _ * _) -> let k = IConst (kinfo, accu, k) in let accu, stack = stack in kundip w accu stack k - | (KRest, (accu : a), (stack : s)) -> (accu, stack, k) + | KRest, (accu : a), (stack : s) -> (accu, stack, k) (* [apply ctxt gas ty v lam] specializes [lam] by fixing its first formal argument to [v]. The type of [v] is represented by [ty]. *) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index ad92c60ddb173..98fdd36176f7b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5938,8 +5938,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode Script_map.make (module M : Boxed_map with type key = M.key - and type value = M.value - ), + and type value = M.value), ids_to_copy, acc ) | _, Option_t (_, _, _), None -> return (ctxt, None, ids_to_copy, acc) @@ -6172,4 +6171,3 @@ let script_size let typecheck_code ~legacy ~show_types ctxt code = typecheck_code ~legacy ~show_types ctxt code >|=? fun (Typechecked_code_internal {type_map; _}, ctxt) -> (type_map, ctxt) - \ No newline at end of file diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 9c6780c014bcd..ba42422368368 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -129,6 +129,7 @@ type 'storage typed_view = } -> 'storage typed_view [@@coq_force_gadt] + type 'storage typed_view_map = (Script_string.t, 'storage typed_view) Script_typed_ir.map diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 898d70e20e426..75b85a322d47f 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -215,75 +215,73 @@ let[@coq_struct "ty"] rec value_size_aux : let apply : type a ac. nodes_and_size -> (a, ac) ty -> a -> nodes_and_size = fun accu ty x -> match[@coq_match_gadt] [@coq_match_with_default] (ty, x) with - | (Unit_t, _) -> ret_succ accu - | (Int_t, (x : _ Script_int.num)) -> - ret_succ_adding accu (script_int_size x) - | (Nat_t, (x : _ Script_int.num)) -> - ret_succ_adding accu (script_nat_size x) - | (Signature_t, _) -> ret_succ_adding accu signature_size - | (String_t, (x : Script_string.t)) -> + | Unit_t, _ -> ret_succ accu + | Int_t, (x : _ Script_int.num) -> ret_succ_adding accu (script_int_size x) + | Nat_t, (x : _ Script_int.num) -> ret_succ_adding accu (script_nat_size x) + | Signature_t, _ -> ret_succ_adding accu signature_size + | String_t, (x : Script_string.t) -> ret_succ_adding accu (script_string_size x) - | (Bytes_t, (x : bytes)) -> ret_succ_adding accu (bytes_size x) - | (Mutez_t, _) -> ret_succ_adding accu mutez_size - | (Key_hash_t, (x : public_key_hash)) -> + | Bytes_t, (x : bytes) -> ret_succ_adding accu (bytes_size x) + | Mutez_t, _ -> ret_succ_adding accu mutez_size + | Key_hash_t, (x : public_key_hash) -> ret_succ_adding accu (key_hash_size x) - | (Key_t, (x : public_key)) -> ret_succ_adding accu (public_key_size x) - | (Timestamp_t, (x : Script_timestamp.t)) -> + | Key_t, (x : public_key) -> ret_succ_adding accu (public_key_size x) + | Timestamp_t, (x : Script_timestamp.t) -> ret_succ_adding accu (timestamp_size x) - | (Address_t, (x : address)) -> ret_succ_adding accu (address_size x) - | (Tx_rollup_l2_address_t, (x : tx_rollup_l2_address)) -> + | Address_t, (x : address) -> ret_succ_adding accu (address_size x) + | Tx_rollup_l2_address_t, (x : tx_rollup_l2_address) -> ret_succ_adding accu (tx_rollup_l2_address_size x) - | (Bool_t, _) -> ret_succ accu - | (Pair_t (_, _, _, _), _) -> ret_succ_adding accu h2w - | (Union_t (_, _, _, _), _) -> ret_succ_adding accu h1w - | (Lambda_t (_, _, _), (x : _ lambda)) -> + | Bool_t, _ -> ret_succ accu + | Pair_t (_, _, _, _), _ -> ret_succ_adding accu h2w + | Union_t (_, _, _, _), _ -> ret_succ_adding accu h1w + | Lambda_t (_, _, _), (x : _ lambda) -> (lambda_size_aux [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) x - | (Option_t (_, _, _), (x : _ option)) -> + | Option_t (_, _, _), (x : _ option) -> ret_succ_adding accu (option_size (fun _ -> !!0) x) - | (List_t (_, _), (x : _ boxed_list)) -> + | List_t (_, _), (x : _ boxed_list) -> ret_succ_adding accu (h2w +! (h2w *? x.length)) - | (Set_t (_, _), (x : _ set)) -> + | Set_t (_, _), (x : _ set) -> let set = Script_set.get x in let module M = (val set) in let boxing_space = !!536 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h4w *? M.size)) - | (Map_t (_, _, _), (x : _ map)) -> + | Map_t (_, _, _), (x : _ map) -> let map = Script_map.get_module x in let module M = (val map) in let boxing_space = !!696 (* By Obj.reachable_words. *) in ret_succ_adding accu (boxing_space +! (h5w *? M.size)) - | (Big_map_t (cty, ty', _), (x : _ big_map)) -> + | Big_map_t (cty, ty', _), (x : _ big_map) -> (big_map_size_aux [@ocaml.tailcall]) ~count_lambda_nodes (ret_succ accu) cty ty' x - | (Contract_t (_, _), (x : _ typed_contract)) -> + | Contract_t (_, _), (x : _ typed_contract) -> ret_succ (accu ++ contract_size x) - | (Sapling_transaction_t _, (x : Sapling.transaction)) -> + | Sapling_transaction_t _, (x : Sapling.transaction) -> ret_succ_adding accu (Sapling.transaction_in_memory_size x) - | (Sapling_transaction_deprecated_t _, (x : Sapling_repr.legacy_transaction)) + | Sapling_transaction_deprecated_t _, (x : Sapling_repr.legacy_transaction) -> ret_succ_adding accu (Sapling.Legacy.transaction_in_memory_size x) - | (Sapling_state_t _, (x : Sapling.state)) -> + | Sapling_state_t _, (x : Sapling.state) -> ret_succ_adding accu (sapling_state_size x) (* Operations are neither storable nor pushable, so they can appear neither in the storage nor in the script. Hence they cannot appear in the cache and we never need to measure their size. *) - | (Operation_t, _) -> assert false - | (Chain_id_t, _) -> ret_succ_adding accu chain_id_size - | (Never_t, _) -> . - | (Bls12_381_g1_t, _) -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory - | (Bls12_381_g2_t, _) -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory - | (Bls12_381_fr_t, _) -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory - | (Ticket_t (_, _), (x : _ ticket)) -> ret_succ_adding accu (ticket_size x) - | (Chest_key_t, (x : Script_timelock.chest_key)) -> + | Operation_t, _ -> assert false + | Chain_id_t, _ -> ret_succ_adding accu chain_id_size + | Never_t, _ -> . + | Bls12_381_g1_t, _ -> ret_succ_adding accu !!Bls12_381.G1.size_in_memory + | Bls12_381_g2_t, _ -> ret_succ_adding accu !!Bls12_381.G2.size_in_memory + | Bls12_381_fr_t, _ -> ret_succ_adding accu !!Bls12_381.Fr.size_in_memory + | Ticket_t (_, _), (x : _ ticket) -> ret_succ_adding accu (ticket_size x) + | Chest_key_t, (x : Script_timelock.chest_key) -> ret_succ_adding accu (chest_key_size x) - | (Chest_t, (x : Script_timelock.chest)) -> + | Chest_t, (x : Script_timelock.chest) -> ret_succ_adding accu (chest_size x) in value_traverse ty x accu {apply} @@ -314,7 +312,11 @@ and[@coq_mutual_as_notation] big_map_size_aux : | None -> accu | Some value -> let accu = ret_succ_adding accu h1w in - (value_size_aux [@ocaml.tailcall]) ~count_lambda_nodes accu ty' value) + (value_size_aux [@ocaml.tailcall]) + ~count_lambda_nodes + accu + ty' + value) diff.map accu in diff --git a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml index e731c5edcdfef..b2570761b32ec 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_frozen_bonds.ml @@ -76,7 +76,9 @@ let init_test ~user_is_delegate = create_context () >>=? fun (ctxt, _) -> let delegate, delegate_pk, _ = Signature.generate_key () in let delegate_contract = Contract.Implicit delegate in - let delegate_account = Token.Sink_container (Contract (Contract.Implicit delegate)) in + let delegate_account = + Token.Sink_container (Contract (Contract.Implicit delegate)) + in let user_contract = if user_is_delegate then delegate_contract else @@ -369,7 +371,11 @@ let test_scenario scenario = let delegate_contract2 = Contract.Implicit delegate2 in let delegate_account2 = Token.Contract delegate_contract2 in let delegate_balance2 = big_random_amount () in - Token.transfer ctxt (Source_infinite Minted) (Sink_container delegate_account2) delegate_balance2 + Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container delegate_account2) + delegate_balance2 >>>=? fun (ctxt, _) -> (* Configure delegate, as a delegate by self-delegation, for which revealing its manager key is a prerequisite. *) @@ -403,7 +409,11 @@ let test_scenario scenario = Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1 -> Delegate.staking_balance ctxt delegate2 >>>=? fun staking_balance2 -> (* Freeze a tx-rollup deposit. *) - Token.transfer ctxt (Source_container user_account) (Sink_container deposit_account) deposit_amount + Token.transfer + ctxt + (Source_container user_account) + (Sink_container deposit_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after freeze. *) Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1' -> @@ -419,7 +429,11 @@ let test_scenario scenario = Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1 -> Delegate.staking_balance ctxt delegate2 >>>=? fun staking_balance2 -> (* Unfreeze the deposit *) - Token.transfer ctxt (Source_container deposit_account) (Sink_container user_account) deposit_amount + Token.transfer + ctxt + (Source_container deposit_account) + (Sink_container user_account) + deposit_amount >>>=? fun (ctxt, _) -> (* Fetch staking balance after unfreeze. *) Delegate.staking_balance ctxt delegate1 >>>=? fun staking_balance1' -> @@ -504,8 +518,6 @@ let test_scenario scenario = ~do_unfreeze ~do_slash - - let test_delegate_freeze_unfreeze_undelegate () = test_scenario (fun diff --git a/src/proto_alpha/lib_protocol/test/integration/test_token.ml b/src/proto_alpha/lib_protocol/test/integration/test_token.ml index cb0ed4917efb9..d09043561e104 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_token.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_token.ml @@ -171,7 +171,13 @@ let force_allocation_if_need_be ctxt account = match account with | Token.Delegate_balance pkh -> let account = Token.Contract (Contract.Implicit pkh) in - wrap (Token.transfer ctxt (Source_infinite Minted) (Sink_container account) Tez.one_mutez) >|=? fst + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container account) + Tez.one_mutez) + >|=? fst | _ -> return ctxt let test_transferring_to_sink ctxt sink amount expected_bupds = @@ -308,7 +314,12 @@ let test_transferring_to_burned ctxt = ]) true >>=? fun () -> - wrap (Token.transfer ctxt (Source_infinite Minted) (Sink_infinite Sc_rollup_refutation_punishments) amount) + wrap + (Token.transfer + ctxt + (Source_infinite Minted) + (Sink_infinite Sc_rollup_refutation_punishments) + amount) >>=? fun (_, bupds) -> Assert.equal_bool ~loc:__LOC__ @@ -592,13 +603,33 @@ let build_test_cases () = let baker2, baker2_pk, _ = Signature.generate_key () in let baker2c = Token.Contract (Contract.Implicit baker2) in (* Allocate contracts for user1, user2, baker1, and baker2. *) - wrap (Token.transfer ctxt (Source_container origin) (Sink_container user1c) (random_amount ())) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user1c) + (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt (Source_container origin) (Sink_container user2c) (random_amount ())) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user2c) + (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt (Source_container origin) (Sink_container baker1c) (random_amount ())) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container baker1c) + (random_amount ())) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt (Source_container origin) (Sink_container baker2c) (random_amount ())) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container baker2c) + (random_amount ())) >>=? fun (ctxt, _) -> (* Configure baker1, and baker2 as delegates by self-delegation, for which revealing their manager key is a prerequisite. *) @@ -676,18 +707,17 @@ let rec check_balances ctxt ctxt' src dest amount = (Source_container contract) (Sink_container contract) amount - | (Source_container src, Sink_container dest) when src = dest -> + | Source_container src, Sink_container dest when src = dest -> (* src and dest are the same contract *) wrap (Token.balance ctxt dest) >>=? fun (_, bal_dest) -> wrap (Token.balance ctxt' dest) >>=? fun (_, bal_dest') -> Assert.equal_tez ~loc:__LOC__ bal_dest bal_dest' - | (Source_container src, Sink_container dest) -> + | Source_container src, Sink_container dest -> check_src_balances ctxt ctxt' src amount >>=? fun _ -> check_sink_balances ctxt ctxt' dest amount - | (Source_container src, _) -> check_src_balances ctxt ctxt' src amount - | (_, Sink_container dest) -> check_sink_balances ctxt ctxt' dest amount - | (_, _) -> return_unit - + | Source_container src, _ -> check_src_balances ctxt ctxt' src amount + | _, Sink_container dest -> check_sink_balances ctxt ctxt' dest amount + | _, _ -> return_unit let test_all_combinations_of_sources_and_sinks () = Random.init 0 ; @@ -698,10 +728,10 @@ let test_all_combinations_of_sources_and_sinks () = | Token.Source_container src -> wrap (Token.transfer - ctxt - (Source_infinite Minted) - (Sink_container src) - amount) + ctxt + (Source_infinite Minted) + (Sink_container src) + amount) >>=? fun (ctxt, _) -> return ctxt | _ -> return ctxt) >>=? fun ctxt -> @@ -820,13 +850,33 @@ let test_transfer_n_with_non_empty_source () = let amount = match Tez.of_mutez 1000L with None -> assert false | Some x -> x in - wrap (Token.transfer ctxt (Source_container origin) (Sink_container user1c) amount) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user1c) + amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt (Source_container origin) (Sink_container user2c) amount) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user2c) + amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt (Source_container origin) (Sink_container user3c) amount) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user3c) + amount) >>=? fun (ctxt, _) -> - wrap (Token.transfer ctxt (Source_container origin) (Sink_container user4c) (random_amount ())) + wrap + (Token.transfer + ctxt + (Source_container origin) + (Sink_container user4c) + (random_amount ())) >>=? fun (ctxt, _) -> let sources = [ diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml index d124c8a81a684..c23564065caa3 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml @@ -71,7 +71,11 @@ let new_context () = let contract = Contract_repr.Implicit pkh in let+ ctxt, _ = lift - @@ Token.transfer ctxt (Source_infinite Minted) (Sink_container (Contract contract)) initial_staker_balance + @@ Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container (Contract contract)) + initial_staker_balance in ctxt in @@ -267,7 +271,11 @@ let test_deposit_by_underfunded_staker () = let staker_contract = Contract_repr.Implicit staker in let* ctxt, _ = lift - @@ Token.transfer ctxt (Source_infinite Minted) (Sink_container (Contract staker_contract)) staker_balance + @@ Token.transfer + ctxt + (Source_infinite Minted) + (Sink_container (Contract staker_contract)) + staker_balance in assert_fails_with ~loc:__LOC__ diff --git a/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml b/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml index 5832a20262b31..3c7a6be8e9cbf 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_parameters.ml @@ -39,6 +39,6 @@ let get_deposit_parameters : | ( Pair_t (Ticket_t (ty, _), Tx_rollup_l2_address_t, _, _), (contents : _ Script_typed_ir.ticket * Script_typed_ir.tx_rollup_l2_address) ) -> - let (ticket, l2_destination) = contents in + let ticket, l2_destination = contents in ok {ex_ticket = Ticket_scanner.Ex_ticket (ty, ticket); l2_destination} | _ -> error Alpha_context.Tx_rollup_errors.Wrong_deposit_parameters -- GitLab From 43bcd2558d73ad6bf792d8f1ec2b6cfa81ca4f5c Mon Sep 17 00:00:00 2001 From: emarzion Date: Fri, 24 Jun 2022 14:36:40 -0500 Subject: [PATCH 084/105] more fixes --- src/proto_alpha/lib_protocol/blinded_public_key_hash.ml | 2 +- src/proto_alpha/lib_protocol/cycle_repr.ml | 4 +++- src/proto_alpha/lib_protocol/period_repr.ml | 4 +++- src/proto_alpha/lib_protocol/raw_level_repr.ml | 4 +++- src/proto_alpha/lib_protocol/round_repr.ml | 4 +++- src/proto_alpha/lib_protocol/sc_rollup_arith.ml | 4 ++-- src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml | 5 +++-- src/proto_alpha/lib_protocol/script_typed_ir.ml | 1 + 8 files changed, 19 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml b/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml index 7b0a3272cc6ee..aec981c1dba38 100644 --- a/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml +++ b/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml @@ -34,7 +34,7 @@ module H = let b58check_prefix = "\001\002\049\223" let size = Some Ed25519.Public_key_hash.size - end) + end : Blake2B.PrefixedName) module Index : Storage_description.INDEX with type t = H.t = struct include H diff --git a/src/proto_alpha/lib_protocol/cycle_repr.ml b/src/proto_alpha/lib_protocol/cycle_repr.ml index b1a4b8bc6e0b9..1b85509b49875 100644 --- a/src/proto_alpha/lib_protocol/cycle_repr.ml +++ b/src/proto_alpha/lib_protocol/cycle_repr.ml @@ -34,7 +34,9 @@ let rpc_arg = RPC_arg.like RPC_arg.uint31 ~descr:"A cycle integer" "block_cycle" let pp ppf cycle = Format.fprintf ppf "%ld" cycle -include (Compare.Int32 : Compare.S with type t := t) +module M : Compare.S with type t := t = Compare.Int32 + +include M module Map = Map.Make (Compare.Int32) diff --git a/src/proto_alpha/lib_protocol/period_repr.ml b/src/proto_alpha/lib_protocol/period_repr.ml index 1f2de5752be8f..23a0aa1da5086 100644 --- a/src/proto_alpha/lib_protocol/period_repr.ml +++ b/src/proto_alpha/lib_protocol/period_repr.ml @@ -101,7 +101,9 @@ module Internal : INTERNAL = struct let pp ppf v = Format.fprintf ppf "%Ld" v - include (Compare.Int64 : Compare.S with type t := t) + module M : Compare.S with type t := t = Compare.Int64 + + include M let zero = 0L diff --git a/src/proto_alpha/lib_protocol/raw_level_repr.ml b/src/proto_alpha/lib_protocol/raw_level_repr.ml index 82aa2ef9b5d76..78b27029aec22 100644 --- a/src/proto_alpha/lib_protocol/raw_level_repr.ml +++ b/src/proto_alpha/lib_protocol/raw_level_repr.ml @@ -27,7 +27,9 @@ type t = int32 type raw_level = t -include (Compare.Int32 : Compare.S with type t := t) +module M : Compare.S with type t := t = Compare.Int32 + +include M let pp ppf level = Format.fprintf ppf "%ld" level diff --git a/src/proto_alpha/lib_protocol/round_repr.ml b/src/proto_alpha/lib_protocol/round_repr.ml index 44f881b5f079e..086e8e8acc468 100644 --- a/src/proto_alpha/lib_protocol/round_repr.ml +++ b/src/proto_alpha/lib_protocol/round_repr.ml @@ -29,7 +29,9 @@ type t = round module Map = Map.Make (Int32) -include (Compare.Int32 : Compare.S with type t := t) +module M : Compare.S with type t := t = Compare.Int32 + +include M let zero = 0l diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 46ce48cd1383e..c5281016d0b71 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -351,8 +351,8 @@ module Make (Context : P) : let mapped_to k v state = let open Lwt_syntax in let* state', _ = Monad.(run (set k v) state) in - let* t = Tree.find_tree state (key k) - and* t' = Tree.find_tree state' (key k) in + let* t = Tree.find_tree state (key k) in + let* t' = Tree.find_tree state' (key k) in Lwt.return (Option.equal Tree.equal t t') let pp = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml index 7077617212618..845ef0491f289 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml @@ -496,5 +496,6 @@ let play game refutation = in match result with | Ok x -> Lwt.return x - | Error (Game_error e) -> Lwt.return @@ game_over e - | Error _ -> Lwt.return @@ game_over "undefined" + | Error e -> match e with + | Game_error e -> Lwt.return @@ game_over e + | _ -> Lwt.return @@ game_over "undefined" diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 164d6950b262e..c24ee47f39fdb 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -2249,6 +2249,7 @@ let ty_traverse = (continue [@ocaml.tailcall]) accu) in fun ty init f -> aux f init ty (fun accu -> accu) + [@@coq_axiom_with_reason "local mutually recursive definition not handled"] type 'accu stack_ty_traverse = { apply : 'ty 's. 'accu -> ('ty, 's) stack_ty -> 'accu; -- GitLab From 36e1c2131e9652748001f4d817f93230a512f6a2 Mon Sep 17 00:00:00 2001 From: emarzion Date: Wed, 29 Jun 2022 00:38:44 -0500 Subject: [PATCH 085/105] fixes --- src/lib_protocol_environment/environment_V6.ml | 4 ++++ src/lib_protocol_environment/sigs/v6/bounded.mli | 2 +- src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli | 9 ++++++--- src/proto_alpha/lib_protocol/bond_id_repr.ml | 2 +- src/proto_alpha/lib_protocol/dal_slot_repr.ml | 8 ++++---- src/proto_alpha/lib_protocol/script_string.ml | 2 +- 6 files changed, 17 insertions(+), 10 deletions(-) diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index 687c637789cfa..b7471b88d2dd1 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -1101,6 +1101,10 @@ struct end module Wasm_2_0_0 = struct + module type S = sig + type tree + val step : tree -> tree Lwt.t + end module Make (Tree : Context.TREE with type key = string list and type value = bytes) = struct diff --git a/src/lib_protocol_environment/sigs/v6/bounded.mli b/src/lib_protocol_environment/sigs/v6/bounded.mli index 46539808d0884..f2a037d48a7b1 100644 --- a/src/lib_protocol_environment/sigs/v6/bounded.mli +++ b/src/lib_protocol_environment/sigs/v6/bounded.mli @@ -66,5 +66,5 @@ module Int32 : sig allow future compatiblity with larger bounds, at the price of addding 1-3 redundant bytes to each message. *) - module Make (_ : BOUNDS) : S + module Make (B : BOUNDS) : S end diff --git a/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli b/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli index ca448ec3bcd8a..137b97529c199 100644 --- a/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli +++ b/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli @@ -23,7 +23,10 @@ (* *) (*****************************************************************************) -module Make - (Tree : Context.TREE with type key = string list and type value = bytes) : sig - val step : Tree.tree -> Tree.tree Lwt.t +module type S = sig + type tree + val step : tree -> tree Lwt.t end + +module Make + (Tree : Context.TREE with type key = string list and type value = bytes) : S with type tree := Tree.tree diff --git a/src/proto_alpha/lib_protocol/bond_id_repr.ml b/src/proto_alpha/lib_protocol/bond_id_repr.ml index 665d0e64d5bfd..ad9ce24f1477a 100644 --- a/src/proto_alpha/lib_protocol/bond_id_repr.ml +++ b/src/proto_alpha/lib_protocol/bond_id_repr.ml @@ -74,7 +74,7 @@ let rpc_arg = let starts_with ~prefix s = let open String in let len_s = length s and len_pre = length prefix in - let rec aux i = + let[@coq_struct "i_value"] rec aux i = if Compare.Int.(i = len_pre) then true else if Compare.Char.(get s i <> get prefix i) then false else aux (i + 1) diff --git a/src/proto_alpha/lib_protocol/dal_slot_repr.ml b/src/proto_alpha/lib_protocol/dal_slot_repr.ml index 44539286a8a97..7af4fd9b7bf7a 100644 --- a/src/proto_alpha/lib_protocol/dal_slot_repr.ml +++ b/src/proto_alpha/lib_protocol/dal_slot_repr.ml @@ -85,26 +85,26 @@ module Slot_market = struct length (fun _ -> None) in - match l with Error msg -> invalid_arg msg | Ok l -> l + match l with Error msg -> invalid_arg msg | Ok l' -> l' let current_fees candidates index = match List.nth candidates index with | None | Some None -> None | Some (Some ((_ : slot), tez)) -> Some tez - let update candidates slot fees = + let update candidates slot' fees = let has_changed = ref false in let may_replace_candidate current_candidate = match current_candidate with | Some ((_slot : slot), current_fees) when Tez_repr.(current_fees >= fees) -> current_candidate - | _ -> Some (slot, fees) + | _ -> Some (slot', fees) in let candidates = List.mapi (fun i candidate -> - if Compare.Int.(i = slot.index) then may_replace_candidate candidate + if Compare.Int.(i = slot'.index) then may_replace_candidate candidate else candidate) candidates in diff --git a/src/proto_alpha/lib_protocol/script_string.ml b/src/proto_alpha/lib_protocol/script_string.ml index b3108eb31ef23..ea0c6bca872cc 100644 --- a/src/proto_alpha/lib_protocol/script_string.ml +++ b/src/proto_alpha/lib_protocol/script_string.ml @@ -57,7 +57,7 @@ let () = let empty = String_tag "" let of_string v = - let rec check_printable_ascii i = + let[@coq_struct "i_value"] rec check_printable_ascii i = if Compare.Int.(i < 0) then ok (String_tag v) else match v.[i] with -- GitLab From 3daa29acd9e5ae8e0dd6f92a70b497d4bc5f01d5 Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 30 Jun 2022 00:16:07 -0500 Subject: [PATCH 086/105] more fixes --- .../sigs/v6/bounded.mli | 1 + .../lib_protocol/carbonated_map.ml | 9 +++++++- .../lib_protocol/carbonated_map.mli | 14 +++++++----- src/proto_alpha/lib_protocol/merkle_list.ml | 14 +++++++----- .../lib_protocol/sc_rollup_arith.ml | 22 ++++++++++++++----- .../lib_protocol/sc_rollup_errors.ml | 2 +- .../lib_protocol/sc_rollup_inbox_repr.ml | 10 ++++----- .../lib_protocol/sc_rollup_wasm.ml | 10 ++++----- 8 files changed, 52 insertions(+), 30 deletions(-) diff --git a/src/lib_protocol_environment/sigs/v6/bounded.mli b/src/lib_protocol_environment/sigs/v6/bounded.mli index f2a037d48a7b1..86f030f40f923 100644 --- a/src/lib_protocol_environment/sigs/v6/bounded.mli +++ b/src/lib_protocol_environment/sigs/v6/bounded.mli @@ -68,3 +68,4 @@ module Int32 : sig *) module Make (B : BOUNDS) : S end +[@@coq_plain_module] \ No newline at end of file diff --git a/src/proto_alpha/lib_protocol/carbonated_map.ml b/src/proto_alpha/lib_protocol/carbonated_map.ml index dcd812c9836c9..e54582fa49074 100644 --- a/src/proto_alpha/lib_protocol/carbonated_map.ml +++ b/src/proto_alpha/lib_protocol/carbonated_map.ml @@ -91,7 +91,14 @@ module type COMPARABLE = sig val compare_cost : t -> Saturation_repr.may_saturate Saturation_repr.t end -module Make_builder (C : COMPARABLE) = struct +module type S_builder = sig + type 'a t + type key + module Make (G : GAS) : + S with type key = key and type context = G.context and type 'a t := 'a t +end + +module Make_builder (C : COMPARABLE) : S_builder with type key := C.t = struct module M = Map.Make (C) type 'a t = {map : 'a M.t; size : int} diff --git a/src/proto_alpha/lib_protocol/carbonated_map.mli b/src/proto_alpha/lib_protocol/carbonated_map.mli index 60de5b15667c7..9fd2d92be6b61 100644 --- a/src/proto_alpha/lib_protocol/carbonated_map.mli +++ b/src/proto_alpha/lib_protocol/carbonated_map.mli @@ -136,18 +136,20 @@ module type COMPARABLE = sig val compare_cost : t -> Saturation_repr.may_saturate Saturation_repr.t end +module type S_builder = sig + type 'a t + type key + module Make (G : GAS) : + S with type key = key and type context = G.context and type 'a t := 'a t +end + (** A functor for exposing the type of a carbonated map before the carbonated make is created. This is useful in scenarios where the map that will need to be carbonated is defined before the gas consuming functions for the carbonation are available. See for example [Raw_context]. *) -module Make_builder (C : COMPARABLE) : sig - type 'a t - - module Make (G : GAS) : - S with type key = C.t and type context = G.context and type 'a t := 'a t -end +module Make_builder (C : COMPARABLE) : S_builder with type key := C.t (** A functor for building gas metered maps. When building a gas metered map via [Make(G)(C)], [C] is a [COMPARABLE] required to construct a the map while diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml index 6b6e8823195b0..e70a323e66f05 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.ml +++ b/src/proto_alpha/lib_protocol/merkle_list.ml @@ -211,11 +211,12 @@ struct let tree', depth' = match (t.tree, t.depth, t.next_pos) with | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1) - | tree, depth, pos when Int32.(equal (shift_left 1l depth) (of_int pos)) - -> + | tree, depth, pos -> + if Int32.(equal (shift_left 1l depth) (of_int pos)) + then let t_right = make_spine_with el depth in (node_of tree t_right, depth + 1) - | tree, depth, pos -> + else let key = to_bin ~pos ~depth in (traverse tree depth key, depth) in @@ -250,11 +251,12 @@ struct let tree', depth' = match (t.tree, t.depth, t.next_pos) with | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1) - | tree, depth, pos when Int32.(equal (shift_left 1l depth) (of_int pos)) - -> + | tree, depth, pos -> + if Int32.(equal (shift_left 1l depth) (of_int pos)) + then let t_right = make_spine_with el depth in (node_of tree t_right, depth + 1) - | tree, depth, pos -> + else let key = to_bin ~pos ~depth in (traverse Top tree depth key, depth) in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index c5281016d0b71..73fa7598f7f63 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -332,7 +332,7 @@ module Make (Context : P) : return @@ fun fmt () -> Format.fprintf fmt "@[%s : %a@]" P.name P.pp v end - module MakeDict (P : sig + module type MakeDictSig = sig type t val name : string @@ -340,7 +340,9 @@ module Make (Context : P) : val pp : Format.formatter -> t -> unit val encoding : t Data_encoding.t - end) = + end + + module MakeDict (P : MakeDictSig) = struct let key k = [P.name; k] @@ -364,13 +366,15 @@ module Make (Context : P) : return @@ fun fmt () -> Format.pp_print_list pp_elem fmt l end - module MakeDeque (P : sig + module type MakeDequeSig = sig type t val name : string val encoding : t Data_encoding.t - end) = + end + + module MakeDeque (P : MakeDequeSig) = struct (* @@ -454,9 +458,15 @@ module Make (Context : P) : end module CurrentTick = MakeVar (struct - include Sc_rollup_tick_repr - + type t = Sc_rollup_tick_repr.t + let name = "tick" + + let initial = Sc_rollup_tick_repr.initial + + let pp = Sc_rollup_tick_repr.pp + + let encoding = Sc_rollup_tick_repr.encoding end) module Vars = MakeDict (struct diff --git a/src/proto_alpha/lib_protocol/sc_rollup_errors.ml b/src/proto_alpha/lib_protocol/sc_rollup_errors.ml index b716a3a793d0e..5d17a2d627c70 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_errors.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_errors.ml @@ -63,7 +63,7 @@ type error += min_expected_balance : Tez_repr.t; } -let () = +let[@coq_axiom_with_reason "Polymorphic variant."] () = register_error_kind `Temporary ~id:"Sc_rollup_max_number_of_available_messages_reached" diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml index c05bfbb7463ec..f2afd4f7269b9 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -633,7 +633,7 @@ module MakeHashingScheme (P : TREE) : let current_messages_hash () = hash_messages messages in return (messages, history, {inbox with current_messages_hash}) - let add_external_messages history inbox level payloads messages = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] add_external_messages history inbox level payloads messages = let open Lwt_tzresult_syntax in let*? payloads = List.map_e @@ -646,7 +646,7 @@ module MakeHashingScheme (P : TREE) : in return (messages, history, inbox) - let add_messages_no_history inbox level payloads messages = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] add_messages_no_history inbox level payloads messages = let open Lwt_tzresult_syntax in let* messages, No_history, inbox = add_messages_aux No_history inbox level payloads messages @@ -679,7 +679,7 @@ module MakeHashingScheme (P : TREE) : in aux [] ptr_path - let produce_inclusion_proof history inbox1 inbox2 = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] produce_inclusion_proof history inbox1 inbox2 = let cell_ptr = hash_old_levels_messages inbox2.old_levels_messages in let target_index = Skip_list.index inbox1.old_levels_messages in let (With_history history) = @@ -810,7 +810,7 @@ module Proof = struct let* r = get_message_payload tree n in return (tree, r) - let check_hash hash kinded_hash = + let[@coq_axiom_with_reason "Type error."] check_hash hash kinded_hash = match kinded_hash with | `Node h -> Hash.(equal (of_context_hash h) hash) | `Value h -> Hash.(equal (of_context_hash h) hash) @@ -826,7 +826,7 @@ module Proof = struct let*! result = promise in match result with Ok r -> return r | Error _ -> proof_error reason - let rec valid {inbox_level = l; message_counter = n} inbox proof = + let[@coq_axiom_with_reason "Type error."] rec valid {inbox_level = l; message_counter = n} inbox proof = assert (Z.(geq n zero)) ; let open Lwt_result_syntax in match split_proof proof with diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index 8243b7403fc73..2306d235dbac7 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml @@ -103,15 +103,15 @@ module V2_0_0 = struct type nonrec proof = Context.proof proof - let proof_input_given p = p.given + let proof_input_given (p : proof) = p.given - let proof_input_requested p = p.requested + let proof_input_requested (p : proof) = p.requested - let proof_encoding = proof_encoding Context.proof_encoding + let proof_encoding : proof Data_encoding.t = proof_encoding Context.proof_encoding - let proof_start_state p = Context.proof_before p.tree_proof + let proof_start_state (p : proof) = Context.proof_before p.tree_proof - let proof_stop_state p = + let proof_stop_state (p : proof) = match (p.given, p.requested) with | None, PS.No_input_required -> Some (Context.proof_after p.tree_proof) | None, _ -> None -- GitLab From 9a8683a0fe67a01bfd35b3946288a606be27f635 Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 5 Jul 2022 19:48:21 -0500 Subject: [PATCH 087/105] more work --- .../lib_protocol/alpha_context.mli | 6 +- .../lib_protocol/operation_repr.ml | 4 ++ .../lib_protocol/operation_repr.mli | 12 ++-- .../lib_protocol/sc_rollup_arith.ml | 38 +++++++++-- .../lib_protocol/sc_rollup_game_repr.ml | 4 +- .../lib_protocol/sc_rollup_proof_repr.ml | 16 ++--- .../lib_protocol/sc_rollup_wasm.ml | 36 ++++++++--- src/proto_alpha/lib_protocol/sc_rollups.ml | 30 ++++----- src/proto_alpha/lib_protocol/sc_rollups.mli | 2 +- src/proto_alpha/lib_protocol/storage.ml | 64 ++++++++++++++++--- .../test/pbt/test_refutation_game.ml | 4 +- 11 files changed, 159 insertions(+), 57 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 4ae678ddcc161..1e22a8b7f9333 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2923,7 +2923,7 @@ module Sc_rollup : sig module type PVM_with_proof = sig include PVM.S - val proof : proof + val proof_val : proof end type wrapped_proof = @@ -3621,10 +3621,14 @@ module Operation : sig type nonrec packed_protocol_data = packed_protocol_data + module Consensus_watermark : sig type consensus_watermark = | Endorsement of Chain_id.t | Preendorsement of Chain_id.t | Dal_slot_availability of Chain_id.t + end + + open Consensus_watermark val to_watermark : consensus_watermark -> Signature.watermark diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 62cf4e627d57a..739c15e4987fa 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -193,10 +193,14 @@ let pp_consensus_content ppf content = Block_payload_hash.pp_short content.block_payload_hash +module Consensus_watermark = struct type consensus_watermark = | Endorsement of Chain_id.t | Preendorsement of Chain_id.t | Dal_slot_availability of Chain_id.t +end + +open Consensus_watermark let bytes_of_consensus_watermark = function | Preendorsement chain_id -> diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index 903f77bfb2409..ae513e344b954 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -194,10 +194,14 @@ val consensus_content_encoding : consensus_content Data_encoding.t val pp_consensus_content : Format.formatter -> consensus_content -> unit -type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t - | Dal_slot_availability of Chain_id.t +module Consensus_watermark : sig + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_slot_availability of Chain_id.t + end + +open Consensus_watermark val to_watermark : consensus_watermark -> Signature.watermark diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index 73fa7598f7f63..e7e0db529a235 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -332,7 +332,7 @@ module Make (Context : P) : return @@ fun fmt () -> Format.fprintf fmt "@[%s : %a@]" P.name P.pp v end - module type MakeDictSig = sig + module type P_MakeDict = sig type t val name : string @@ -342,7 +342,19 @@ module Make (Context : P) : val encoding : t Data_encoding.t end - module MakeDict (P : MakeDictSig) = + module type MakeDict_sig = sig + type t + + val get : string -> t option Monad.t + + val set : string -> t -> unit Monad.t + + val mapped_to : string -> t -> state -> bool Lwt.t + + val pp : (Format.formatter -> unit -> unit) Monad.t + end + + module MakeDict (P : P_MakeDict) : MakeDict_sig with type t := P.t = struct let key k = [P.name; k] @@ -366,7 +378,7 @@ module Make (Context : P) : return @@ fun fmt () -> Format.pp_print_list pp_elem fmt l end - module type MakeDequeSig = sig + module type P_MakeDeque = sig type t val name : string @@ -374,7 +386,23 @@ module Make (Context : P) : val encoding : t Data_encoding.t end - module MakeDeque (P : MakeDequeSig) = + module type MakeDeque_sig = sig + type t + + val top : t option Monad.t + + val push : t -> unit Monad.t + + val pop : t option Monad.t + + val inject : t -> unit Monad.t + + val to_list : t list Monad.t + + val clear : unit Monad.t + end + + module MakeDeque (P : P_MakeDeque) : MakeDeque_sig with type t := P.t = struct (* @@ -444,7 +472,7 @@ module Make (Context : P) : let open Monad.Syntax in let* head_idx = get_head in let* end_idx = get_end in - let rec aux l idx = + let[@coq_struct "idx"] rec aux l idx = if Z.(lt idx head_idx) then return l else let* v = find_value (idx_key idx) P.encoding in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml index 845ef0491f289..249c394f72a9d 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml @@ -333,7 +333,7 @@ let game_error reason = let find_choice game tick = let open Lwt_result_syntax in - let rec traverse states = + let[@coq_struct "states"] rec traverse states = match states with | (state, state_tick) :: (next_state, next_tick) :: others -> if Sc_rollup_tick_repr.(tick = state_tick) then @@ -404,7 +404,7 @@ let check_dissection start start_tick stop stop_tick dissection = stop_tick)) | _ -> game_error "Dissection should contain at least 2 elements" in - let rec traverse states = + let[@coq_struct "states"] rec traverse states = match states with | (None, _) :: (Some _, _) :: _ -> game_error "Cannot return to a Some state after being at a None state" diff --git a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml index 84333262f7aec..66ef9ce9d7e42 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml @@ -42,11 +42,11 @@ let pp ppf _ = Format.fprintf ppf "Refutation game proof" let start proof = let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in - P.proof_start_state P.proof + P.proof_start_state P.proof_val let stop proof = let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in - P.proof_stop_state P.proof + P.proof_stop_state P.proof_val (* This takes an [input] and checks if it is at or above the given level. It returns [None] if this is the case. @@ -69,12 +69,12 @@ let check p reason = let open Lwt_result_syntax in if p then return () else proof_error reason -let valid snapshot commit_level ~pvm_name proof = +let[@coq_axiom_with_reason "Type errors."] valid snapshot commit_level ~pvm_name proof = let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in let open Lwt_result_syntax in let* _ = check (String.equal P.name pvm_name) "Incorrect PVM kind" in - let input_requested = P.proof_input_requested P.proof in - let input_given = P.proof_input_given P.proof in + let input_requested = P.proof_input_requested P.proof_val in + let input_given = P.proof_input_given P.proof_val in let* input = match (input_requested, proof.inbox) with | Sc_rollup_PVM_sem.No_input_required, None -> return None @@ -105,7 +105,7 @@ let valid snapshot commit_level ~pvm_name proof = input_given) "Input given is not what inbox proof expects" in - Lwt.map Result.ok (P.verify_proof P.proof) + Lwt.map Result.ok (P.verify_proof P.proof_val) module type PVM_with_context_and_state = sig include Sc_rollups.PVM.S @@ -117,7 +117,7 @@ end type error += Proof_cannot_be_wrapped -let produce pvm_and_state inbox commit_level = +let[@coq_axiom_with_reason "Type errors."] produce pvm_and_state inbox commit_level = let open Lwt_result_syntax in let (module P : PVM_with_context_and_state) = pvm_and_state in let*! request = P.is_input_state P.state in @@ -140,7 +140,7 @@ let produce pvm_and_state inbox commit_level = let module P_with_proof = struct include P - let proof = pvm_step_proof + let proof_val = pvm_step_proof end in match Sc_rollups.wrap_proof (module P_with_proof) with | Some pvm_step -> return {pvm_step; inbox} diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index 2306d235dbac7..3ecf6c267b8fa 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml @@ -207,7 +207,7 @@ module V2_0_0 = struct open Monad - module MakeVar (P : sig + module type P_MakeVar = sig type t val name : string @@ -215,7 +215,18 @@ module V2_0_0 = struct val initial : t val encoding : t Data_encoding.t - end) = + end + + module type MakeVar_sig = sig + type t + (*val key : string list*) + + val get : t Monad.t + + val set : t -> unit Monad.t + end + + module MakeVar (P : P_MakeVar) : MakeVar_sig with type t := P.t = struct let key = [P.name] @@ -228,9 +239,14 @@ module V2_0_0 = struct end module CurrentTick = MakeVar (struct - include Sc_rollup_tick_repr - + type t = Sc_rollup_tick_repr.t let name = "tick" + + let initial = Sc_rollup_tick_repr.initial + + let encoding = Sc_rollup_tick_repr.encoding + + let _pp = Sc_rollup_tick_repr.pp end) module Boot_sector = MakeVar (struct @@ -411,7 +427,7 @@ module V2_0_0 = struct in return (state, request) - let verify_proof proof = + let verify_proof (proof : proof) = let open Lwt_syntax in let* result = Context.verify_proof proof.tree_proof (step_transition proof.given) @@ -423,7 +439,7 @@ module V2_0_0 = struct type error += WASM_proof_production_failed - let produce_proof context input_given state = + let produce_proof context input_given state : (proof, error) result Lwt.t = let open Lwt_result_syntax in let*! result = Context.produce_proof context state (step_transition input_given) @@ -489,15 +505,15 @@ module V2_0_0 = struct (* Can't produce proof without full context*) Lwt.return None - let kinded_hash_to_state_hash = function + let[@coq_axiom_with_reason "Type error."] kinded_hash_to_state_hash = function | `Value hash | `Node hash -> State_hash.hash_bytes [Context_hash.to_bytes hash] - let proof_before proof = + let[@coq_axiom_with_reason "Type error."] proof_before proof = kinded_hash_to_state_hash proof.Context.Proof.before - let proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after + let[@coq_axiom_with_reason "Type error."] proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after - let proof_encoding = Context.Proof_encoding.V1.Tree32.tree_proof_encoding + let[@coq_axiom_with_reason "Type error."] proof_encoding = Context.Proof_encoding.V1.Tree32.tree_proof_encoding end) end diff --git a/src/proto_alpha/lib_protocol/sc_rollups.ml b/src/proto_alpha/lib_protocol/sc_rollups.ml index f8dc13c41824c..d142b61ac28f7 100644 --- a/src/proto_alpha/lib_protocol/sc_rollups.ml +++ b/src/proto_alpha/lib_protocol/sc_rollups.ml @@ -84,11 +84,11 @@ module Kind = struct | "wasm_2_0_0" -> Some Wasm_2_0_0 | _ -> None - let example_arith_pvm = - (module Sc_rollup_arith.ProtocolImplementation : PVM.S) + let example_arith_pvm : (module PVM.S) = + (module (Sc_rollup_arith.ProtocolImplementation : PVM.S)) - let wasm_2_0_0_pvm = - (module Sc_rollup_wasm.V2_0_0.ProtocolImplementation : PVM.S) + let wasm_2_0_0_pvm : (module PVM.S) = + (module (Sc_rollup_wasm.V2_0_0.ProtocolImplementation : PVM.S)) let pvm_of = function | Example_arith -> example_arith_pvm @@ -122,7 +122,7 @@ end module type PVM_with_proof = sig include PVM.S - val proof : proof + val proof_val : proof end type wrapped_proof = @@ -148,7 +148,7 @@ let wrapped_proof_module p = include P end : PVM_with_proof) -let wrapped_proof_encoding = +let[@coq_axiom_with_reason "Module Issues."] wrapped_proof_encoding = let open Data_encoding in let encoding = union @@ -165,13 +165,13 @@ let wrapped_proof_encoding = Sc_rollup_arith.ProtocolImplementation.proof) = pvm in - Some P.proof + Some P.proof_val | _ -> None) (fun proof -> let module P = struct include Sc_rollup_arith.ProtocolImplementation - let proof = proof + let proof_val = proof end in Arith_pvm_with_proof (module P)); case @@ -185,20 +185,20 @@ let wrapped_proof_encoding = Sc_rollup_wasm.V2_0_0.ProtocolImplementation.proof) = pvm in - Some P.proof + Some P.proof_val | _ -> None) (fun proof -> let module P = struct include Sc_rollup_wasm.V2_0_0.ProtocolImplementation - let proof = proof + let proof_val = proof end in Wasm_2_0_0_pvm_with_proof (module P)); ] in check_size Constants_repr.sc_max_wrapped_proof_binary_size encoding -let wrap_proof pvm_with_proof = +let[@coq_axiom_with_reason "Module Issues."] wrap_proof pvm_with_proof = let (module P : PVM_with_proof) = pvm_with_proof in match Kind.of_name P.name with | None -> Some (Unencodable pvm_with_proof) @@ -208,11 +208,11 @@ let wrap_proof pvm_with_proof = let module P_arith = struct include Sc_rollup_arith.ProtocolImplementation - let proof = arith_proof + let proof_val = arith_proof end in Arith_pvm_with_proof (module P_arith)) (Option.bind - (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof) + (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof_val) (fun bytes -> Data_encoding.Binary.of_bytes_opt Sc_rollup_arith.ProtocolImplementation.proof_encoding @@ -223,11 +223,11 @@ let wrap_proof pvm_with_proof = let module P_wasm2_0_0 = struct include Sc_rollup_wasm.V2_0_0.ProtocolImplementation - let proof = wasm_proof + let proof_val = wasm_proof end in Wasm_2_0_0_pvm_with_proof (module P_wasm2_0_0)) (Option.bind - (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof) + (Data_encoding.Binary.to_bytes_opt P.proof_encoding P.proof_val) (fun bytes -> Data_encoding.Binary.of_bytes_opt Sc_rollup_wasm.V2_0_0.ProtocolImplementation.proof_encoding diff --git a/src/proto_alpha/lib_protocol/sc_rollups.mli b/src/proto_alpha/lib_protocol/sc_rollups.mli index 81ec833da0ab9..3684ff07ab392 100644 --- a/src/proto_alpha/lib_protocol/sc_rollups.mli +++ b/src/proto_alpha/lib_protocol/sc_rollups.mli @@ -87,7 +87,7 @@ end module type PVM_with_proof = sig include PVM.S - val proof : proof + val proof_val : proof end (** A wrapper for first-class modules [(module PVM_with_proof)]. We need diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 219ad6927861d..7c29eccc60a19 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1495,15 +1495,49 @@ module Sc_rollup = struct end)) (Make_index (Sc_rollup_repr.Index)) - module Make_versioned (Versioned_value : sig + module type Make_versioned_sig = sig val name : string module Index : Storage_description.INDEX include Sc_rollup_data_version_sig.S - end) = + end + + (* + module type Make_versioned_out = sig + type t + + type context + + type key + + val mem : context -> key -> (Indexed_context.t * bool) tzresult Lwt.t + + val remove_existing : context -> key -> (Indexed_context.t * int) tzresult Lwt.t + + val remove : context -> key -> (Indexed_context.t * int * bool) tzresult Lwt.t + + type value + + val get : context -> key -> (Indexed_context.t * value, error trace) result Lwt.t + + val find : context -> + key -> (Indexed_context.t * value option, error trace) result Lwt.t + + val update : context -> key -> value -> (Indexed_context.t * int) tzresult Lwt.t + + val init : context -> key -> value -> (Indexed_context.t * int) tzresult Lwt.t + + val add : context -> key -> value -> (Indexed_context.t * int * bool) tzresult Lwt.t + + val add_or_remove : context -> + key -> value option -> (Indexed_context.t * int * bool) tzresult Lwt.t + end + *) + + module Make_versioned (Versioned_value : Make_versioned_sig) (*: Make_versioned_out*) = struct - include + module M = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1516,27 +1550,39 @@ module Sc_rollup = struct let encoding = Versioned_value.versioned_encoding end) + type t = M.t + + type context = M.context + + type key = M.key + + let mem = M.mem + + let remove_existing = M.remove_existing + + let remove = M.remove + type value = Versioned_value.t let get ctxt key = let open Lwt_result_syntax in - let* ctxt, versioned = get ctxt key in + let* ctxt, versioned = M.get ctxt key in return (ctxt, Versioned_value.of_versioned versioned) let find ctxt key = let open Lwt_result_syntax in - let* ctxt, versioned = find ctxt key in + let* ctxt, versioned = M.find ctxt key in return (ctxt, Option.map Versioned_value.of_versioned versioned) let update ctxt key value = - update ctxt key (Versioned_value.to_versioned value) + M.update ctxt key (Versioned_value.to_versioned value) - let init ctxt key value = init ctxt key (Versioned_value.to_versioned value) + let init ctxt key value = M.init ctxt key (Versioned_value.to_versioned value) - let add ctxt key value = add ctxt key (Versioned_value.to_versioned value) + let add ctxt key value = M.add ctxt key (Versioned_value.to_versioned value) let add_or_remove ctxt key value = - add_or_remove ctxt key (Option.map Versioned_value.to_versioned value) + M.add_or_remove ctxt key (Option.map Versioned_value.to_versioned value) end module PVM_kind = diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml index 91d787b235d81..658911e1927a7 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml @@ -655,7 +655,7 @@ module Strategies (PVM : TestPVM with type hash = State_hash.t) = struct let module P = struct include PVM - let proof = pvm_proof + let proof_val = pvm_proof end in Unencodable (module P) in @@ -732,7 +732,7 @@ module Strategies (PVM : TestPVM with type hash = State_hash.t) = struct let module P = struct include PVM - let proof = pvm_proof + let proof_val = pvm_proof end in Unencodable (module P) in -- GitLab From 83ffbb0da95b075fa2f38d1309369c686be3bf44 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 6 Jul 2022 10:58:42 +0200 Subject: [PATCH 088/105] Running Ocamlformat --- .../environment_V6.ml | 2 ++ .../sigs/v6/bounded.mli | 2 +- .../sigs/v6/wasm_2_0_0.mli | 4 ++- .../lib_protocol/alpha_context.mli | 8 +++--- .../lib_protocol/blinded_public_key_hash.ml | 14 +++++----- .../lib_protocol/carbonated_map.ml | 2 ++ .../lib_protocol/carbonated_map.mli | 2 ++ src/proto_alpha/lib_protocol/cycle_repr.ml | 1 - src/proto_alpha/lib_protocol/merkle_list.ml | 26 +++++++++---------- .../lib_protocol/operation_repr.ml | 8 +++--- .../lib_protocol/operation_repr.mli | 2 +- .../lib_protocol/sc_rollup_arith.ml | 9 +++---- .../lib_protocol/sc_rollup_game_repr.ml | 7 ++--- .../lib_protocol/sc_rollup_inbox_repr.ml | 12 ++++++--- .../lib_protocol/sc_rollup_proof_repr.ml | 6 +++-- .../lib_protocol/sc_rollup_wasm.ml | 18 ++++++++----- src/proto_alpha/lib_protocol/storage.ml | 6 +++-- 17 files changed, 74 insertions(+), 55 deletions(-) diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index b7471b88d2dd1..cb3af05c1d309 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -1103,8 +1103,10 @@ struct module Wasm_2_0_0 = struct module type S = sig type tree + val step : tree -> tree Lwt.t end + module Make (Tree : Context.TREE with type key = string list and type value = bytes) = struct diff --git a/src/lib_protocol_environment/sigs/v6/bounded.mli b/src/lib_protocol_environment/sigs/v6/bounded.mli index 86f030f40f923..835cf46553f6b 100644 --- a/src/lib_protocol_environment/sigs/v6/bounded.mli +++ b/src/lib_protocol_environment/sigs/v6/bounded.mli @@ -68,4 +68,4 @@ module Int32 : sig *) module Make (B : BOUNDS) : S end -[@@coq_plain_module] \ No newline at end of file +[@@coq_plain_module] diff --git a/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli b/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli index 137b97529c199..3a0c43c35cf84 100644 --- a/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli +++ b/src/lib_protocol_environment/sigs/v6/wasm_2_0_0.mli @@ -25,8 +25,10 @@ module type S = sig type tree + val step : tree -> tree Lwt.t end module Make - (Tree : Context.TREE with type key = string list and type value = bytes) : S with type tree := Tree.tree + (Tree : Context.TREE with type key = string list and type value = bytes) : + S with type tree := Tree.tree diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 1e22a8b7f9333..ff4e62bf9c574 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -3622,10 +3622,10 @@ module Operation : sig type nonrec packed_protocol_data = packed_protocol_data module Consensus_watermark : sig - type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t - | Dal_slot_availability of Chain_id.t + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_slot_availability of Chain_id.t end open Consensus_watermark diff --git a/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml b/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml index aec981c1dba38..38a8f65138c2d 100644 --- a/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml +++ b/src/proto_alpha/lib_protocol/blinded_public_key_hash.ml @@ -26,15 +26,17 @@ module H = Blake2B.Make (Base58) - (struct - let name = "Blinded public key hash" + (( + struct + let name = "Blinded public key hash" - let title = "A blinded public key hash" + let title = "A blinded public key hash" - let b58check_prefix = "\001\002\049\223" + let b58check_prefix = "\001\002\049\223" - let size = Some Ed25519.Public_key_hash.size - end : Blake2B.PrefixedName) + let size = Some Ed25519.Public_key_hash.size + end : + Blake2B.PrefixedName)) module Index : Storage_description.INDEX with type t = H.t = struct include H diff --git a/src/proto_alpha/lib_protocol/carbonated_map.ml b/src/proto_alpha/lib_protocol/carbonated_map.ml index e54582fa49074..28e8a3da72ba9 100644 --- a/src/proto_alpha/lib_protocol/carbonated_map.ml +++ b/src/proto_alpha/lib_protocol/carbonated_map.ml @@ -93,7 +93,9 @@ end module type S_builder = sig type 'a t + type key + module Make (G : GAS) : S with type key = key and type context = G.context and type 'a t := 'a t end diff --git a/src/proto_alpha/lib_protocol/carbonated_map.mli b/src/proto_alpha/lib_protocol/carbonated_map.mli index 9fd2d92be6b61..e175569b172f8 100644 --- a/src/proto_alpha/lib_protocol/carbonated_map.mli +++ b/src/proto_alpha/lib_protocol/carbonated_map.mli @@ -138,7 +138,9 @@ end module type S_builder = sig type 'a t + type key + module Make (G : GAS) : S with type key = key and type context = G.context and type 'a t := 'a t end diff --git a/src/proto_alpha/lib_protocol/cycle_repr.ml b/src/proto_alpha/lib_protocol/cycle_repr.ml index 1b85509b49875..21dc8929c3553 100644 --- a/src/proto_alpha/lib_protocol/cycle_repr.ml +++ b/src/proto_alpha/lib_protocol/cycle_repr.ml @@ -37,7 +37,6 @@ let pp ppf cycle = Format.fprintf ppf "%ld" cycle module M : Compare.S with type t := t = Compare.Int32 include M - module Map = Map.Make (Compare.Int32) let root = 0l diff --git a/src/proto_alpha/lib_protocol/merkle_list.ml b/src/proto_alpha/lib_protocol/merkle_list.ml index e70a323e66f05..93e671434f84e 100644 --- a/src/proto_alpha/lib_protocol/merkle_list.ml +++ b/src/proto_alpha/lib_protocol/merkle_list.ml @@ -212,13 +212,12 @@ struct match (t.tree, t.depth, t.next_pos) with | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1) | tree, depth, pos -> - if Int32.(equal (shift_left 1l depth) (of_int pos)) - then - let t_right = make_spine_with el depth in - (node_of tree t_right, depth + 1) - else - let key = to_bin ~pos ~depth in - (traverse tree depth key, depth) + if Int32.(equal (shift_left 1l depth) (of_int pos)) then + let t_right = make_spine_with el depth in + (node_of tree t_right, depth + 1) + else + let key = to_bin ~pos ~depth in + (traverse tree depth key, depth) in {tree = tree'; depth = depth'; next_pos = t.next_pos + 1} @@ -252,13 +251,12 @@ struct match (t.tree, t.depth, t.next_pos) with | Empty, 0, 0 -> (node_of (leaf_of el) Empty, 1) | tree, depth, pos -> - if Int32.(equal (shift_left 1l depth) (of_int pos)) - then - let t_right = make_spine_with el depth in - (node_of tree t_right, depth + 1) - else - let key = to_bin ~pos ~depth in - (traverse Top tree depth key, depth) + if Int32.(equal (shift_left 1l depth) (of_int pos)) then + let t_right = make_spine_with el depth in + (node_of tree t_right, depth + 1) + else + let key = to_bin ~pos ~depth in + (traverse Top tree depth key, depth) in {tree = tree'; depth = depth'; next_pos = t.next_pos + 1} diff --git a/src/proto_alpha/lib_protocol/operation_repr.ml b/src/proto_alpha/lib_protocol/operation_repr.ml index 739c15e4987fa..2e610b9201d39 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.ml +++ b/src/proto_alpha/lib_protocol/operation_repr.ml @@ -194,10 +194,10 @@ let pp_consensus_content ppf content = content.block_payload_hash module Consensus_watermark = struct -type consensus_watermark = - | Endorsement of Chain_id.t - | Preendorsement of Chain_id.t - | Dal_slot_availability of Chain_id.t + type consensus_watermark = + | Endorsement of Chain_id.t + | Preendorsement of Chain_id.t + | Dal_slot_availability of Chain_id.t end open Consensus_watermark diff --git a/src/proto_alpha/lib_protocol/operation_repr.mli b/src/proto_alpha/lib_protocol/operation_repr.mli index ae513e344b954..dea534d881f7c 100644 --- a/src/proto_alpha/lib_protocol/operation_repr.mli +++ b/src/proto_alpha/lib_protocol/operation_repr.mli @@ -199,7 +199,7 @@ module Consensus_watermark : sig | Endorsement of Chain_id.t | Preendorsement of Chain_id.t | Dal_slot_availability of Chain_id.t - end +end open Consensus_watermark diff --git a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml index e7e0db529a235..26d03fbd0ba27 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_arith.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_arith.ml @@ -354,8 +354,7 @@ module Make (Context : P) : val pp : (Format.formatter -> unit -> unit) Monad.t end - module MakeDict (P : P_MakeDict) : MakeDict_sig with type t := P.t = - struct + module MakeDict (P : P_MakeDict) : MakeDict_sig with type t := P.t = struct let key k = [P.name; k] let get k = find_value (key k) P.encoding @@ -398,11 +397,11 @@ module Make (Context : P) : val inject : t -> unit Monad.t val to_list : t list Monad.t - + val clear : unit Monad.t end - module MakeDeque (P : P_MakeDeque) : MakeDeque_sig with type t := P.t = + module MakeDeque (P : P_MakeDeque) : MakeDeque_sig with type t := P.t = struct (* @@ -487,7 +486,7 @@ module Make (Context : P) : module CurrentTick = MakeVar (struct type t = Sc_rollup_tick_repr.t - + let name = "tick" let initial = Sc_rollup_tick_repr.initial diff --git a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml index 249c394f72a9d..3ea3369d89f43 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml @@ -496,6 +496,7 @@ let play game refutation = in match result with | Ok x -> Lwt.return x - | Error e -> match e with - | Game_error e -> Lwt.return @@ game_over e - | _ -> Lwt.return @@ game_over "undefined" + | Error e -> ( + match e with + | Game_error e -> Lwt.return @@ game_over e + | _ -> Lwt.return @@ game_over "undefined") diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml index f2afd4f7269b9..5908d7a3e9a0c 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -633,7 +633,8 @@ module MakeHashingScheme (P : TREE) : let current_messages_hash () = hash_messages messages in return (messages, history, {inbox with current_messages_hash}) - let[@coq_axiom_with_reason "Non-exhaustive pattern match."] add_external_messages history inbox level payloads messages = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] add_external_messages + history inbox level payloads messages = let open Lwt_tzresult_syntax in let*? payloads = List.map_e @@ -646,7 +647,8 @@ module MakeHashingScheme (P : TREE) : in return (messages, history, inbox) - let[@coq_axiom_with_reason "Non-exhaustive pattern match."] add_messages_no_history inbox level payloads messages = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] add_messages_no_history + inbox level payloads messages = let open Lwt_tzresult_syntax in let* messages, No_history, inbox = add_messages_aux No_history inbox level payloads messages @@ -679,7 +681,8 @@ module MakeHashingScheme (P : TREE) : in aux [] ptr_path - let[@coq_axiom_with_reason "Non-exhaustive pattern match."] produce_inclusion_proof history inbox1 inbox2 = + let[@coq_axiom_with_reason "Non-exhaustive pattern match."] produce_inclusion_proof + history inbox1 inbox2 = let cell_ptr = hash_old_levels_messages inbox2.old_levels_messages in let target_index = Skip_list.index inbox1.old_levels_messages in let (With_history history) = @@ -826,7 +829,8 @@ module Proof = struct let*! result = promise in match result with Ok r -> return r | Error _ -> proof_error reason - let[@coq_axiom_with_reason "Type error."] rec valid {inbox_level = l; message_counter = n} inbox proof = + let[@coq_axiom_with_reason "Type error."] rec valid + {inbox_level = l; message_counter = n} inbox proof = assert (Z.(geq n zero)) ; let open Lwt_result_syntax in match split_proof proof with diff --git a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml index 66ef9ce9d7e42..e7e3050258557 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml @@ -69,7 +69,8 @@ let check p reason = let open Lwt_result_syntax in if p then return () else proof_error reason -let[@coq_axiom_with_reason "Type errors."] valid snapshot commit_level ~pvm_name proof = +let[@coq_axiom_with_reason "Type errors."] valid snapshot commit_level ~pvm_name + proof = let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in let open Lwt_result_syntax in let* _ = check (String.equal P.name pvm_name) "Incorrect PVM kind" in @@ -117,7 +118,8 @@ end type error += Proof_cannot_be_wrapped -let[@coq_axiom_with_reason "Type errors."] produce pvm_and_state inbox commit_level = +let[@coq_axiom_with_reason "Type errors."] produce pvm_and_state inbox + commit_level = let open Lwt_result_syntax in let (module P : PVM_with_context_and_state) = pvm_and_state in let*! request = P.is_input_state P.state in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml index 3ecf6c267b8fa..91eee6b23cec3 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_wasm.ml @@ -107,7 +107,8 @@ module V2_0_0 = struct let proof_input_requested (p : proof) = p.requested - let proof_encoding : proof Data_encoding.t = proof_encoding Context.proof_encoding + let proof_encoding : proof Data_encoding.t = + proof_encoding Context.proof_encoding let proof_start_state (p : proof) = Context.proof_before p.tree_proof @@ -226,8 +227,7 @@ module V2_0_0 = struct val set : t -> unit Monad.t end - module MakeVar (P : P_MakeVar) : MakeVar_sig with type t := P.t = - struct + module MakeVar (P : P_MakeVar) : MakeVar_sig with type t := P.t = struct let key = [P.name] let get = @@ -240,6 +240,7 @@ module V2_0_0 = struct module CurrentTick = MakeVar (struct type t = Sc_rollup_tick_repr.t + let name = "tick" let initial = Sc_rollup_tick_repr.initial @@ -439,7 +440,7 @@ module V2_0_0 = struct type error += WASM_proof_production_failed - let produce_proof context input_given state : (proof, error) result Lwt.t = + let produce_proof context input_given state : (proof, error) result Lwt.t = let open Lwt_result_syntax in let*! result = Context.produce_proof context state (step_transition input_given) @@ -505,15 +506,18 @@ module V2_0_0 = struct (* Can't produce proof without full context*) Lwt.return None - let[@coq_axiom_with_reason "Type error."] kinded_hash_to_state_hash = function + let[@coq_axiom_with_reason "Type error."] kinded_hash_to_state_hash = + function | `Value hash | `Node hash -> State_hash.hash_bytes [Context_hash.to_bytes hash] let[@coq_axiom_with_reason "Type error."] proof_before proof = kinded_hash_to_state_hash proof.Context.Proof.before - let[@coq_axiom_with_reason "Type error."] proof_after proof = kinded_hash_to_state_hash proof.Context.Proof.after + let[@coq_axiom_with_reason "Type error."] proof_after proof = + kinded_hash_to_state_hash proof.Context.Proof.after - let[@coq_axiom_with_reason "Type error."] proof_encoding = Context.Proof_encoding.V1.Tree32.tree_proof_encoding + let[@coq_axiom_with_reason "Type error."] proof_encoding = + Context.Proof_encoding.V1.Tree32.tree_proof_encoding end) end diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 7c29eccc60a19..adf43075e756d 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1535,7 +1535,8 @@ module Sc_rollup = struct end *) - module Make_versioned (Versioned_value : Make_versioned_sig) (*: Make_versioned_out*) = + module Make_versioned (Versioned_value : Make_versioned_sig) = + (*: Make_versioned_out*) struct module M = Make_indexed_carbonated_data_storage @@ -1577,7 +1578,8 @@ module Sc_rollup = struct let update ctxt key value = M.update ctxt key (Versioned_value.to_versioned value) - let init ctxt key value = M.init ctxt key (Versioned_value.to_versioned value) + let init ctxt key value = + M.init ctxt key (Versioned_value.to_versioned value) let add ctxt key value = M.add ctxt key (Versioned_value.to_versioned value) -- GitLab From df3238388c0b6deacaf47f15f1b97cee24b0b0e1 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 6 Jul 2022 11:05:13 +0200 Subject: [PATCH 089/105] Fix the compilation of storage.ml --- src/proto_alpha/lib_protocol/storage.ml | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index adf43075e756d..5ef338d47f65e 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1496,11 +1496,11 @@ module Sc_rollup = struct (Make_index (Sc_rollup_repr.Index)) module type Make_versioned_sig = sig - val name : string + include Sc_rollup_data_version_sig.S module Index : Storage_description.INDEX - include Sc_rollup_data_version_sig.S + val name : string end (* @@ -1535,9 +1535,11 @@ module Sc_rollup = struct end *) - module Make_versioned (Versioned_value : Make_versioned_sig) = - (*: Make_versioned_out*) - struct + module Make_versioned (Versioned_value : Make_versioned_sig) : + Non_iterable_indexed_carbonated_data_storage + with type key = Versioned_value.Index.t + and type value = Versioned_value.t + and type t = Raw_context.t * Sc_rollup_repr.t = struct module M = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) @@ -1682,8 +1684,13 @@ module Sc_rollup = struct end) module Commitments = Make_versioned (struct - include Sc_rollup_commitment_repr - module Index = Hash + include ( + Sc_rollup_commitment_repr : + Sc_rollup_data_version_sig.S with type t = Sc_rollup_commitment_repr.t) + + module Index : + Storage_description.INDEX with type t = Sc_rollup_commitment_repr.Hash.t = + Sc_rollup_commitment_repr.Hash let name = "commitments" end) -- GitLab From 894e19483ede97acbf6707e33068e5f5c6ab54e3 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Wed, 6 Jul 2022 18:02:48 +0200 Subject: [PATCH 090/105] One last commit --- src/lib_protocol_environment/sigs/v6/compare.mli | 1 + 1 file changed, 1 insertion(+) diff --git a/src/lib_protocol_environment/sigs/v6/compare.mli b/src/lib_protocol_environment/sigs/v6/compare.mli index 0437dd1e23de5..38f5f19e98bd3 100644 --- a/src/lib_protocol_environment/sigs/v6/compare.mli +++ b/src/lib_protocol_environment/sigs/v6/compare.mli @@ -120,6 +120,7 @@ module Int : sig external equal : int -> int -> bool = "%equal" end +[@@coq_plain_module] module Int32 : S with type t = int32 -- GitLab From 2f537ff532b9b17146f348b33664c5cb615c7296 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 7 Jul 2022 11:18:54 +0200 Subject: [PATCH 091/105] Fix compilation of storage files --- .../sc_rollup_refutation_storage.ml | 4 +-- .../lib_protocol/sc_rollup_stake_storage.ml | 4 +-- src/proto_alpha/lib_protocol/storage.ml | 36 +++++++++++++++---- 3 files changed, 34 insertions(+), 10 deletions(-) diff --git a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml index 66e00aa3cca1c..626131f03dea8 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml @@ -49,7 +49,7 @@ let timeout_level ctxt = arrives at the exact [inbox_level]. The result is the commit hash at the given inbox level. *) let goto_inbox_level ctxt rollup inbox_level commit = let open Lwt_tzresult_syntax in - let rec go ctxt commit = + let[@coq_struct "commit"] rec go ctxt commit = let* info, ctxt = Commitment_storage.get_commitment_unsafe ctxt rollup commit in @@ -104,7 +104,7 @@ let get_conflict_point ctxt rollup staker1 staker2 = (* The inbox level of a commitment increases by a fixed amount over the preceding commitment. We use this fact in the following to efficiently traverse both commitment histories towards the conflict points. *) - let rec traverse_in_parallel ctxt commit1 commit2 = + let[@coq_struct "commit1"] rec traverse_in_parallel ctxt commit1 commit2 = (* We know that commit1 <> commit2 at the first call and during recursive calls as well. *) let* commit1_info, ctxt = diff --git a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml index be64f754470bb..bbf1fc8ec6952 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml @@ -248,7 +248,7 @@ let refine_stake ctxt rollup staker commitment = let new_hash = Commitment.hash commitment in (* TODO: https://gitlab.com/tezos/tezos/-/issues/2559 Add a test checking that L2 nodes can catch up after going offline. *) - let rec go node ctxt = + let[@coq_struct "node_value"] rec go node ctxt = (* WARNING: Do NOT reorder this sequence of ifs. we must check for staked_on before LCC, since refining from the LCC to another commit is a valid operation. *) @@ -398,7 +398,7 @@ let remove_staker ctxt rollup staker = Store.Stakers.remove_existing (ctxt, rollup) staker in let* ctxt = modify_staker_count ctxt rollup Int32.pred in - let rec go node ctxt = + let[@coq_struct "node_value"] rec go node ctxt = if Commitment_hash.(node = lcc) then return ctxt else let* pred, ctxt = diff --git a/src/proto_alpha/lib_protocol/storage.ml b/src/proto_alpha/lib_protocol/storage.ml index 5ef338d47f65e..3e586ee145e89 100644 --- a/src/proto_alpha/lib_protocol/storage.ml +++ b/src/proto_alpha/lib_protocol/storage.ml @@ -1695,7 +1695,11 @@ module Sc_rollup = struct let name = "commitments" end) - module Commitment_stake_count = + module Commitment_stake_count : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_commitment_repr.Hash.t + and type value = int32 + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1708,7 +1712,11 @@ module Sc_rollup = struct let encoding = Data_encoding.int32 end) - module Commitment_added = + module Commitment_added : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_commitment_repr.Hash.t + and type value = Raw_level_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1721,7 +1729,11 @@ module Sc_rollup = struct let encoding = Raw_level_repr.encoding end) - module Game = + module Game : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_game_repr.Index.t + and type value = Sc_rollup_game_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1734,7 +1746,11 @@ module Sc_rollup = struct let encoding = Sc_rollup_game_repr.encoding end) - module Game_timeout = + module Game_timeout : + Non_iterable_indexed_carbonated_data_storage + with type key = Sc_rollup_game_repr.Index.t + and type value = Raw_level_repr.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1747,7 +1763,11 @@ module Sc_rollup = struct let encoding = Raw_level_repr.encoding end) - module Opponent = + module Opponent : + Non_iterable_indexed_carbonated_data_storage + with type key = Signature.Public_key_hash.t + and type value = Sc_rollup_repr.Staker.t + and type t = Raw_context.t * Sc_rollup_repr.t = Make_indexed_carbonated_data_storage (Make_subcontext (Registered) (Indexed_context.Raw_context) (struct @@ -1841,7 +1861,11 @@ module Dal = struct This is only for prototyping. Probably something smarter would be to index each header directly. *) - module Slot_headers = + module Slot_headers : + Non_iterable_indexed_data_storage + with type t = Raw_context.t + and type key = Raw_level_repr.t + and type value = Dal_slot_repr.slot list = Level_context.Make_map (struct let name = ["slots"] -- GitLab From 7b5e83c872e5be7b2f9d881a96ba0d46b5fa1348 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 7 Jul 2022 14:44:59 +0200 Subject: [PATCH 092/105] More changes --- src/proto_alpha/lib_protocol/alpha_context.ml | 2 +- src/proto_alpha/lib_protocol/alpha_context.mli | 2 +- src/proto_alpha/lib_protocol/sc_rollup_storage.ml | 5 ++--- src/proto_alpha/lib_protocol/sc_rollup_storage.mli | 2 +- .../lib_protocol/test/unit/test_sc_rollup_storage.ml | 2 +- 5 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 0da4d4a2e7e71..e1ae28d7d4b60 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -80,7 +80,7 @@ module Sc_rollup = struct include Sc_rollups module Outbox = struct - include Sc_rollup_storage.Outbox + include Sc_rollup_storage.Outbox_aux module Message = Sc_rollup_outbox_message_repr end diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index ff4e62bf9c574..3bab2abc9fcc6 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2753,7 +2753,7 @@ module Sc_rollup : sig module Number_of_ticks : Bounded.Int32.S module Commitment : sig - module Hash : S.HASH + module Hash : S.HASH [@@coq_plain_module] type t = { compressed_state : State_hash.t; diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index 06a0fea1999db..1bf6ddb426c79 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml @@ -26,8 +26,7 @@ open Sc_rollup_errors module Store = Storage.Sc_rollup -module Commitment = Sc_rollup_commitment_repr -module Commitment_hash = Commitment.Hash +module Commitment_hash = Sc_rollup_commitment_repr.Hash let originate ctxt ~kind ~boot_sector ~parameters_ty = Raw_context.increment_origination_nonce ctxt >>?= fun (ctxt, nonce) -> @@ -80,7 +79,7 @@ let parameters_type ctxt rollup = let+ ctxt, res = Store.Parameters_type.find ctxt rollup in (res, ctxt) -module Outbox = struct +module Outbox_aux = struct let level_index ctxt level = let max_active_levels = Constants_storage.sc_rollup_max_active_outbox_levels ctxt diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.mli b/src/proto_alpha/lib_protocol/sc_rollup_storage.mli index 2dca63488e63c..dd602c88abeb4 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.mli @@ -62,7 +62,7 @@ val parameters_type : (Script_repr.lazy_expr option * Raw_context.t) tzresult Lwt.t (** A module for managing state concerning a rollup's outbox. *) -module Outbox : sig +module Outbox_aux : sig (** [record_applied_message ctxt rollup level ~message_index] marks the message in the outbox of rollup [rollup] at level [level] and position [message_index] as processed. Returns the size diff resulting from diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml index c23564065caa3..2d0ba59a921a1 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml @@ -2416,7 +2416,7 @@ let test_limit_on_number_of_messages_during_commitment_period with_gap () = | _ -> false let record ctxt rollup level message_index = - Sc_rollup_storage.Outbox.record_applied_message + Sc_rollup_storage.Outbox_aux.record_applied_message ctxt rollup (Raw_level_repr.of_int32_exn @@ Int32.of_int level) -- GitLab From 19a47dd78e15066053156a611f392535b3016b71 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Thu, 7 Jul 2022 16:01:53 +0200 Subject: [PATCH 093/105] More changes to compile alpha-context --- .../lib_injector/injector_functor.ml | 2 +- .../lib_protocol/alpha_context.mli | 2 +- src/proto_alpha/lib_protocol/apply_results.ml | 113 +++++++++--------- .../lib_protocol/apply_results.mli | 2 - 4 files changed, 57 insertions(+), 62 deletions(-) diff --git a/src/proto_alpha/lib_injector/injector_functor.ml b/src/proto_alpha/lib_injector/injector_functor.ml index 3e844aa3e73d9..cab01309c5cc5 100644 --- a/src/proto_alpha/lib_injector/injector_functor.ml +++ b/src/proto_alpha/lib_injector/injector_functor.ml @@ -390,7 +390,7 @@ module Make (Rollup : PARAMETERS) = struct let* packed_op, result = simulate_operations ~must_succeed state operations in - let results = Apply_results.to_list result in + let results = Apply_results.packed_contents_result_list_to_list result in let failure = ref false in let* rev_non_failing_operations = List.fold_left2_s diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 3bab2abc9fcc6..d25cde6d52a7c 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2514,7 +2514,7 @@ module Sc_rollup : sig module Map : Map.S with type key = t end - module Address = Sc_rollup_repr.Address + module Address = Sc_rollup_repr.Address [@@coq_plain_module] type t = Sc_rollup_repr.t diff --git a/src/proto_alpha/lib_protocol/apply_results.ml b/src/proto_alpha/lib_protocol/apply_results.ml index 4c8c931facb5d..6b53268090634 100644 --- a/src/proto_alpha/lib_protocol/apply_results.ml +++ b/src/proto_alpha/lib_protocol/apply_results.ml @@ -380,7 +380,7 @@ module Manager_result = struct ~title:"Applied" (merge_objs (obj1 (req "status" (constant "applied"))) encoding) (fun o -> - match o with + match[@coq_match_gadt] o with | Skipped _ | Failed _ | Backtracked _ -> None | Applied o -> ( match select (Successful_manager_result o) with @@ -410,7 +410,7 @@ module Manager_result = struct (opt "errors" trace_encoding)) encoding) (fun o -> - match o with + match[@coq_match_gadt] o with | Skipped _ | Failed _ | Applied _ -> None | Backtracked (o, errs) -> ( match select (Successful_manager_result o) with @@ -836,7 +836,7 @@ module Manager_result = struct Transfer_ticket_result {balance_updates; consumed_gas; paid_storage_size_diff}) - let[@coq_axiom_with_reason "gadt"] dal_publish_slot_header_case = + let dal_publish_slot_header_case = make ~op_case: Operation.Encoding.Manager_operations.dal_publish_slot_header_case @@ -846,7 +846,7 @@ module Manager_result = struct | Successful_manager_result (Dal_publish_slot_header_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Dal_publish_slot_header_result {consumed_gas} -> consumed_gas) ~kind:Kind.Dal_publish_slot_header_manager_kind ~inj:(fun consumed_gas -> Dal_publish_slot_header_result {consumed_gas}) @@ -939,7 +939,7 @@ module Manager_result = struct ~select:(function | Successful_manager_result (Sc_rollup_refute_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_refute_result {consumed_gas; status; balance_updates} -> (consumed_gas, status, balance_updates)) ~kind:Kind.Sc_rollup_refute_manager_kind @@ -958,7 +958,7 @@ module Manager_result = struct | Successful_manager_result (Sc_rollup_timeout_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_timeout_result {consumed_gas; status; balance_updates} -> (consumed_gas, status, balance_updates)) ~kind:Kind.Sc_rollup_timeout_manager_kind @@ -982,7 +982,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Sc_rollup_execute_outbox_message_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_execute_outbox_message_result {balance_updates; consumed_gas; paid_storage_size_diff} -> (balance_updates, consumed_gas, paid_storage_size_diff)) @@ -990,7 +990,7 @@ module Manager_result = struct Sc_rollup_execute_outbox_message_result {balance_updates; consumed_gas; paid_storage_size_diff}) - let[@coq_axiom_with_reason "gadt"] sc_rollup_recover_bond_case = + let sc_rollup_recover_bond_case = make ~op_case:Operation.Encoding.Manager_operations.sc_rollup_recover_bond_case ~encoding: @@ -1003,7 +1003,7 @@ module Manager_result = struct Some op | _ -> None) ~kind:Kind.Sc_rollup_recover_bond_manager_kind - ~proj:(function + ~proj:(function[@coq_match_with_default] | Sc_rollup_recover_bond_result {balance_updates; consumed_gas} -> (balance_updates, consumed_gas)) ~inj:(fun (balance_updates, consumed_gas) -> @@ -1188,7 +1188,7 @@ module Internal_manager_result = struct ~title:"Applied" (merge_objs (obj1 (req "status" (constant "applied"))) encoding) (fun o -> - match o with + match[@coq_match_gadt] o with | Skipped _ | Failed _ | Backtracked _ -> None | Applied o -> ( match select (Successful_internal_manager_result o) with @@ -1218,7 +1218,7 @@ module Internal_manager_result = struct (opt "errors" trace_encoding)) encoding) (fun o -> - match o with + match[@coq_match_gadt] o with | Skipped _ | Failed _ | Applied _ -> None | Backtracked (o, errs) -> ( match select (Successful_internal_manager_result o) with @@ -1229,7 +1229,7 @@ module Internal_manager_result = struct in MCase {op_case; encoding; kind; select; proj; inj; t} - let[@coq_axiom_with_reason "gadt"] transaction_case = + let transaction_case = make ~op_case:Internal_result.transaction_case ~encoding:Manager_result.transaction_contract_variant_cases @@ -1238,10 +1238,10 @@ module Internal_manager_result = struct Some op | _ -> None) ~kind:Kind.Transaction_manager_kind - ~proj:(function ITransaction_result x -> x) + ~proj:(function[@coq_match_with_default] ITransaction_result x -> x) ~inj:(fun x -> ITransaction_result x) - let[@coq_axiom_with_reason "gadt"] origination_case = + let origination_case = make ~op_case:Internal_result.origination_case ~encoding: @@ -1256,7 +1256,7 @@ module Internal_manager_result = struct | Successful_internal_manager_result (IOrigination_result _ as op) -> Some op | _ -> None) - ~proj:(function + ~proj:(function[@coq_match_with_default] | IOrigination_result { lazy_storage_diff; @@ -1315,26 +1315,27 @@ let internal_manager_operation_result_encoding : packed_internal_manager_operation_result Data_encoding.t = let make (type kind) (Internal_manager_result.MCase res_case : - kind Internal_manager_result.case) - (Internal_result.MCase ires_case : kind Internal_result.case) = - let (Internal_result.MCase op_case) = res_case.op_case in - case - (Tag op_case.tag) - ~title:op_case.name - (merge_objs - (obj3 - (req "kind" (constant op_case.name)) - (req "source" Contract.encoding) - (req "nonce" uint16)) - (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) - (fun op -> - match ires_case.iselect op with - | Some (op, res) -> - Some (((), op.source, op.nonce), (ires_case.proj op.operation, res)) - | None -> None) - (fun (((), source, nonce), (op, res)) -> - let op = {source; operation = ires_case.inj op; nonce} in - Internal_manager_operation_result (op, res)) + kind Internal_manager_result.case) = function[@coq_match_gadt] + | (Internal_result.MCase ires_case : kind Internal_result.case) -> + let (Internal_result.MCase op_case) = res_case.op_case in + case + (Tag op_case.tag) + ~title:op_case.name + (merge_objs + (obj3 + (req "kind" (constant op_case.name)) + (req "source" Contract.encoding) + (req "nonce" uint16)) + (merge_objs ires_case.encoding (obj1 (req "result" res_case.t)))) + (fun op -> + match ires_case.iselect op with + | Some (op, res) -> + Some + (((), op.source, op.nonce), (ires_case.proj op.operation, res)) + | None -> None) + (fun (((), source, nonce), (op, res)) -> + let op = {source; operation = ires_case.inj op; nonce} in + Internal_manager_operation_result (op, res)) in def "apply_results.alpha.operation_result" @@ union @@ -1595,7 +1596,7 @@ module Encoding = struct Endorsement_result {balance_updates; delegate; endorsement_power}); } - let[@coq_axiom_with_reason "gadt"] dal_slot_availability_case = + let dal_slot_availability_case = Case { op_case = Operation.Encoding.dal_slot_availability_case; @@ -1609,11 +1610,13 @@ module Encoding = struct | Contents_and_result ((Dal_slot_availability _ as op), res) -> Some (op, res) | _ -> None); - proj = (function Dal_slot_availability_result {delegate} -> delegate); + proj = + (function[@coq_match_with_default] + | Dal_slot_availability_result {delegate} -> delegate); inj = (fun delegate -> Dal_slot_availability_result {delegate}); } - let[@coq_axiom_with_reason "gadt"] seed_nonce_revelation_case = + let seed_nonce_revelation_case = Case { op_case = Operation.Encoding.seed_nonce_revelation_case; @@ -1770,7 +1773,7 @@ module Encoding = struct (list internal_manager_operation_result_encoding) []); select = - (function + (function[@coq_match_gadt] | Contents_result (Manager_operation_result ({operation_result = Applied res; _} as op)) -> ( @@ -2001,7 +2004,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] dal_publish_slot_header_case = + let dal_publish_slot_header_case = make_manager_case Operation.Encoding.dal_publish_slot_header_case Manager_result.dal_publish_slot_header_case @@ -2013,7 +2016,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_originate_case = + let sc_rollup_originate_case = make_manager_case Operation.Encoding.sc_rollup_originate_case Manager_result.sc_rollup_originate_case @@ -2057,7 +2060,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_refute_case = + let sc_rollup_refute_case = make_manager_case Operation.Encoding.sc_rollup_refute_case Manager_result.sc_rollup_refute_case @@ -2068,7 +2071,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_timeout_case = + let sc_rollup_timeout_case = make_manager_case Operation.Encoding.sc_rollup_timeout_case Manager_result.sc_rollup_timeout_case @@ -2079,7 +2082,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_execute_outbox_message_case = + let sc_rollup_execute_outbox_message_case = make_manager_case Operation.Encoding.sc_rollup_execute_outbox_message_case Manager_result.sc_rollup_execute_outbox_message_case @@ -2091,7 +2094,7 @@ module Encoding = struct Some (op, res) | _ -> None) - let[@coq_axiom_with_reason "gadt"] sc_rollup_recover_bond_case = + let sc_rollup_recover_bond_case = make_manager_case Operation.Encoding.sc_rollup_recover_bond_case Manager_result.sc_rollup_recover_bond_case @@ -2256,11 +2259,6 @@ let rec packed_contents_result_list_of_list = function Ok (Contents_result_list (Cons_result (o, os))) | _ -> Error "cannot decode ill-formed operation result") -let rec to_list = function - | Contents_result_list (Single_result o) -> [Contents_result o] - | Contents_result_list (Cons_result (o, os)) -> - Contents_result o :: to_list (Contents_result_list os) - let contents_result_list_encoding = def "operation.alpha.contents_list_result" @@ conv_with_guard @@ -2340,11 +2338,11 @@ let operation_metadata_encoding = (fun () -> No_operation_metadata); ] -let kind_equal : +let[@coq_axiom_with_reason "gadt"] kind_equal : type kind kind2. kind contents -> kind2 contents_result -> (kind, kind2) eq option = fun op res -> - match (op, res) with + match[@coq_match_gadt] (op, res) with | Endorsement _, Endorsement_result _ -> Some Eq | Endorsement _, _ -> None | Preendorsement _, Preendorsement_result _ -> Some Eq @@ -2371,13 +2369,12 @@ let kind_equal : (* the Failing_noop operation always fails and can't have result *) None | ( Manager_operation {operation = Reveal _; _}, - Manager_operation_result {operation_result = Applied (Reveal_result _); _} - ) -> - Some Eq + Manager_operation_result {operation_result = Applied applied; _} ) -> ( + match applied with Reveal_result _ -> Some Eq | _ -> None) | ( Manager_operation {operation = Reveal _; _}, - Manager_operation_result - {operation_result = Backtracked (Reveal_result _, _); _} ) -> - Some Eq + Manager_operation_result {operation_result = Backtracked (applied, _); _} + ) -> ( + match applied with Reveal_result _ -> Some Eq | _ -> None) | ( Manager_operation {operation = Reveal _; _}, Manager_operation_result { diff --git a/src/proto_alpha/lib_protocol/apply_results.mli b/src/proto_alpha/lib_protocol/apply_results.mli index eddf70d4ff658..e59d318e5930c 100644 --- a/src/proto_alpha/lib_protocol/apply_results.mli +++ b/src/proto_alpha/lib_protocol/apply_results.mli @@ -404,8 +404,6 @@ val unpack_contents_list : val packed_contents_result_list_to_list : packed_contents_result_list -> packed_contents_result list -val to_list : packed_contents_result_list -> packed_contents_result list - type ('a, 'b) eq = Eq : ('a, 'a) eq val kind_equal_list : -- GitLab From 13a0193be7ed4c4fe9be54345354dac238319e89 Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 7 Jul 2022 23:09:33 -0500 Subject: [PATCH 094/105] adding attributes --- src/proto_alpha/lib_protocol/gas_monad.ml | 2 +- src/proto_alpha/lib_protocol/script_int.ml | 2 +- src/proto_alpha/lib_protocol/script_int.mli | 2 +- .../lib_protocol/script_ir_translator.ml | 22 +++++++++++-------- 4 files changed, 16 insertions(+), 12 deletions(-) diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 3948d4f5c3890..ba4d9045c0601 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -79,7 +79,7 @@ let run ctxt m = ok (res, ctxt) | None -> error Gas.Operation_quota_exceeded) -let record_trace_eval : +let[@coq_axiom_with_reason "type being matched is not informative enough."] record_trace_eval : type error_trace error_context. error_details:(error_context, error_trace) Script_tc_errors.error_details -> (error_context -> error) -> diff --git a/src/proto_alpha/lib_protocol/script_int.ml b/src/proto_alpha/lib_protocol/script_int.ml index a2ef0ebc257e9..5d06c29b734ed 100644 --- a/src/proto_alpha/lib_protocol/script_int.ml +++ b/src/proto_alpha/lib_protocol/script_int.ml @@ -35,7 +35,7 @@ type z = Integer_tag having to deconstruct to and reconstruct from `Z.t`. *) type 't repr = Z.t -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] let compare (Num_tag x) (Num_tag y) = Z.compare x y diff --git a/src/proto_alpha/lib_protocol/script_int.mli b/src/proto_alpha/lib_protocol/script_int.mli index 1dbb5425330dc..7abe7e93c5697 100644 --- a/src/proto_alpha/lib_protocol/script_int.mli +++ b/src/proto_alpha/lib_protocol/script_int.mli @@ -34,7 +34,7 @@ type 't repr [@@coq_phantom] (** [num] is made algebraic in order to distinguish it from the other type parameters of [Script_typed_ir.ty]. *) -type 't num = Num_tag of 't repr [@@ocaml.unboxed] +type 't num = Num_tag of 't repr [@@ocaml.unboxed] [@@coq_force_gadt] (** Flag for natural numbers. *) type n = Natural_tag diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 98fdd36176f7b..b12108214e21c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -168,7 +168,7 @@ let unparse_memo_size ~loc memo_size = let z = Sapling.Memo_size.unparse_to_z memo_size in Int (loc, z) -let rec unparse_ty_and_entrypoints_uncarbonated : +let[@coq_struct "ty"] rec unparse_ty_and_entrypoints_uncarbonated : type a ac loc. loc:loc -> (a, ac) ty -> a entrypoints_node -> loc Script.michelson_node = fun ~loc ty {nested = nested_entrypoints; at_node} -> @@ -277,7 +277,7 @@ let rec unparse_ty_and_entrypoints_uncarbonated : in Prim (loc, name, args, annot) -and unparse_comparable_ty_uncarbonated : +and[@coq_struct "ty"] unparse_comparable_ty_uncarbonated : type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = fun ~loc ty -> unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints @@ -610,7 +610,7 @@ let hash_comparable_data ctxt ty data = All comparable types are dupable, this function exists only to not forget checking this property when adding new types. *) -let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function +let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function[@coq_match_with_default] | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t | Tx_rollup_l2_address_t | Pair_t _ | Union_t _ | Option_t _ -> @@ -704,7 +704,7 @@ let memo_size_eq : if Sapling.Memo_size.equal ms1 ms2 then Result.return_unit else Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> Inconsistent_types_fast | Informative _ -> trace_of_error @@ Inconsistent_memo_sizes (ms1, ms2)) @@ -1617,16 +1617,19 @@ type 'before comb_get_proof_argument = | Comb_get_proof_argument : ('before, 'after) comb_get_gadt_witness * ('after, _) ty -> 'before comb_get_proof_argument +[@@coq_force_gadt] type ('rest, 'before) comb_set_proof_argument = | Comb_set_proof_argument : ('rest, 'before, 'after) comb_set_gadt_witness * ('after, _) ty -> ('rest, 'before) comb_set_proof_argument +[@@coq_force_gadt] type 'before dup_n_proof_argument = | Dup_n_proof_argument : ('before, 'a) dup_n_gadt_witness * ('a, _) ty -> 'before dup_n_proof_argument +[@@coq_force_gadt] let rec make_dug_proof_argument : type a s x xc. @@ -1696,7 +1699,7 @@ let find_entrypoint (type full fullc error_context error_trace) (full : (full, fullc) ty) (entrypoints : full entrypoints) entrypoint : (full ex_ty_cstr, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let rec find_entrypoint : + let[@coq_struct "ty"] rec find_entrypoint : type t tc. (t, tc) ty -> t entrypoints_node -> @@ -1704,12 +1707,12 @@ let find_entrypoint (type full fullc error_context error_trace) (t ex_ty_cstr, unit) Gas_monad.t = fun ty entrypoints entrypoint -> let* () = Gas_monad.consume_gas Typecheck_costs.find_entrypoint_cycle in - match (ty, entrypoints) with + match[@coq_match_gadt] [@coq_match_with_default] (ty, entrypoints) with | _, {at_node = Some {name; original_type_expr}; _} when Entrypoint.(name = entrypoint) -> return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> ( - Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function + Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function [@coq_match_gadt] | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> return (Ex_ty_cstr @@ -1720,10 +1723,11 @@ let find_entrypoint (type full fullc error_context error_trace) }) | Error () -> let+ (Ex_ty_cstr {ty; construct; original_type_expr}) = - find_entrypoint tr right entrypoint + find_entrypoint tr right entrypoint [@coq_type_annotation] in Ex_ty_cstr {ty; construct = (fun e -> R (construct e)); original_type_expr}) + [@coq_cast] | _, {nested = Entrypoints_None; _} -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in @@ -1736,7 +1740,7 @@ let find_entrypoint (type full fullc error_context error_trace) else Gas_monad.of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative _ -> trace_of_error @@ No_such_entrypoint entrypoint) -- GitLab From 4010557ee1f85315db245a0f08a52201f9886e28 Mon Sep 17 00:00:00 2001 From: emarzion Date: Fri, 8 Jul 2022 16:49:35 -0500 Subject: [PATCH 095/105] more work --- .../lib_protocol/script_ir_translator.ml | 39 ++++++++++++------- .../lib_protocol/script_typed_ir.ml | 2 + .../lib_protocol/script_typed_ir.mli | 1 + 3 files changed, 27 insertions(+), 15 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index b12108214e21c..68f8208296023 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -901,6 +901,7 @@ type ('a, 's) judgement = descr : 'b 'u. ('b, 'u) stack_ty -> ('a, 's, 'b, 'u) descr; } -> ('a, 's) judgement + [@@coq_force_gadt] (* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*) @@ -954,6 +955,7 @@ type ex_comparable_ty = | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty type ex_ty = Ex_ty : ('a, _) ty -> ex_ty +[@@coq_force_gadt] type ex_parameter_ty_and_entrypoints_node = | Ex_parameter_ty_and_entrypoints_node : { @@ -1069,7 +1071,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_type_annot loc annot >|? fun () -> return ctxt bls12_381_fr_t | Prim (loc, T_contract, [utl], annot) -> if allow_contract then - parse_passable_ty + parse_passable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1340,7 +1342,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_compar error (Comparable_type_expected (location node, Micheline.strip_locations node)) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty : +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty_aux : type ret name. context -> stack_depth:int -> @@ -1560,6 +1562,7 @@ type ('arg, 'storage) code = code_size : Cache_memory_helpers.sint; } -> ('arg, 'storage) code + [@@coq_force_gadt] type ex_script = Ex_script : ('a, 'c) Script_typed_ir.script -> ex_script @@ -1721,13 +1724,19 @@ let find_entrypoint (type full fullc error_context error_trace) construct = (fun e -> L (construct e)); original_type_expr; }) - | Error () -> - let+ (Ex_ty_cstr {ty; construct; original_type_expr}) = - find_entrypoint tr right entrypoint [@coq_type_annotation] - in - Ex_ty_cstr - {ty; construct = (fun e -> R (construct e)); original_type_expr}) - [@coq_cast] + | Error () -> ( + let+ x = + (find_entrypoint tr right entrypoint [@coq_type_annotation]) + in + match[@coq_match_gadt] x with + | Ex_ty_cstr {ty; construct; original_type_expr} -> + Ex_ty_cstr + { + ty; + construct = (fun e -> R (construct e)); + original_type_expr; + })) + [@coq_cast] | _, {nested = Entrypoints_None; _} -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in @@ -1749,7 +1758,7 @@ let find_entrypoint_for_type (type full fullc exp expc error_trace) entrypoints entrypoint : (Entrypoint.t * (exp, expc) ty, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let* res = find_entrypoint ~error_details full entrypoints entrypoint in + let* res = (find_entrypoint ~error_details full entrypoints entrypoint [@coq_type_annotation]) in match res with | Ex_ty_cstr {ty; _} -> ( match entrypoints.root.at_node with @@ -1834,7 +1843,7 @@ let parse_parameter_ty_and_entrypoints : Script.node -> (ex_parameter_ty_and_entrypoints * context) tzresult = fun ctxt ~stack_depth ~legacy node -> - parse_passable_ty + parse_passable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1848,7 +1857,7 @@ let parse_parameter_ty_and_entrypoints : let entrypoints = {root = entrypoints; original_type_expr = node} in (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -let parse_passable_ty = parse_passable_ty ~ret:Don't_parse_entrypoints +let parse_passable_ty = parse_passable_ty_aux ~ret:Don't_parse_entrypoints let parse_uint ~nb_bits = assert (Compare.Int.(nb_bits >= 0 && nb_bits <= 30)) ; @@ -2193,7 +2202,7 @@ let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = (* The limitation of length of string is same as entrypoint *) if Compare.Int.(String.length v > 31) then error (View_name_too_long v) else - let rec check_char i = + let[@coq_struct "i_value"] rec check_char i = if Compare.Int.(i < 0) then ok v else if Script_ir_annot.is_allowed_char v.[i] then check_char (i - 1) else error (Bad_view_name loc) @@ -2758,7 +2767,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Chest_t, expr -> traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) -and parse_view : +and[@coq_axiom_with_reason "gadt"] parse_view : type storage storagec. ?type_logger:type_logger -> context -> @@ -2822,7 +2831,7 @@ and parse_view : ctxt ) | _ -> error (ill_type_view aft loc)) -and parse_views : +and[@coq_axiom_with_reason "gadt"] parse_views : type storage storagec. ?type_logger:type_logger -> context -> diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index c24ee47f39fdb..26ad69cd0bad6 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1210,6 +1210,7 @@ and (_, _, _, _) continuation = | KLog : ('a, 's, 'r, 'f) continuation * logger -> ('a, 's, 'r, 'f) continuation + [@@coq_force_gadt] and ('a, 's, 'b, 'f, 'c, 'u) logging_function = ('a, 's, 'b, 'f) kinstr -> @@ -1287,6 +1288,7 @@ and ('ty, 'comparable) ty = | Ticket_t : 'a comparable_ty * 'a ticket ty_metadata -> ('a ticket, no) ty | Chest_key_t : (Script_timelock.chest_key, no) ty | Chest_t : (Script_timelock.chest, no) ty + [@@coq_force_gadt] and 'ty comparable_ty = ('ty, yes) ty diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index cd496fcc6aac7..8c2c38533f95e 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1381,6 +1381,7 @@ and ('ty, 'comparable) ty = | Ticket_t : 'a comparable_ty * 'a ticket ty_metadata -> ('a ticket, no) ty | Chest_key_t : (Script_timelock.chest_key, no) ty | Chest_t : (Script_timelock.chest, no) ty + [@@coq_force_gadt] and 'ty comparable_ty = ('ty, yes) ty -- GitLab From a39e84b15c3e78edcea0435f64d92149accf4720 Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 12 Jul 2022 01:20:07 -0500 Subject: [PATCH 096/105] finishing script_ir_translator.ml --- .../lib_protocol/script_ir_translator.ml | 207 +++++++++--------- 1 file changed, 105 insertions(+), 102 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 68f8208296023..fce2d31ed2514 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -978,7 +978,7 @@ type ('ret, 'name) parse_ty_ret = | Parse_entrypoints : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret -let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty : +let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty_aux : type ret name. context -> stack_depth:int -> @@ -1071,7 +1071,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_type_annot loc annot >|? fun () -> return ctxt bls12_381_fr_t | Prim (loc, T_contract, [utl], annot) -> if allow_contract then - parse_passable_ty_aux + parse_passable_ty_aux_with_ret ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1083,7 +1083,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty else error (Unexpected_contract loc) | Prim (loc, T_pair, utl :: utr, annot) -> remove_field_annot utl >>? fun utl -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1100,7 +1100,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) ok (Prim (loc, T_pair, utr, []))) >>? fun utr -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1120,7 +1120,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty remove_field_annot utr >|? fun utr -> (utl, utr) | Parse_entrypoints -> ok (utl, utr)) >>? fun (utl, utr) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1131,7 +1131,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty ~ret utl >>? fun (parsed_l, ctxt) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1167,9 +1167,9 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt) ) | Prim (loc, T_lambda, [uta; utr], annot) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy uta + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy uta >>? fun (Ex_ty ta, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy utr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy utr >>? fun (Ex_ty tr, ctxt) -> check_type_annot loc annot >>? fun () -> lambda_t loc ta tr >|? fun ty -> return ctxt ty @@ -1180,7 +1180,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_composed_type_annot loc annot >>? fun () -> ok ut else check_type_annot loc annot >>? fun () -> ok ut) >>? fun ut -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1193,7 +1193,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty >>? fun (Ex_ty t, ctxt) -> option_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_list, [ut], annot) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1208,20 +1208,20 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty list_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_ticket, [ut], annot) -> if allow_ticket then - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> ticket_t loc t >|? fun ty -> return ctxt ty else error (Unexpected_ticket loc) | Prim (loc, T_set, [ut], annot) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> set_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_map, [uta; utr], annot) -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt uta + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> - parse_ty + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1318,14 +1318,14 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty T_unit; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_comparable_ty +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_comparable_ty_aux : context -> stack_depth:int -> Script.node -> (ex_comparable_ty * context) tzresult = fun ctxt ~stack_depth node -> - parse_ty + parse_ty_aux ~ret:Don't_parse_entrypoints ctxt ~stack_depth:(stack_depth + 1) @@ -1342,7 +1342,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_compar error (Comparable_type_expected (location node, Micheline.strip_locations node)) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty_aux : +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty_aux_with_ret : type ret name. context -> stack_depth:int -> @@ -1351,7 +1351,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab Script.node -> (ret * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1360,7 +1360,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab ~allow_contract:true ~allow_ticket:true -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty_aux : context -> stack_depth:int -> @@ -1368,7 +1368,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty Script.node -> (ex_ty * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1383,9 +1383,9 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt -> match args with | [key_ty; value_ty] -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt key_ty + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt key_ty >>? fun (Ex_comparable_ty key_ty, ctxt) -> - parse_big_map_value_ty + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1396,9 +1396,9 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty_aux ctxt ~stack_depth ~legacy value_ty = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1409,8 +1409,8 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma ~ret:Don't_parse_entrypoints value_ty -let parse_packable_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) +let parse_packable_ty_aux ctxt ~stack_depth ~legacy node = + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1424,7 +1424,7 @@ let parse_packable_ty ctxt ~stack_depth ~legacy node = node let parse_view_input_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1436,7 +1436,7 @@ let parse_view_input_ty ctxt ~stack_depth ~legacy node = node let parse_view_output_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1448,7 +1448,7 @@ let parse_view_output_ty ctxt ~stack_depth ~legacy node = node let parse_normal_storage_ty ctxt ~stack_depth ~legacy node = - (parse_ty [@tailcall]) + (parse_ty_aux [@tailcall]) ctxt ~stack_depth ~legacy @@ -1576,6 +1576,7 @@ type 'storage typed_view = original_code_expr : Script.node; } -> 'storage typed_view + [@@coq_force_gadt] type 'storage typed_view_map = (Script_string.t, 'storage typed_view) map @@ -1836,14 +1837,14 @@ type ex_parameter_ty_and_entrypoints = } -> ex_parameter_ty_and_entrypoints -let parse_parameter_ty_and_entrypoints : +let parse_parameter_ty_and_entrypoints_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_parameter_ty_and_entrypoints * context) tzresult = fun ctxt ~stack_depth ~legacy node -> - parse_passable_ty_aux + parse_passable_ty_aux_with_ret ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1857,7 +1858,7 @@ let parse_parameter_ty_and_entrypoints : let entrypoints = {root = entrypoints; original_type_expr = node} in (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -let parse_passable_ty = parse_passable_ty_aux ~ret:Don't_parse_entrypoints +let parse_passable_ty_aux = parse_passable_ty_aux_with_ret ~ret:Don't_parse_entrypoints let parse_uint ~nb_bits = assert (Compare.Int.(nb_bits >= 0 && nb_bits <= 30)) ; @@ -2218,7 +2219,7 @@ let parse_view_name ctxt : Script.node -> (Script_string.t * context) tzresult = Script_string.of_string v >|? fun s -> (s, ctxt) ) | expr -> error @@ Invalid_kind (location expr, [String_kind], kind expr) -let parse_toplevel : +let parse_toplevel_aux : context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult = fun ctxt ~legacy toplevel -> record_trace (Ill_typed_contract (toplevel, [])) @@ -2325,7 +2326,7 @@ let parse_toplevel : - storage after origination *) -let[@coq_axiom_with_reason "gadt"] rec parse_data : +let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : type a ac. ?type_logger:type_logger -> stack_depth:int -> @@ -2341,7 +2342,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : if Compare.Int.(stack_depth > 10_000) then fail Typechecking_too_many_recursive_calls else - parse_data + parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -2497,7 +2498,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : traced ( parse_address ctxt expr >>?= fun (address, ctxt) -> let loc = location expr in - parse_contract_data + parse_contract_data_aux ~stack_depth:(stack_depth + 1) ctxt loc @@ -2636,12 +2637,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | _, None -> traced_fail (Invalid_big_map (loc, id)) | ctxt, Some (btk, btv) -> Lwt.return - ( parse_comparable_ty + ( parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt (Micheline.root btk) >>? fun (Ex_comparable_ty btk, ctxt) -> - parse_big_map_value_ty + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -2791,7 +2792,7 @@ and[@coq_axiom_with_reason "gadt"] parse_view : (parse_view_output_ty ctxt ~stack_depth:0 ~legacy output_ty) >>?= fun (Ex_ty output_ty, ctxt) -> pair_t input_ty_loc input_ty storage_type >>?= fun (Ty_ex_c pair_ty) -> - parse_instr + parse_instr_aux ?type_logger ~stack_depth:0 Tc_context.view @@ -2860,7 +2861,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : Script.node -> ((arg, ret) lambda * context) tzresult Lwt.t = fun ?type_logger ~stack_depth tc_context ctxt ~legacy arg ret script_instr -> - parse_instr + parse_instr_aux ?type_logger tc_context ctxt @@ -2891,7 +2892,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : : (arg, ret) lambda), ctxt ) -and[@coq_axiom_with_reason "gadt"] parse_instr : +and[@coq_axiom_with_reason "gadt"] parse_instr_aux : type a s. ?type_logger:type_logger -> stack_depth:int -> @@ -2937,7 +2938,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : if Compare.Int.(stack_depth > 10000) then fail Typechecking_too_many_recursive_calls else - parse_instr + parse_instr_aux ?type_logger tc_context ctxt @@ -3068,9 +3069,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc swap stack_ty | Prim (loc, I_PUSH, [t; d], annot), stack -> check_var_annot loc annot >>?= fun () -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> - parse_data + parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) ctxt @@ -3091,7 +3092,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let cons_some = {apply = (fun kinfo k -> ICons_some (kinfo, k))} in option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest)) | Prim (loc, I_NONE, [t], annot), stack -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let cons_none = {apply = (fun kinfo k -> ICons_none (kinfo, k))} in @@ -3256,7 +3257,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc cdr (Item_t (b, rest)) (* unions *) | Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tr >>?= fun (Ex_ty tr, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_left = {apply = (fun kinfo k -> ICons_left (kinfo, k))} in @@ -3264,7 +3265,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack_ty = Item_t (ty, rest) in typed ctxt loc cons_left stack_ty | Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tl + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tl >>?= fun (Ex_ty tl, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_right = {apply = (fun kinfo k -> ICons_right (kinfo, k))} in @@ -3309,7 +3310,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Lwt.return @@ merge_branches ctxt loc btr bfr {branch} (* lists *) | Prim (loc, I_NIL, [t], annot), stack -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let nil = {apply = (fun kinfo k -> INil (kinfo, k))} in @@ -3430,7 +3431,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ) (* sets *) | Prim (loc, I_EMPTY_SET, [t], annot), rest -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt t + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t >>?= fun (Ex_comparable_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_set (kinfo, t, k))} in @@ -3490,9 +3491,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* maps *) | Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_map (kinfo, tk, k))} in @@ -3616,9 +3617,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : typed ctxt loc instr (Item_t (nat_t, rest)) (* big_map *) | Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack -> - parse_comparable_ty ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_big_map_value_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = @@ -3855,9 +3856,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (tr, rest) in typed_no_lwt ctxt loc instr stack) | Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy arg >>?= fun (Ex_ty arg, ctxt) -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ret >>?= fun (Ex_ty ret, ctxt) -> check_kind [Seq_kind] code >>?= fun () -> check_var_annot loc annot >>?= fun () -> @@ -4301,7 +4302,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : (* annotations *) | Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack) -> check_var_annot loc annot >>?= fun () -> - parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t >>?= fun (Ex_ty cast_t, ctxt) -> Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) cast_t t >>?= fun (eq, ctxt) -> @@ -4326,7 +4327,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> option_t loc t >>?= fun res_ty -> @@ -4340,7 +4341,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : let stack = Item_t (address_t, rest) in typed ctxt loc instr stack | Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest) -> - parse_passable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_passable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> contract_t loc t >>?= fun contract_ty -> option_t loc contract_ty >>?= fun res_ty -> @@ -4399,11 +4400,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : contracts but then we throw away the typed version, except for the storage type which is kept for efficiency in the ticket scanner. *) let canonical_code = Micheline.strip_locations code in - parse_toplevel ctxt ~legacy canonical_code + parse_toplevel_aux ctxt ~legacy canonical_code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> record_trace (Ill_formed_type (Some "parameter", canonical_code, location arg_type)) - (parse_parameter_ty_and_entrypoints + (parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -4914,7 +4915,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : I_XOR; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract_data : +and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract_data_aux : type arg argc. stack_depth:int -> context -> @@ -4997,9 +4998,9 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra code >>? fun (code, ctxt) -> (* can only fail because of gas *) - parse_toplevel ctxt ~legacy:true code + parse_toplevel_aux ctxt ~legacy:true code >>? fun ({arg_type; _}, ctxt) -> - parse_parameter_ty_and_entrypoints + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy:true @@ -5047,7 +5048,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra ctxt parameters_type >>? fun (parameters_type, ctxt) -> - parse_parameter_ty_and_entrypoints + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy:true @@ -5125,12 +5126,12 @@ let parse_code : code >>?= fun (code, ctxt) -> Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code + parse_toplevel_aux ctxt ~legacy code >>?= fun ({arg_type; storage_type; code_field; views}, ctxt) -> let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:0 ~legacy arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5178,7 +5179,7 @@ let parse_storage : (fun () -> let storage_type = serialize_ty_for_error storage_type in Ill_typed_data (None, storage, storage_type)) - (parse_data + (parse_data_aux ?type_logger ~stack_depth:0 ctxt @@ -5224,7 +5225,7 @@ type typechecked_code_internal = } -> typechecked_code_internal -let typecheck_code : +let typecheck_code_aux : legacy:bool -> show_types:bool -> context -> @@ -5233,13 +5234,13 @@ let typecheck_code : fun ~legacy ~show_types ctxt code -> (* Constants need to be expanded or [parse_toplevel] may fail. *) Global_constants_storage.expand ctxt code >>=? fun (ctxt, code) -> - parse_toplevel ctxt ~legacy code >>?= fun (toplevel, ctxt) -> + parse_toplevel_aux ctxt ~legacy code >>?= fun (toplevel, ctxt) -> let {arg_type; storage_type; code_field; views} = toplevel in let type_map = ref [] in let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:0 ~legacy arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5333,7 +5334,7 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) (* -- Unparsing data of any type -- *) -let[@coq_axiom_with_reason "gadt"] rec unparse_data : +let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : type a ac. context -> stack_depth:int -> @@ -5346,7 +5347,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : let non_terminal_recursion ctxt mode ty a = if Compare.Int.(stack_depth > 10_000) then fail Unparsing_too_many_recursive_calls - else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a + else unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode ty a in let loc = Micheline.dummy_location in match (ty, a) with @@ -5398,7 +5399,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : opened_ticket_type loc t >>?= fun t -> let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in - (unparse_data [@tailcall]) + (unparse_data_aux [@tailcall]) ctxt ~stack_depth mode @@ -5461,7 +5462,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data : unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) | Lambda_t _, Lam (_, original_code) -> - unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code + unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code | Never_t, _ -> . | Sapling_transaction_t _, s -> Lwt.return @@ -5532,22 +5533,22 @@ and unparse_items : (fun (l, ctxt) (k, v) -> let loc = Micheline.dummy_location in unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v + unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode vt v >|=? fun (value, ctxt) -> (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) ([], ctxt) items -and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = +and[@coq_axiom_with_reason "gadt"] unparse_code_aux ctxt ~stack_depth mode code = let legacy = true in Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> let non_terminal_recursion ctxt mode code = if Compare.Int.(stack_depth > 10_000) then fail Unparsing_too_many_recursive_calls - else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code + else unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode code in match code with | Prim (loc, I_PUSH, [ty; data], annot) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> let allow_forged = false @@ -5556,7 +5557,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = from APPLYing a non-forgeable but this cannot happen either as long as all packable values are also forgeable. *) in - parse_data + parse_data_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -5564,7 +5565,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code ctxt ~stack_depth mode code = t data >>=? fun (data, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data + unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode t data >>=? fun (data, ctxt) -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) | Seq (loc, items) -> @@ -5594,7 +5595,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage ctxt code >>?= fun (code, ctxt) -> - typecheck_code ~legacy ~show_types:false ctxt code + typecheck_code_aux ~legacy ~show_types:false ctxt code >>=? fun ( Typechecked_code_internal { toplevel = @@ -5611,15 +5612,15 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage type_map = _; }, ctxt ) -> - parse_storage + (parse_storage [@coq_implicit "storage" "a"]) ctxt ~legacy ~allow_forged:allow_forged_in_storage storage_type ~storage >>=? fun (storage, ctxt) -> - unparse_code ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> - unparse_data ctxt ~stack_depth:0 mode storage_type storage + unparse_code_aux ctxt ~stack_depth:0 mode code_field >>=? fun (code, ctxt) -> + unparse_data_aux ctxt ~stack_depth:0 mode storage_type storage >>=? fun (storage, ctxt) -> let loc = Micheline.dummy_location in (if normalize_types then @@ -5641,7 +5642,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage >>=? fun (arg_type, storage_type, views, ctxt) -> Script_map.map_es_in_context (fun ctxt _name {input_ty; output_ty; view_code} -> - unparse_code ctxt ~stack_depth:0 mode view_code + unparse_code_aux ctxt ~stack_depth:0 mode view_code >|=? fun (view_code, ctxt) -> ({input_ty; output_ty; view_code}, ctxt)) ctxt views @@ -5679,7 +5680,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage ctxt ) let pack_data_with_mode ctxt ty data ~mode = - unparse_data ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> + unparse_data_aux ~stack_depth:0 ctxt mode ty data >>=? fun (unparsed, ctxt) -> Lwt.return @@ pack_node unparsed ctxt let hash_data ctxt ty data = @@ -5696,7 +5697,9 @@ type lazy_storage_ids = Lazy_storage.IdSet.t let no_lazy_storage_id = Lazy_storage.IdSet.empty let diff_of_big_map ctxt mode ~temporary ~ids_to_copy - (Big_map {id; key_type; value_type; diff}) = + (big_map : ('a, 'b) big_map) = + match[@coq_match_gadt] big_map with + | Big_map {id; key_type; value_type; diff} -> (match id with | Some id -> if Lazy_storage.IdSet.mem Big_map id ids_to_copy then @@ -5739,7 +5742,7 @@ let diff_of_big_map ctxt mode ~temporary ~ids_to_copy (match value with | None -> return (None, ctxt) | Some x -> - unparse_data ~stack_depth:0 ctxt mode value_type x + unparse_data_aux ~stack_depth:0 ctxt mode value_type x >>=? fun (node, ctxt) -> Lwt.return ( Gas.consume ctxt (Script.strip_locations_cost node) >|? fun ctxt -> @@ -6065,7 +6068,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode let list_of_big_map_ids ids = Lazy_storage.IdSet.fold Big_map (fun id acc -> id :: acc) ids [] -let parse_data = parse_data ~stack_depth:0 +let parse_data = parse_data_aux ~stack_depth:0 let parse_comparable_data = parse_data ~legacy:false ~allow_forged:false @@ -6079,7 +6082,7 @@ let parse_instr : (a, s) stack_ty -> ((a, s) judgement * context) tzresult Lwt.t = fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty -> - parse_instr + parse_instr_aux ~stack_depth:0 ?type_logger tc_context @@ -6088,34 +6091,34 @@ let parse_instr : script_instr stack_ty -let unparse_data = unparse_data ~stack_depth:0 +let unparse_data = unparse_data_aux ~stack_depth:0 let unparse_code ctxt mode code = (* Constants need to be expanded or [unparse_code] may fail. *) Global_constants_storage.expand ctxt (strip_locations code) - >>=? fun (ctxt, code) -> unparse_code ~stack_depth:0 ctxt mode (root code) + >>=? fun (ctxt, code) -> unparse_code_aux ~stack_depth:0 ctxt mode (root code) let parse_contract_data context loc arg_ty contract ~entrypoint = - parse_contract_data ~stack_depth:0 context loc arg_ty contract ~entrypoint + parse_contract_data_aux ~stack_depth:0 context loc arg_ty contract ~entrypoint let parse_toplevel ctxt ~legacy toplevel = Global_constants_storage.expand ctxt toplevel >>=? fun (ctxt, toplevel) -> - Lwt.return @@ parse_toplevel ctxt ~legacy toplevel + Lwt.return @@ parse_toplevel_aux ctxt ~legacy toplevel -let parse_comparable_ty = parse_comparable_ty ~stack_depth:0 +let parse_comparable_ty = parse_comparable_ty_aux ~stack_depth:0 -let parse_big_map_value_ty = parse_big_map_value_ty ~stack_depth:0 +let parse_big_map_value_ty = parse_big_map_value_ty_aux ~stack_depth:0 -let parse_packable_ty = parse_packable_ty ~stack_depth:0 +let parse_packable_ty = parse_packable_ty_aux ~stack_depth:0 -let parse_passable_ty = parse_passable_ty ~stack_depth:0 +let parse_passable_ty = parse_passable_ty_aux ~stack_depth:0 -let parse_any_ty = parse_any_ty ~stack_depth:0 +let parse_any_ty = parse_any_ty_aux ~stack_depth:0 -let parse_ty = parse_ty ~stack_depth:0 ~ret:Don't_parse_entrypoints +let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints let parse_parameter_ty_and_entrypoints = - parse_parameter_ty_and_entrypoints ~stack_depth:0 + parse_parameter_ty_and_entrypoints_aux ~stack_depth:0 let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = let has_lazy_storage = has_lazy_storage ty in @@ -6182,5 +6185,5 @@ let script_size (Saturation_repr.(add code_size storage_size |> to_int), cost) let typecheck_code ~legacy ~show_types ctxt code = - typecheck_code ~legacy ~show_types ctxt code + typecheck_code_aux ~legacy ~show_types ctxt code >|=? fun (Typechecked_code_internal {type_map; _}, ctxt) -> (type_map, ctxt) -- GitLab From aa2eddee0b5781fbfb1bab5eba4eb498581cee73 Mon Sep 17 00:00:00 2001 From: emarzion Date: Tue, 12 Jul 2022 18:23:37 -0500 Subject: [PATCH 097/105] tx_rollup_l2_context --- .../lib_protocol/tx_rollup_l2_context.ml | 17 +- .../lib_protocol/tx_rollup_l2_context_sig.ml | 200 +++++++++--------- 2 files changed, 111 insertions(+), 106 deletions(-) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml index 233d37239d2f9..8e9f1c5457633 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context.ml @@ -275,7 +275,12 @@ struct end end - module Address_index = struct + module Address_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Tx_rollup_l2_address.t + and type index := address_index = struct let count ctxt = let open Syntax in let+ count = get ctxt Address_count in @@ -312,7 +317,12 @@ struct end end - module Ticket_index = struct + module Ticket_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Alpha_context.Ticket_hash.t + and type index := ticket_index = struct let count ctxt = let open Syntax in let+ count = get ctxt Ticket_count in @@ -349,7 +359,8 @@ struct end end - module Ticket_ledger = struct + module Ticket_ledger : TICKET_LEDGER with type t := t and type 'a m := 'a m = + struct let get_opt ctxt tidx aidx = get ctxt (Ticket_ledger (tidx, aidx)) let get ctxt tidx aidx = diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml index 270247f0feaad..a706f3d14673d 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_context_sig.ml @@ -233,132 +233,61 @@ module type ADDRESS_METADATA = sig end end -(** This module type describes the API of the [Tx_rollup] context, - which is used to implement the semantics of the L2 operations. *) -module type CONTEXT = sig - (** The state of the [Tx_rollup] context. - - The context provides a type-safe, functional API to interact - with the state of a transaction rollup. The functions of this - module, manipulating and creating values of type [t] are called - “context operations” afterwards. *) +module type INDEX = sig type t - (** The monad used by the context. - - {b Note:} It is likely to be the monad of the underlying - storage. In the case of the proof verifier, as it is expected to - be run into the L1, the monad will also be used to perform gas - accounting. This is why all the functions of this module type - needs to be inside the monad [m]. *) type 'a m - module Syntax : SYNTAX with type 'a m := 'a m - - (** [bls_aggregate_verify] allows to verify the aggregated signature - of a batch. *) - val bls_verify : - (Bls_signature.pk * bytes) list -> Bls_signature.signature -> bool m - - (** The metadata associated to an address. *) - module Address_metadata : - ADDRESS_METADATA with type t := t and type 'a m := 'a m - - (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}. - - Addresses are supposed to be associated to a {!address_index} in - order to reduce the batches' size submitted from the layer1 to the - layer2. Therefore, the first time an address is used in a layer2 - operation, we associate it to a address_index that should be use - in future layer2 operations. - *) - module Address_index : sig - (** [init_counter ctxt] writes the default counter (i.e. [0L]) in - the context. *) - val init_counter : t -> t m - - (** [get ctxt addr] returns the index associated to [addr], if - any. *) - val get : t -> Tx_rollup_l2_address.t -> address_index option m - - (** [get_or_associate_index ctxt addr] associates a fresh [address_index] - to [addr], and returns it. If the [addr] has already been associated to - an index, it returns it. - It also returns the information on whether the index was created or - already existed. - - This function can fail with [Too_many_l2_addresses] iff there - is no fresh index available. *) - val get_or_associate_index : - t -> Tx_rollup_l2_address.t -> (t * created_existed * address_index) m - - (** [count ctxt] returns the number of addresses that have been - involved in the transaction rollup. *) - val count : t -> int32 m - - (**/**) - - module Internal_for_tests : sig - (** [set ctxt count] sets the [count] in [ctxt]. It is used to test - the behavior of [Too_many_l2_addresses]. *) - val set_count : t -> int32 -> t m - end - end + type hash - (** Mapping between {!Ticket_hash.t} and {!ticket_index}. + type index - Ticket hashes are supposed to be associated to a {!ticket_index} in - order to reduce the batches' size submitted from the layer1 to the - layer2. Therefore, the first time a ticket hash is used in a layer2 - operation, we associate it to a ticket_index that should be use - in future layer2 operations. - *) - module Ticket_index : sig - (** [init_counter ctxt] writes the default counter (i.e. [0L]) in + (** [init_counter ctxt] writes the default counter (i.e. [0L]) in the context. *) - val init_counter : t -> t m + val init_counter : t -> t m - (** [get ctxt ticket] returns the index associated to [ticket], if + (** [get ctxt hash] returns the index associated to [hash], if any. *) - val get : t -> Alpha_context.Ticket_hash.t -> ticket_index option m + val get : t -> hash -> index option m - (** [get_or_associate_index ctxt ticket] associates a fresh [ticket_index] - to [ticket], and returns it. If the [ticket] has already been associated + (** [get_or_associate_index ctxt hash] associates a fresh [index] + to [hash], and returns it. If the [hash] has already been associated to an index, it returns it. It also returns the information on whether the index was created or already existed. This function can fail with [Too_many_l2_tickets] iff there is no fresh index available. *) - val get_or_associate_index : - t -> Alpha_context.Ticket_hash.t -> (t * created_existed * ticket_index) m + val get_or_associate_index : t -> hash -> (t * created_existed * index) m - (** [count ctxt] returns the number of tickets that have been + (** [count ctxt] returns the number of tickets that have been involved in the transaction rollup. *) - val count : t -> int32 m + val count : t -> int32 m - (**/**) + (**/**) - module Internal_for_tests : sig - (** [set_count ctxt count] sets the [count] in [ctxt]. It is used to test + module Internal_for_tests : sig + (** [set_count ctxt count] sets the [count] in [ctxt]. It is used to test the behavior of [Too_many_l2_addresses]. *) - val set_count : t -> int32 -> t m - end + val set_count : t -> int32 -> t m end +end - (** The ledger of the layer 2 where are registered the amount of a - given ticket a L2 [account] has in its possession. *) - module Ticket_ledger : sig - (** [get ctxt tidx aidx] returns the quantity of tickets ([tidx]) [aidx] +module type TICKET_LEDGER = sig + type t + + type 'a m + + (** [get ctxt tidx aidx] returns the quantity of tickets ([tidx]) [aidx] owns. {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. The function will return zero when the address has no such ticket. *) - val get : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t m + val get : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t m - (** [credit ctxt tidx aidx qty] updates the ledger to + (** [credit ctxt tidx aidx qty] updates the ledger to increase the number of tickets indexed by [tidx] the address [aidx] owns by [qty] units. @@ -372,9 +301,9 @@ module type CONTEXT = sig {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. *) - val credit : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m + val credit : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m - (** [spend ctxt tidx aidx qty] updates the ledger to + (** [spend ctxt tidx aidx qty] updates the ledger to decrease the number of tickets indexed by [tidx] the address [aidx] owns by [qty] units. @@ -384,11 +313,76 @@ module type CONTEXT = sig {b Note:} It is the responsibility of the caller to verify that [aidx] and [tidx] have been associated to an address and a ticket respectively. *) - val spend : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m + val spend : t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t -> t m - module Internal_for_tests : sig - val get_opt : - t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t option m - end + module Internal_for_tests : sig + val get_opt : + t -> ticket_index -> address_index -> Tx_rollup_l2_qty.t option m end end + +(** This module type describes the API of the [Tx_rollup] context, + which is used to implement the semantics of the L2 operations. *) +module type CONTEXT = sig + (** The state of the [Tx_rollup] context. + + The context provides a type-safe, functional API to interact + with the state of a transaction rollup. The functions of this + module, manipulating and creating values of type [t] are called + “context operations” afterwards. *) + type t + + (** The monad used by the context. + + {b Note:} It is likely to be the monad of the underlying + storage. In the case of the proof verifier, as it is expected to + be run into the L1, the monad will also be used to perform gas + accounting. This is why all the functions of this module type + needs to be inside the monad [m]. *) + type 'a m + + module Syntax : SYNTAX with type 'a m := 'a m + + (** [bls_aggregate_verify] allows to verify the aggregated signature + of a batch. *) + val bls_verify : + (Bls_signature.pk * bytes) list -> Bls_signature.signature -> bool m + + (** The metadata associated to an address. *) + module Address_metadata : + ADDRESS_METADATA with type t := t and type 'a m := 'a m + + (** Mapping between {!Tx_rollup_l2_address.address} and {!address_index}. + + Addresses are supposed to be associated to a {!address_index} in + order to reduce the batches' size submitted from the layer1 to the + layer2. Therefore, the first time an address is used in a layer2 + operation, we associate it to a address_index that should be use + in future layer2 operations. + *) + module Address_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Tx_rollup_l2_address.t + and type index := address_index + + (** Mapping between {!Ticket_hash.t} and {!ticket_index}. + + Ticket hashes are supposed to be associated to a {!ticket_index} in + order to reduce the batches' size submitted from the layer1 to the + layer2. Therefore, the first time a ticket hash is used in a layer2 + operation, we associate it to a ticket_index that should be use + in future layer2 operations. + *) + module Ticket_index : + INDEX + with type t := t + and type 'a m := 'a m + and type hash := Alpha_context.Ticket_hash.t + and type index := ticket_index + + (** The ledger of the layer 2 where are registered the amount of a + given ticket a L2 [account] has in its possession. *) + module Ticket_ledger : TICKET_LEDGER with type t := t and type 'a m := 'a m +end -- GitLab From 3d5dc45f05b1933a839889ac2c4bfac3a5fd566d Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 14 Jul 2022 00:19:25 -0500 Subject: [PATCH 098/105] script interpreter work --- src/proto_alpha/lib_protocol/script_big_map.ml | 6 +++--- src/proto_alpha/lib_protocol/script_interpreter.ml | 6 ++++-- .../lib_protocol/script_interpreter_defs.ml | 11 ++++++----- src/proto_alpha/lib_protocol/script_typed_ir.ml | 2 +- 4 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_big_map.ml b/src/proto_alpha/lib_protocol/script_big_map.ml index 44369f61a1fd5..0e323a4f6e8e1 100644 --- a/src/proto_alpha/lib_protocol/script_big_map.ml +++ b/src/proto_alpha/lib_protocol/script_big_map.ml @@ -29,7 +29,7 @@ open Script_typed_ir open Script_ir_translator -let empty key_type value_type = +let[@coq_axiom_with_reason "type issues."] empty key_type value_type = Big_map { id = None; @@ -48,7 +48,7 @@ let mem ctxt key (Big_map {id; diff; key_type; _}) = | Some (_, None), _ -> return (false, ctxt) | Some (_, Some _), _ -> return (true, ctxt) -let get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = +let[@coq_axiom_with_reason "type issues"] get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = match (Big_map_overlay.find key diff.map, id) with | Some (_, x), _ -> return (x, ctxt) | None, None -> return (None, ctxt) @@ -68,7 +68,7 @@ let get ctxt key (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> get_by_hash ctxt key_hash map -let update_by_hash key_hash key value (Big_map map) = +let[@coq_axiom_with_reason "type issues"] update_by_hash key_hash key value (Big_map map) = let contains = Big_map_overlay.mem key_hash map.diff.map in Big_map { diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 1ec5c2e6cca11..c3ba51d9a8f6c 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -451,7 +451,8 @@ and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = and[@coq_mutual_as_notation] ilsl_nat : type a b c d e f. (a, b, c, d, e, f) ilsl_nat_type = fun logger g gas kinfo k ks accu stack -> - let x = accu and y, stack = stack in + let x = accu in + let y, stack = stack in match[@coq_type_annotation] Script_int.shift_left_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some x -> (step [@ocaml.tailcall]) g gas k ks x stack @@ -459,7 +460,8 @@ and[@coq_mutual_as_notation] ilsl_nat : and[@coq_mutual_as_notation] ilsr_nat : type a b c d e f. (a, b, c, d, e, f) ilsr_nat_type = fun logger g gas kinfo k ks accu stack -> - let x = accu and y, stack = stack in + let x = accu in + let y, stack = stack in match[@coq_type_annotation] Script_int.shift_right_n x y with | None -> get_log logger >>=? fun log -> fail (Overflow (kinfo.iloc, log)) | Some r -> (step [@ocaml.tailcall]) g gas k ks r stack diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index e94a5de023c68..d1bd91a1eed4e 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -479,12 +479,13 @@ let[@coq_struct "w_value"] rec kundip : formal argument to [v]. The type of [v] is represented by [ty]. *) let apply ctxt gas capture_ty capture lam = let (Lam (descr, expr)) = lam in - let (Item_t (full_arg_ty, _)) = descr.kbef in + match[@coq_match_with_default] descr.kbef with + | Item_t (full_arg_ty, _) -> let ctxt = update_context gas ctxt in unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> let loc = Micheline.dummy_location in unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> - match full_arg_ty with + match[@coq_match_with_default] full_arg_ty with | Pair_t (capture_ty, arg_ty, _, _) -> let arg_stack_ty = Item_t (arg_ty, Bot_t) in let full_descr = @@ -712,11 +713,11 @@ let[@coq_struct "n_value"] rec interp_stack_prefix_preserving_operation : u -> (d * w) * result = fun f n accu stk -> - match[@coq_match_gadt_with_result] (n, stk) with - | KPrefix (_, n), rest -> + match[@coq_match_gadt_with_result] (n, accu, stk) with + | (KPrefix (_, n), _, (rest : _ * _)) -> interp_stack_prefix_preserving_operation f n (fst rest) (snd rest) |> fun ((v, rest'), result) -> ((accu, (v, rest')), result) - | KRest, v -> f accu v + | (KRest, (accu : a), (v : s)) -> f accu v (* diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 26ad69cd0bad6..949357db496f4 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1306,7 +1306,7 @@ and ('key, 'value) big_map = value_type : ('value, _) ty; } -> ('key, 'value) big_map -[@@coq_force_gadt] + [@@coq_force_gadt] and ('a, 's, 'r, 'f) kdescr = { kloc : Script.location; -- GitLab From 2a3986d43c4d111b257ed4c73720b1fdfd191efb Mon Sep 17 00:00:00 2001 From: emarzion Date: Thu, 14 Jul 2022 21:03:22 -0500 Subject: [PATCH 099/105] interpreter work --- .../lib_protocol/script_big_map.ml | 4 +- .../lib_protocol/script_interpreter.ml | 650 ++++++++++-------- 2 files changed, 354 insertions(+), 300 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_big_map.ml b/src/proto_alpha/lib_protocol/script_big_map.ml index 0e323a4f6e8e1..7116f8fdec62c 100644 --- a/src/proto_alpha/lib_protocol/script_big_map.ml +++ b/src/proto_alpha/lib_protocol/script_big_map.ml @@ -29,11 +29,11 @@ open Script_typed_ir open Script_ir_translator -let[@coq_axiom_with_reason "type issues."] empty key_type value_type = +let empty key_type value_type : ('a, 'b) big_map = Big_map { id = None; - diff = {map = Big_map_overlay.empty; size = 0}; + diff = {map = Big_map_overlay.empty; size = 0} [@coq_type_annotation]; key_type; value_type; } diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index c3ba51d9a8f6c..7dddeea91790b 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -265,12 +265,13 @@ let[@coq_mutual_as_notation] rec kmap_exit : let ys = Script_map.update yk (Some accu) ys in let ks = mk (KMap_enter_body (body, xs, ys, ks)) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack + [@coq_type_annotation]) [@@inline] -and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = +and[@coq_mutual_as_notation] kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = fun mk g gas body xs ys ks accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks ys (accu, stack) | (xk, xv) :: xs -> let ks = mk (KMap_exit_body (body, xs, ys, xk, ks)) in @@ -279,17 +280,18 @@ and kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = (step [@ocaml.tailcall]) g gas body ks res stack [@@inline] -and klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type = +and[@coq_mutual_as_notation] klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type = fun mk g gas body xs ys len ks accu stack -> let ks = mk (KList_enter_body (body, xs, accu :: ys, len, ks)) in let accu, stack = stack in - (next [@ocaml.tailcall]) g gas ks accu stack + ((next [@ocaml.tailcall]) g gas ks accu stack + [@coq_type_annotation]) [@@inline] and[@coq_mutual_as_notation] klist_enter : type a b c d e j. (a, b, c, d, e, j) klist_enter_type = fun mk g gas body xs ys len ks' accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> let ys = {elements = List.rev ys; length = len} in (next [@ocaml.tailcall]) g gas ks' ys (accu, stack) @@ -315,9 +317,9 @@ and[@coq_mutual_as_notation] kloop_in : else (next [@ocaml.tailcall]) g gas ks' accu' stack' [@@inline] -and kiter : type a b s r f. (a, b, s, r, f) kiter_type = +and[@coq_mutual_as_notation] kiter : type a b s r f. (a, b, s, r, f) kiter_type = fun mk g gas body xs ks accu stack -> - match xs with + match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks accu stack | x :: xs -> let ks = mk (KIter (body, xs, ks)) in @@ -337,29 +339,29 @@ and[@coq_struct "gas"] next : match consume_control gas ks0 with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match[@coq_match_gadt] ks0 with - | KLog (ks, logger) -> + match[@coq_match_gadt] ks0, accu, stack with + | KLog (ks, logger), _, _ -> (klog [@ocaml.tailcall]) logger g gas ks0 ks accu stack - | KNil -> Lwt.return (Ok (accu, stack, ctxt, gas)) - | KCons (k, ks) -> (step [@ocaml.tailcall]) g gas k ks accu stack - | KLoop_in (ki, ks') -> + | KNil, (accu : r), (stack : f) -> Lwt.return (Ok (accu, stack, ctxt, gas)) + | KCons (k, ks), _, _ -> (step [@ocaml.tailcall]) g gas k ks accu stack + | KLoop_in (ki, ks'), (accu : bool), (stack : _ * _) -> (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KReturn (stack', ks) -> (next [@ocaml.tailcall]) g gas ks accu stack' - | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack - | KLoop_in_left (ki, ks') -> + | KReturn (stack', ks), _, _ -> (next [@ocaml.tailcall]) g gas ks accu stack' + | KMap_head (f, ks), _, _ -> (next [@ocaml.tailcall]) g gas ks (f accu) stack + | KLoop_in_left (ki, ks'), (accu : _ union), _ -> (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KUndip (x, ks) -> (next [@ocaml.tailcall]) g gas ks x (accu, stack) - | KIter (body, xs, ks) -> + | KUndip (x, ks), _, _ -> (next [@ocaml.tailcall]) g gas ks x (accu, stack) + | KIter (body, xs, ks), _, _ -> (kiter [@ocaml.tailcall]) id g gas body xs ks accu stack - | KList_enter_body (body, xs, ys, len, ks) -> + | KList_enter_body (body, xs, ys, len, ks), _, _ -> (klist_enter [@ocaml.tailcall]) id g gas body xs ys len ks accu stack - | KList_exit_body (body, xs, ys, len, ks) -> + | KList_exit_body (body, xs, ys, len, ks), _, (stack : _ * _) -> (klist_exit [@ocaml.tailcall]) id g gas body xs ys len ks accu stack - | KMap_enter_body (body, xs, ys, ks) -> + | KMap_enter_body (body, xs, ys, ks), _, _ -> (kmap_enter [@ocaml.tailcall]) id g gas body xs ys ks accu stack - | KMap_exit_body (body, xs, ys, yk, ks) -> + | KMap_exit_body (body, xs, ys, yk, ks), _, (stack : _ * _) -> (kmap_exit [@ocaml.tailcall]) id g gas body xs ys yk ks accu stack - | KView_exit (orig_step_constants, ks) -> + | KView_exit (orig_step_constants, ks), _, _ -> let g = (fst g, orig_step_constants) in (next [@ocaml.tailcall]) g gas ks accu stack) @@ -469,7 +471,8 @@ and[@coq_mutual_as_notation] ilsr_nat : and[@coq_mutual_as_notation] iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = fun logger g gas k ks accu stack -> - let arg = accu and code, stack = stack in + let arg = accu in + let code, stack = stack in let (Lam (code, _)) = code in let code = match logger with @@ -491,25 +494,25 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = match consume_instr gas i accu stack with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match i with - | ILog (_, event, logger, k) -> + match[@coq_match_gadt] [@coq_match_with_default] i, accu, stack with + | ILog (_, event, logger, k), _, _ -> (log [@ocaml.tailcall]) (logger, event) g gas k ks accu stack - | IHalt _ -> (next [@ocaml.tailcall]) g gas ks accu stack + | IHalt _, _, _ -> (next [@ocaml.tailcall]) g gas ks accu stack (* stack ops *) - | IDrop (_, k) -> + | IDrop (_, k), _, (stack : _ * _) -> let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDup (_, k) -> (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) - | ISwap (_, k) -> + | IDup (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) + | ISwap (_, k), _, (stack : _ * _) -> let top, stack = stack in (step [@ocaml.tailcall]) g gas k ks top (accu, stack) - | IConst (_, v, k) -> (step [@ocaml.tailcall]) g gas k ks v (accu, stack) + | IConst (_, v, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks v (accu, stack) (* options *) - | ICons_some (_, k) -> + | ICons_some (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks (Some accu) stack - | ICons_none (_, k) -> - (step [@ocaml.tailcall]) g gas k ks None (accu, stack) - | IIf_none {branch_if_none; branch_if_some; k; _} -> ( + | ICons_none (_, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks (None [@coq_type_annotation]) (accu, stack) + | IIf_none {branch_if_none; branch_if_some; k; _}, (accu : _ option), (stack : _ * _) -> ( match accu with | None -> let accu, stack = stack in @@ -528,29 +531,29 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) v stack) - | IOpt_map {body; k; kinfo = _} -> ( + | IOpt_map {body; k; kinfo = _}, (accu : _ option), _ -> ( match accu with - | None -> (step [@ocaml.tailcall]) g gas k ks None stack + | None -> (step [@ocaml.tailcall]) g gas k ks (None [@coq_type_annotation]) stack | Some v -> - let ks' = KMap_head (Option.some, KCons (k, ks)) in + let ks' = KMap_head ((Option.some [@coq_type_annotation]), KCons (k, ks)) in (step [@ocaml.tailcall]) g gas body ks' v stack) (* pairs *) - | ICons_pair (_, k) -> + | ICons_pair (_, k), _, (stack : _ * _) -> let b, stack = stack in (step [@ocaml.tailcall]) g gas k ks (accu, b) stack - | IUnpair (_, k) -> + | IUnpair (_, k), (accu : _ * _), _ -> let a, b = accu in (step [@ocaml.tailcall]) g gas k ks a (b, stack) - | ICar (_, k) -> + | ICar (_, k), (accu : _ * _), _ -> let a, _ = accu in (step [@ocaml.tailcall]) g gas k ks a stack - | ICdr (_, k) -> + | ICdr (_, k), (accu : _ * _), _ -> let _, b = accu in (step [@ocaml.tailcall]) g gas k ks b stack (* unions *) - | ICons_left (_, k) -> (step [@ocaml.tailcall]) g gas k ks (L accu) stack - | ICons_right (_, k) -> (step [@ocaml.tailcall]) g gas k ks (R accu) stack - | IIf_left {branch_if_left; branch_if_right; k; _} -> ( + | ICons_left (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks (L accu [@coq_type_annotation]) stack + | ICons_right (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks (R accu [@coq_type_annotation]) stack + | IIf_left {branch_if_left; branch_if_right; k; _}, (accu : _ union), _ -> ( match accu with | L v -> (step [@ocaml.tailcall]) @@ -569,15 +572,15 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = v stack) (* lists *) - | ICons_list (_, k) -> + | ICons_list (_, k), _, (stack : _ * _) -> let tl, stack = stack in let accu = Script_list.cons accu tl in (step [@ocaml.tailcall]) g gas k ks accu stack - | INil (_, k) -> + | INil (_, k), _, _ -> let stack = (accu, stack) in let accu = Script_list.empty in - (step [@ocaml.tailcall]) g gas k ks accu stack - | IIf_cons {branch_if_cons; branch_if_nil; k; _} -> ( + (step [@ocaml.tailcall]) g gas k ks (accu [@coq_implicit "E" "__INil_'b"]) stack + | IIf_cons {branch_if_cons; branch_if_nil; k; _}, (accu : _ boxed_list), (stack : _ * _) -> ( match accu.elements with | [] -> let accu, stack = stack in @@ -597,88 +600,91 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) hd (tl, stack)) - | IList_map (_, body, k) -> - (ilist_map [@ocaml.tailcall]) id g gas body k ks accu stack - | IList_size (_, k) -> + | IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _) -> + (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b"]) id g gas body k ks accu stack + | IList_size (_, k), (accu : _ boxed_list), _ -> let list = accu in let len = Script_int.(abs (of_int list.length)) in (step [@ocaml.tailcall]) g gas k ks len stack - | IList_iter (_, body, k) -> + | IList_iter (_, body, k), (accu : _ boxed_list), (stack : _ * _) -> (ilist_iter [@ocaml.tailcall]) id g gas body k ks accu stack (* sets *) - | IEmpty_set (_, ty, k) -> - let res = Script_set.empty ty in + | IEmpty_set (_, ty, k), _, _ -> + let res = (Script_set.empty [@coq_type_annotation]) ty in let stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_iter (_, body, k) -> + | ISet_iter (_, body, k), (accu : _ set), (stack : _ * _) -> (iset_iter [@ocaml.tailcall]) id g gas body k ks accu stack - | ISet_mem (_, k) -> + | ISet_mem (_, k), _, (stack : _ * _) -> let set, stack = stack in let res = Script_set.mem accu set in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_update (_, k) -> + | ISet_update (_, k), _, (stack : _ * (_ * _)) -> let presence, (set, stack) = stack in let res = Script_set.update accu presence set in (step [@ocaml.tailcall]) g gas k ks res stack - | ISet_size (_, k) -> + | ISet_size (_, k), (accu : _ set), _ -> let res = Script_set.size accu in (step [@ocaml.tailcall]) g gas k ks res stack (* maps *) - | IEmpty_map (_, ty, k) -> - let res = Script_map.empty ty and stack = (accu, stack) in + | IEmpty_map (_, ty, k), _, _ -> + let res = (Script_map.empty [@coq_type_annotation]) ty in + let stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_map (_, body, k) -> - (imap_map [@ocaml.tailcall]) id g gas body k ks accu stack - | IMap_iter (_, body, k) -> + | IMap_map (_, body, k), (accu : _ map), (stack : _ * _) -> + (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c"]) id g gas body k ks accu stack + | IMap_iter (_, body, k), (accu : _ map), (stack : _ * _) -> (imap_iter [@ocaml.tailcall]) id g gas body k ks accu stack - | IMap_mem (_, k) -> + | IMap_mem (_, k), _, (stack : _ * _) -> let map, stack = stack in let res = Script_map.mem accu map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_get (_, k) -> + | IMap_get (_, k), _, (stack : _ * _) -> let map, stack = stack in let res = Script_map.get accu map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_update (_, k) -> + | IMap_update (_, k), _, (stack : _ * (_ * _)) -> let v, (map, stack) = stack in let key = accu in let res = Script_map.update key v map in (step [@ocaml.tailcall]) g gas k ks res stack - | IMap_get_and_update (_, k) -> + | IMap_get_and_update (_, k), _, (stack : _ * (_ * _)) -> let key = accu in let v, (map, rest) = stack in let map' = Script_map.update key v map in let v' = Script_map.get key map in (step [@ocaml.tailcall]) g gas k ks v' (map', rest) - | IMap_size (_, k) -> + | IMap_size (_, k), (accu : _ map), _ -> let res = Script_map.size accu in (step [@ocaml.tailcall]) g gas k ks res stack (* Big map operations *) - | IEmpty_big_map (_, tk, tv, k) -> - let ebm = Script_big_map.empty tk tv in + | IEmpty_big_map (_, tk, tv, k), _, _ -> + let ebm = (Script_big_map.empty + [@coq_implicit "a" "__IEmpty_big_map_'b"] + [@coq_implicit "b" "__IEmpty_big_map_'c"]) tk tv in (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack) - | IBig_map_mem (_, k) -> + | IBig_map_mem (_, k), _, (stack : _ * _) -> let map, stack = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_big_map.mem ctxt key map ) >>=? fun (res, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBig_map_get (_, k) -> + | IBig_map_get (_, k), _, (stack : _ * _) -> let map, stack = stack in let key = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_big_map.get ctxt key map ) >>=? fun (res, ctxt, gas) -> - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBig_map_update (_, k) -> + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks (res [@coq_type_annotation]) stack + | IBig_map_update (_, k), _, (stack : _ * (_ * _)) -> let key = accu in let maybe_value, (map, stack) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_big_map.update ctxt key maybe_value map ) >>=? fun (big_map, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks big_map stack - | IBig_map_get_and_update (_, k) -> + | IBig_map_get_and_update (_, k), _, (stack : _ * (_ * _)) -> let key = accu in let v, (map, stack) = stack in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> @@ -686,33 +692,33 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = >>=? fun ((v', map'), ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks v' (map', stack) (* timestamp operations *) - | IAdd_seconds_to_timestamp (_, k) -> + | IAdd_seconds_to_timestamp (_, k), (accu : _ Script_int.num), (stack : _ * _) -> let n = accu in let t, stack = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | IAdd_timestamp_to_seconds (_, k) -> + | IAdd_timestamp_to_seconds (_, k), (accu : Script_timestamp.t), (stack : _ * _) -> let t = accu in let n, stack = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | ISub_timestamp_seconds (_, k) -> + | ISub_timestamp_seconds (_, k), (accu : Script_timestamp.t), (stack : _ * _) -> let t = accu in let s, stack = stack in let result = Script_timestamp.sub_delta t s in (step [@ocaml.tailcall]) g gas k ks result stack - | IDiff_timestamps (_, k) -> + | IDiff_timestamps (_, k), (accu : Script_timestamp.t), (stack : _ * _) -> let t1 = accu in let t2, stack = stack in let result = Script_timestamp.diff t1 t2 in (step [@ocaml.tailcall]) g gas k ks result stack (* string operations *) - | IConcat_string_pair (_, k) -> + | IConcat_string_pair (_, k), (accu : Script_string.t), (stack : _ * _) -> let x = accu in let y, stack = stack in let s = Script_string.concat_pair x y in (step [@ocaml.tailcall]) g gas k ks s stack - | IConcat_string (_, k) -> + | IConcat_string (_, k), (accu : _ boxed_list), _ -> let ss = accu in (* The cost for this fold_left has been paid upfront *) let total_length = @@ -724,8 +730,9 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = consume gas (Interp_costs.concat_string total_length) >>?= fun gas -> let s = Script_string.concat ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack - | ISlice_string (_, k) -> - let offset = accu and length, (s, stack) = stack in + | ISlice_string (_, k), (accu : _ Script_int.num), (stack : _ * (Script_string.t * _)) -> + let offset = accu in + let length, (s, stack) = stack in let s_length = Z.of_int (Script_string.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -733,18 +740,18 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Script_string.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks None stack - | IString_size (_, k) -> + else (step [@ocaml.tailcall]) g gas k ks (None [@coq_type_annotation]) stack + | IString_size (_, k), (accu : Script_string.t), _ -> let s = accu in let result = Script_int.(abs (of_int (Script_string.length s))) in (step [@ocaml.tailcall]) g gas k ks result stack (* bytes operations *) - | IConcat_bytes_pair (_, k) -> + | IConcat_bytes_pair (_, k), (accu : bytes), (stack : _ * _) -> let x = accu in let y, stack = stack in let s = Bytes.cat x y in (step [@ocaml.tailcall]) g gas k ks s stack - | IConcat_bytes (_, k) -> + | IConcat_bytes (_, k), (accu : _ boxed_list), _ -> let ss = accu in (* The cost for this fold_left has been paid upfront *) let total_length = @@ -756,8 +763,9 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = consume gas (Interp_costs.concat_string total_length) >>?= fun gas -> let s = Bytes.concat Bytes.empty ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack - | ISlice_bytes (_, k) -> - let offset = accu and length, (s, stack) = stack in + | ISlice_bytes (_, k), (accu : _ Script_int.num), (stack : _ * (_ * _)) -> + let offset = accu in + let length, (s, stack) = stack in let s_length = Z.of_int (Bytes.length s) in let offset = Script_int.to_zint offset in let length = Script_int.to_zint length in @@ -765,85 +773,91 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Bytes.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks None stack - | IBytes_size (_, k) -> + else (step [@ocaml.tailcall]) g gas k ks (None [@coq_type_annotation]) stack + | IBytes_size (_, k), (accu : bytes), _ -> let s = accu in let result = Script_int.(abs (of_int (Bytes.length s))) in (step [@ocaml.tailcall]) g gas k ks result stack (* currency operations *) - | IAdd_tez (_, k) -> + | IAdd_tez (_, k), (accu : Tez.t), (stack : _ * _) -> let x = accu in let y, stack = stack in Tez.(x +? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_tez (_, k) -> + | ISub_tez (_, k), (accu : Tez.t), (stack : _ * _) -> let x = accu in let y, stack = stack in let res = Tez.sub_opt x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_tez_legacy (_, k) -> + | ISub_tez_legacy (_, k), (accu : Tez.t), (stack : _ * _) -> let x = accu in let y, stack = stack in Tez.(x -? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_teznat (kinfo, k) -> imul_teznat None g gas kinfo k ks accu stack - | IMul_nattez (kinfo, k) -> imul_nattez None g gas kinfo k ks accu stack + | IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _) -> imul_teznat None g gas kinfo k ks accu stack + | IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _) -> imul_nattez None g gas kinfo k ks accu stack (* boolean operations *) - | IOr (_, k) -> + | IOr (_, k), (accu : bool), (stack : _ * _) -> let x = accu in let y, stack = stack in (step [@ocaml.tailcall]) g gas k ks (x || y) stack - | IAnd (_, k) -> + | IAnd (_, k), (accu : bool), (stack : _ * _) -> let x = accu in let y, stack = stack in (step [@ocaml.tailcall]) g gas k ks (x && y) stack - | IXor (_, k) -> + | IXor (_, k), (accu : bool), (stack : _ * _) -> let x = accu in let y, stack = stack in let res = Compare.Bool.(x <> y) in (step [@ocaml.tailcall]) g gas k ks res stack - | INot (_, k) -> + | INot (_, k), (accu : bool), _ -> let x = accu in (step [@ocaml.tailcall]) g gas k ks (not x) stack (* integer operations *) - | IIs_nat (_, k) -> + | IIs_nat (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.is_nat x in (step [@ocaml.tailcall]) g gas k ks res stack - | IAbs_int (_, k) -> + | IAbs_int (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.abs x in (step [@ocaml.tailcall]) g gas k ks res stack - | IInt_nat (_, k) -> + | IInt_nat (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.int x in (step [@ocaml.tailcall]) g gas k ks res stack - | INeg (_, k) -> + | INeg (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.neg x in (step [@ocaml.tailcall]) g gas k ks res stack - | IAdd_int (_, k) -> - let x = accu and y, stack = stack in + | IAdd_int (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.add x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAdd_nat (_, k) -> - let x = accu and y, stack = stack in + | IAdd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.add_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ISub_int (_, k) -> - let x = accu and y, stack = stack in + | ISub_int (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.sub x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_int (_, k) -> - let x = accu and y, stack = stack in + | IMul_int (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_nat (_, k) -> - let x = accu and y, stack = stack in + | IMul_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.mul_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_teznat (_, k) -> - let x = accu and y, stack = stack in + | IEdiv_teznat (_, k), (accu : Tez.t), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let x = Script_int.of_int64 (Tez.to_mutez x) in let result = match Script_int.ediv x y with @@ -859,8 +873,9 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = | _ -> assert false) in (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_tez (_, k) -> - let x = accu and y, stack = stack in + | IEdiv_tez (_, k), (accu : Tez.t), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in let result = @@ -875,38 +890,44 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = | Some r -> Some (q, r))) in (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_int (_, k) -> - let x = accu and y, stack = stack in + | IEdiv_int (_, k), (accu : _ Script_int.num), (stack : _ Script_int.num * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.ediv x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IEdiv_nat (_, k) -> - let x = accu and y, stack = stack in + | IEdiv_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.ediv_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ILsl_nat (kinfo, k) -> ilsl_nat None g gas kinfo k ks accu stack - | ILsr_nat (kinfo, k) -> ilsr_nat None g gas kinfo k ks accu stack - | IOr_nat (_, k) -> - let x = accu and y, stack = stack in + | ILsl_nat (kinfo, k), (accu : _ Script_int.num), (stack : _ Script_int.num * _) -> ilsl_nat None g gas kinfo k ks accu stack + | ILsr_nat (kinfo, k), (accu : _ Script_int.num), (stack : _ Script_int.num * _) -> ilsr_nat None g gas kinfo k ks accu stack + | IOr_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.logor x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_nat (_, k) -> - let x = accu and y, stack = stack in + | IAnd_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IAnd_int_nat (_, k) -> - let x = accu and y, stack = stack in + | IAnd_int_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.logand x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IXor_nat (_, k) -> - let x = accu and y, stack = stack in + | IXor_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + let x = accu in + let y, stack = stack in let res = Script_int.logxor x y in (step [@ocaml.tailcall]) g gas k ks res stack - | INot_int (_, k) -> + | INot_int (_, k), (accu : _ Script_int.num), _ -> let x = accu in let res = Script_int.lognot x in (step [@ocaml.tailcall]) g gas k ks res stack (* control *) - | IIf {branch_if_true; branch_if_false; k; _} -> + | IIf {branch_if_true; branch_if_false; k; _}, (accu : bool), (stack : _ * _) -> let res, stack = stack in if accu then (step [@ocaml.tailcall]) @@ -924,30 +945,30 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (KCons (k, ks)) res stack - | ILoop (_, body, k) -> + | ILoop (_, body, k), _, _ -> let ks = KLoop_in (body, KCons (k, ks)) in (next [@ocaml.tailcall]) g gas ks accu stack - | ILoop_left (_, bl, br) -> + | ILoop_left (_, bl, br), _, _ -> let ks = KLoop_in_left (bl, KCons (br, ks)) in (next [@ocaml.tailcall]) g gas ks accu stack - | IDip (_, b, k) -> + | IDip (_, b, k), _, (stack : _ * _) -> let ign = accu in let ks = KUndip (ign, KCons (k, ks)) in let accu, stack = stack in (step [@ocaml.tailcall]) g gas b ks accu stack - | IExec (_, k) -> iexec None g gas k ks accu stack - | IApply (_, capture_ty, k) -> + | IExec (_, k), _, (stack : _ lambda * _) -> iexec None g gas k ks accu stack + | IApply (_, capture_ty, k), _, (stack : _ lambda * _) -> let capture = accu in let lam, stack = stack in apply ctxt gas capture_ty capture lam >>=? fun (lam', ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks lam' stack - | ILambda (_, lam, k) -> + | ILambda (_, lam, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks lam (accu, stack) - | IFailwith (_, kloc, tv) -> + | IFailwith (_, kloc, tv), _, _ -> let {ifailwith} = ifailwith in ifailwith None g gas kloc tv accu (* comparison *) - | ICompare (_, ty, k) -> + | ICompare (_, ty, k), _, (stack : _ * _) -> let a = accu in let b, stack = stack in let r = @@ -955,53 +976,53 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = in (step [@ocaml.tailcall]) g gas k ks r stack (* comparators *) - | IEq (_, k) -> + | IEq (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a = 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | INeq (_, k) -> + | INeq (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a <> 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | ILt (_, k) -> + | ILt (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a < 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | ILe (_, k) -> + | ILe (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a <= 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | IGt (_, k) -> + | IGt (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a > 0) in (step [@ocaml.tailcall]) g gas k ks a stack - | IGe (_, k) -> + | IGe (_, k), (accu : _ Script_int.num), _ -> let a = accu in let a = Script_int.compare a Script_int.zero in let a = Compare.Int.(a >= 0) in (step [@ocaml.tailcall]) g gas k ks a stack (* packing *) - | IPack (_, ty, k) -> + | IPack (_, ty, k), _, _ -> let value = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_ir_translator.pack_data ctxt ty value ) >>=? fun (bytes, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks bytes stack - | IUnpack (_, ty, k) -> + | IUnpack (_, ty, k), (accu : bytes), _ -> let bytes = accu in ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> - unpack ctxt ~ty ~bytes ) + (unpack [@coq_type_annotation]) ctxt ~ty ~bytes ) >>=? fun (opt, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks opt stack - | IAddress (_, k) -> + | IAddress (_, k), (accu : _ Script_typed_ir.typed_contract), _ -> let (Typed_contract {address; _}) = accu in (step [@ocaml.tailcall]) g gas k ks address stack - | IContract (kinfo, t, entrypoint, k) -> ( + | IContract (kinfo, t, entrypoint, k), (accu : address), _ -> ( let addr = accu in let entrypoint_opt = if Entrypoint.is_default addr.entrypoint then Some entrypoint @@ -1021,8 +1042,8 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let accu = maybe_contract in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | ITransfer_tokens (kinfo, k) -> + | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks (None [@coq_type_annotation]) stack) + | ITransfer_tokens (kinfo, k), _, (stack : _ * (_ typed_contract * _)) -> let p = accu in let amount, (Typed_contract {arg_ty; address}, stack) = stack in let {destination; entrypoint} = address in @@ -1037,7 +1058,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = entrypoint >>=? fun (accu, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | IImplicit_account (_, k) -> + | IImplicit_account (_, k), (accu : public_key_hash), _ -> let key = accu in let arg_ty = unit_t in let address = @@ -1048,14 +1069,14 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = in let res = Typed_contract {arg_ty; address} in (step [@ocaml.tailcall]) g gas k ks res stack - | IView (_, View_signature {name; input_ty; output_ty}, k) -> ( + | IView (_, View_signature {name; input_ty; output_ty}, k), _, (stack : address * _) -> ( let input = accu in let addr, stack = stack in let c = addr.destination in let ctxt = update_context gas ctxt in let return_none ctxt = let gas, ctxt = local_gas_counter_and_outdated_context ctxt in - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack + (step [@ocaml.tailcall]) (ctxt, sc) gas k ks (None [@coq_type_annotation]) stack in match c with | Contract (Implicit _) | Tx_rollup _ | Sc_rollup _ -> @@ -1143,7 +1164,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (KView_exit (sc, KReturn (stack, ks))) (input, storage) (EmptyCell, EmptyCell)))))) - | ICreate_contract {storage_type; code; k; kinfo = _} -> + | ICreate_contract {storage_type; code; k; kinfo = _}, (accu : public_key_hash option), (stack : _ * (_ * _)) -> (* Removed the instruction's arguments manager, spendable and delegatable *) let delegate = accu in let credit, (init, stack) = stack in @@ -1152,7 +1173,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = let destination = Destination.Contract (Originated contract) in let stack = ({destination; entrypoint = Entrypoint.default}, stack) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | ISet_delegate (_, k) -> + | ISet_delegate (_, k), (accu : public_key_hash option), _ -> let delegate = accu in let operation = Delegation delegate in let ctxt = update_context gas ctxt in @@ -1161,18 +1182,18 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = Internal_operation {source = Contract.Originated sc.self; operation; nonce} in - let res = {piop; lazy_storage_diff = None} in + let res = {piop; lazy_storage_diff = (None [@coq_type_annotation] : Lazy_storage.diffs option)} in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack - | IBalance (_, k) -> + | IBalance (_, k), _, _ -> let ctxt = update_context gas ctxt in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks sc.balance (accu, stack) - | ILevel (_, k) -> + | ILevel (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks sc.level (accu, stack) - | INow (_, k) -> (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) - | IMin_block_time (_, k) -> + | INow (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) + | IMin_block_time (_, k), _, _ -> let ctxt = update_context gas ctxt in let min_block_time = Alpha_context.Constants.minimal_block_delay ctxt @@ -1182,47 +1203,49 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = in let new_stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks min_block_time new_stack - | ICheck_signature (_, k) -> - let key = accu and signature, (message, stack) = stack in + | ICheck_signature (_, k), (accu : public_key), (stack : _ * (_ * _)) -> + let key = accu in + let signature, (message, stack) = stack in let res = Script_signature.check key signature message in (step [@ocaml.tailcall]) g gas k ks res stack - | IHash_key (_, k) -> + | IHash_key (_, k), (accu : public_key), _ -> let key = accu in let res = Signature.Public_key.hash key in (step [@ocaml.tailcall]) g gas k ks res stack - | IBlake2b (_, k) -> + | IBlake2b (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.blake2b bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha256 (_, k) -> + | ISha256 (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.sha256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha512 (_, k) -> + | ISha512 (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.sha512 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISource (_, k) -> + | ISource (_, k), _, _ -> let destination : Destination.t = Contract sc.payer in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISender (_, k) -> + | ISender (_, k), _, _ -> let destination : Destination.t = Contract sc.source in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf (_, ty, entrypoint, k) -> + | ISelf (_, ty, entrypoint, k), _, _ -> let destination : Destination.t = Contract (Originated sc.self) in let address = {destination; entrypoint} in let res = Typed_contract {arg_ty = ty; address} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | ISelf_address (_, k) -> + | ISelf_address (_, k), _, _ -> let destination : Destination.t = Contract (Originated sc.self) in let res = {destination; entrypoint = Entrypoint.default} in (step [@ocaml.tailcall]) g gas k ks res (accu, stack) - | IAmount (_, k) -> - let accu = sc.amount and stack = (accu, stack) in + | IAmount (_, k), _, _ -> + let stack = (accu, stack) in + let accu = sc.amount in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDig (_, _n, n', k) -> + | IDig (_, _n, n', k), _, _ -> let (accu, stack), x = interp_stack_prefix_preserving_operation (fun v stack -> (stack, v)) @@ -1230,9 +1253,10 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = accu stack in - let accu = x and stack = (accu, stack) in + let stack = ((accu, stack) [@coq_type_annotation]) in + let accu = x in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDug (_, _n, n', k) -> + | IDug (_, _n, n', k), _, (stack : _ * _) -> let v = accu in let accu, stack = stack in let (accu, stack), () = @@ -1242,34 +1266,34 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = accu stack in - (step [@ocaml.tailcall]) g gas k ks accu stack - | IDipn (_, _n, n', b, k) -> - let accu, stack, restore_prefix = kundip n' accu stack k in + (step [@ocaml.tailcall]) g gas k ks (accu [@coq_type_annotation]) (stack [@coq_type_annotation]) + | IDipn (_, _n, n', b, k), _, _ -> + let accu, stack, restore_prefix = (kundip [@coq_type_annotation]) n' accu stack k in let ks = KCons (restore_prefix, ks) in (step [@ocaml.tailcall]) g gas b ks accu stack - | IDropn (_, _n, n', k) -> + | IDropn (_, _n, n', k), _, _ -> let stack = - let rec aux : + let[@coq_struct "w_value"] rec aux : type a s b t. (b, t, b, t, a, s, a, s) stack_prefix_preservation_witness -> a -> s -> b * t = fun w accu stack -> - match w with - | KRest -> (accu, stack) - | KPrefix (_, w) -> + match[@coq_match_gadt] w, accu, stack with + | KRest, (accu : b), (stack : t) -> (accu, stack) + | KPrefix (_, w), _, (stack : _ * _) -> let accu, stack = stack in aux w accu stack in - aux n' accu stack + (aux [@coq_type_annotation]) n' accu stack in let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | ISapling_empty_state (_, memo_size, k) -> + | ISapling_empty_state (_, memo_size, k), _, _ -> let state = Sapling.empty_state ~memo_size () in (step [@ocaml.tailcall]) g gas k ks state (accu, stack) - | ISapling_verify_update (_, k) -> ( + | ISapling_verify_update (_, k), (accu : Sapling.transaction), (stack : _ * _) -> ( let transaction = accu in let state, stack = stack in let address = Contract_hash.to_b58check sc.self in @@ -1288,8 +1312,8 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (Script_int.of_int64 balance, state) ) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | ISapling_verify_update_deprecated (_, k) -> ( + | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks (None [@coq_type_annotation]) stack) + | ISapling_verify_update_deprecated (_, k), (accu : Sapling_repr.legacy_transaction), (stack : _ * _) -> ( let transaction = accu in let state, stack = stack in let address = Contract_hash.to_b58check sc.self in @@ -1304,170 +1328,200 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = | Some (balance, state) -> let state = Some (Script_int.of_int64 balance, state) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks None stack) - | IChainId (_, k) -> - let accu = Script_chain_id.make sc.chain_id - and stack = (accu, stack) in - (step [@ocaml.tailcall]) g gas k ks accu stack - | INever _ -> ( match accu with _ -> .) - | IVoting_power (_, k) -> + | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks (None [@coq_type_annotation]) stack) + | IChainId (_, k), _, _ -> + let stack = (accu, stack) in + let accu = Script_chain_id.make sc.chain_id in + (step [@ocaml.tailcall]) g gas k ks accu stack + | INever _, _, _ -> . + | IVoting_power (_, k), (accu : public_key_hash), _ -> let key_hash = accu in let ctxt = update_context gas ctxt in Vote.get_voting_power ctxt key_hash >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks power stack - | ITotal_voting_power (_, k) -> + | ITotal_voting_power (_, k), _, _ -> let ctxt = update_context gas ctxt in Vote.get_total_voting_power ctxt >>=? fun (ctxt, power) -> let power = Script_int.(abs (of_int64 power)) in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let g = (ctxt, sc) in (step [@ocaml.tailcall]) g gas k ks power (accu, stack) - | IKeccak (_, k) -> + | IKeccak (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.keccak256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | ISha3 (_, k) -> + | ISha3 (_, k), (accu : bytes), _ -> let bytes = accu in let hash = Raw_hashes.sha3_256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | IAdd_bls12_381_g1 (_, k) -> - let x = accu and y, stack = stack in + | IAdd_bls12_381_g1 (_, k), (accu : Script_bls.G1.t), (stack : Script_bls.G1.t * _) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G1.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_g2 (_, k) -> - let x = accu and y, stack = stack in + | IAdd_bls12_381_g2 (_, k), (accu : Script_bls.G2.t), (stack : Script_bls.G2.t * _) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G2.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_fr (_, k) -> - let x = accu and y, stack = stack in + | IAdd_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), (stack : Script_bls.Fr.t * _) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.Fr.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g1 (_, k) -> - let x = accu and y, stack = stack in + | IMul_bls12_381_g1 (_, k), (accu : Script_bls.G1.t), (stack : Script_bls.Fr.t * _) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G1.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g2 (_, k) -> - let x = accu and y, stack = stack in + | IMul_bls12_381_g2 (_, k), (accu : Script_bls.G2.t), (stack : Script_bls.Fr.t * _) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.G2.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr (_, k) -> - let x = accu and y, stack = stack in + | IMul_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), (stack : Script_bls.Fr.t * _) -> + let x = accu in + let y, stack = stack in let accu = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr_z (_, k) -> - let x = accu and y, stack = stack in + | IMul_bls12_381_fr_z (_, k), (accu : _ Script_int.num), (stack : Script_bls.Fr.t * _) -> + let x = accu in + let y, stack = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_bls12_381_z_fr (_, k) -> - let y = accu and x, stack = stack in + | IMul_bls12_381_z_fr (_, k), (accu : Script_bls.Fr.t), (stack : _ Script_int.num * _) -> + let y = accu in + let x, stack = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IInt_bls12_381_fr (_, k) -> + | IInt_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _ -> let x = accu in let res = Script_int.of_zint (Script_bls.Fr.to_z x) in (step [@ocaml.tailcall]) g gas k ks res stack - | INeg_bls12_381_g1 (_, k) -> + | INeg_bls12_381_g1 (_, k), (accu : Script_bls.G1.t), _ -> let x = accu in let accu = Script_bls.G1.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | INeg_bls12_381_g2 (_, k) -> + | INeg_bls12_381_g2 (_, k), (accu : Script_bls.G2.t), _ -> let x = accu in let accu = Script_bls.G2.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | INeg_bls12_381_fr (_, k) -> + | INeg_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), _ -> let x = accu in let accu = Script_bls.Fr.negate x in (step [@ocaml.tailcall]) g gas k ks accu stack - | IPairing_check_bls12_381 (_, k) -> + | IPairing_check_bls12_381 (_, k), (accu : _ boxed_list), _ -> let pairs = accu in let check = Script_bls.pairing_check pairs.elements in (step [@ocaml.tailcall]) g gas k ks check stack - | IComb (_, _, witness, k) -> - let rec aux : + | IComb (_, _, witness, k), _, _ -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) comb_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | Comb_one, stack -> stack - | Comb_succ witness', (a, tl) -> - let b, tl' = aux witness' tl in - ((a, b), tl') + match[@coq_match_gadt] (witness, stack) with + | (Comb_one, (stack : after)) -> stack + | (Comb_succ witness', (stack : _ * _)) -> + let (a, tl) = stack in + let (b, tl') = (aux [@coq_type_annotation]) witness' tl in + ((((a, b), tl') [@coq_cast]) : after) in - let stack = aux witness (accu, stack) in + let stack = (aux [@coq_type_annotation]) witness (accu, stack) in let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IUncomb (_, _, witness, k) -> - let rec aux : + | IUncomb (_, _, witness, k), _, _ -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) uncomb_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | Uncomb_one, stack -> stack - | Uncomb_succ witness', ((a, b), tl) -> (a, aux witness' (b, tl)) + match[@coq_match_gadt] (witness, stack) with + | (Uncomb_one, (stack : after)) -> stack + | (Uncomb_succ witness', (stack : (_ * _) * _)) -> + let ((a, b), tl) = stack in + (((a, (aux [@coq_type_annotation]) witness' (b, tl)) + [@coq_cast]) + : after) in - let stack = aux witness (accu, stack) in + let stack = (aux [@coq_type_annotation]) witness (accu, stack) in let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IComb_get (_, _, witness, k) -> + | IComb_get (_, _, witness, k), _, _ -> let comb = accu in - let rec aux : + let[@coq_struct "witness"] rec aux : type before after. (before, after) comb_get_gadt_witness -> before -> after = fun witness comb -> - match (witness, comb) with - | Comb_get_zero, v -> v - | Comb_get_one, (a, _) -> a - | Comb_get_plus_two witness', (_, b) -> aux witness' b + match[@coq_match_gadt] (witness, comb) with + | (Comb_get_zero, (v : after)) -> v + | (Comb_get_one, (comb : after * _)) -> + let (a, _) = comb in + a + | (Comb_get_plus_two witness', (comb : _ * _)) -> + let (_, b) = comb in + aux witness' b in - let accu = aux witness comb in + let accu = (aux [@coq_type_annotation]) witness comb in (step [@ocaml.tailcall]) g gas k ks accu stack - | IComb_set (_, _, witness, k) -> - let value = accu and comb, stack = stack in - let rec aux : + | IComb_set (_, _, witness, k), _, (stack : _ * _) -> + let value = accu in + let comb, stack = stack in + let[@coq_struct "witness"] rec aux : type value before after. (value, before, after) comb_set_gadt_witness -> value -> before -> after = fun witness value item -> - match (witness, item) with - | Comb_set_zero, _ -> value - | Comb_set_one, (_hd, tl) -> (value, tl) - | Comb_set_plus_two witness', (hd, tl) -> (hd, aux witness' value tl) + match[@coq_match_gadt] (witness, value, item) with + | (Comb_set_zero, (value : after), _) -> value + | (Comb_set_one, _, (item : _ * _)) -> + let (_hd, tl) = item in + (((value, tl) [@coq_cast]) : after) + | (Comb_set_plus_two witness', _, (item : _ * _)) -> + let (hd, tl) = item in + (((hd, (aux [@coq_type_annotation]) witness' value tl) + [@coq_cast]) + : after) in - let accu = aux witness value comb in + let accu = (aux [@coq_type_annotation]) witness value comb in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDup_n (_, _, witness, k) -> - let rec aux : + | IDup_n (_, _, witness, k), _, _ -> + let[@coq_struct "witness"] rec aux : type before after. (before, after) dup_n_gadt_witness -> before -> after = fun witness stack -> - match (witness, stack) with - | Dup_n_zero, (a, _) -> a - | Dup_n_succ witness', (_, tl) -> aux witness' tl + match[@coq_match_gadt] (witness, stack) with + | (Dup_n_zero, (stack : after * _)) -> + let (a, _) = stack in + a + | (Dup_n_succ witness', (stack : _ * _)) -> + let (_, tl) = stack in + aux witness' tl in let stack = (accu, stack) in - let accu = aux witness stack in + let accu = (aux [@coq_type_annotation]) witness stack in (step [@ocaml.tailcall]) g gas k ks accu stack (* Tickets *) - | ITicket (_, k) -> - let contents = accu and amount, stack = stack in + | ITicket (_, k), _, (stack : _ * _) -> + let contents = accu in + let amount, stack = stack in let ticketer = Contract.Originated sc.self in let accu = {ticketer; contents; amount} in (step [@ocaml.tailcall]) g gas k ks accu stack - | IRead_ticket (_, k) -> + | IRead_ticket (_, k), (accu : _ ticket), _ -> let {ticketer; contents; amount} = accu in let stack = (accu, stack) in let destination : Destination.t = Contract ticketer in let addr = {destination; entrypoint = Entrypoint.default} in let accu = (addr, (contents, amount)) in (step [@ocaml.tailcall]) g gas k ks accu stack - | ISplit_ticket (_, k) -> - let ticket = accu and (amount_a, amount_b), stack = stack in + | ISplit_ticket (_, k), (accu : _ ticket), (stack : (_ * _) * _) -> + let ticket = accu in + let (amount_a, amount_b), stack = stack in let result = if Compare.Int.( @@ -1479,7 +1533,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IJoin_tickets (_, contents_ty, k) -> + | IJoin_tickets (_, contents_ty, k), (accu : _ ticket * _ ticket), _ -> let ticket_a, ticket_b = accu in let result = if @@ -1500,7 +1554,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IOpen_chest (_, k) -> + | IOpen_chest (_, k), (accu : Script_timelock.chest_key), (stack : Script_timelock.chest * (_ Script_int.num * _)) -> let open Timelock in let chest_key = accu in let chest, (time_z, stack) = stack in @@ -1551,35 +1605,35 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] log : | _, LogExit prev_kinfo -> log_exit logger ctxt gas prev_kinfo k accu stack) ; let k = log_next_kinstr logger k in let with_log k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match k with - | IList_map (_, body, k) -> - (ilist_map [@ocaml.tailcall]) with_log g gas body k ks accu stack - | IList_iter (_, body, k) -> + match[@coq_match_gadt] k, accu, stack with + | IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _) -> + (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b2"]) with_log g gas body k ks accu stack + | IList_iter (_, body, k), (accu : _ boxed_list), (stack : _ * _) -> (ilist_iter [@ocaml.tailcall]) with_log g gas body k ks accu stack - | ISet_iter (_, body, k) -> + | ISet_iter (_, body, k), (accu : _ set), (stack : _ * _) -> (iset_iter [@ocaml.tailcall]) with_log g gas body k ks accu stack - | IMap_map (_, body, k) -> - (imap_map [@ocaml.tailcall]) with_log g gas body k ks accu stack - | IMap_iter (_, body, k) -> + | IMap_map (_, body, k), (accu : _ map), (stack : _ * _) -> + (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c2"]) with_log g gas body k ks accu stack + | IMap_iter (_, body, k), (accu : _ map), (stack : _ * _) -> (imap_iter [@ocaml.tailcall]) with_log g gas body k ks accu stack - | ILoop (_, body, k) -> + | ILoop (_, body, k), _, _ -> let ks = with_log (KLoop_in (body, KCons (k, ks))) in (next [@ocaml.tailcall]) g gas ks accu stack - | ILoop_left (_, bl, br) -> + | ILoop_left (_, bl, br), _, _ -> let ks = with_log (KLoop_in_left (bl, KCons (br, ks))) in (next [@ocaml.tailcall]) g gas ks accu stack - | IMul_teznat (kinfo, k) -> + | IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _) -> (imul_teznat [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack - | IMul_nattez (kinfo, k) -> + | IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _) -> (imul_nattez [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack - | ILsl_nat (kinfo, k) -> + | ILsl_nat (kinfo, k), (accu : _ Script_int.num), (stack : _ Script_int.num * _) -> (ilsl_nat [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack - | ILsr_nat (kinfo, k) -> + | ILsr_nat (kinfo, k), (accu : _ Script_int.num), (stack : _ Script_int.num * _) -> (ilsr_nat [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack - | IFailwith (_, kloc, tv) -> + | IFailwith (_, kloc, tv), _, _ -> let {ifailwith} = ifailwith in (ifailwith [@ocaml.tailcall]) (Some logger) g gas kloc tv accu - | IExec (_, k) -> + | IExec (_, k), _, (stack : _ lambda * _) -> (iexec [@ocaml.tailcall]) (Some logger) g gas k ks accu stack | _ -> (step [@ocaml.tailcall]) g gas k (with_log ks) accu stack [@@inline] @@ -1598,49 +1652,49 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] klog : (match ks with KLog _ -> () | _ -> log_control logger ks) ; let enable_log ki = log_kinstr logger ki in let mk k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match ks with - | KCons (ki, ks') -> + match[@coq_match_gadt] ks, accu, stack with + | KCons (ki, ks'), _, _ -> let log = enable_log ki in let ks = mk ks' in (step [@ocaml.tailcall]) g gas log ks accu stack - | KNil -> (next [@ocaml.tailcall]) g gas ks accu stack - | KLoop_in (ki, ks') -> + | KNil, _, _ -> (next [@ocaml.tailcall]) g gas ks accu stack + | KLoop_in (ki, ks'), (accu : bool), (stack : _ * _) -> let ks' = mk ks' in let ki = enable_log ki in (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KReturn (stack', ks') -> + | KReturn (stack', ks'), _, _ -> let ks' = mk ks' in let ks = KReturn (stack', ks') in (next [@ocaml.tailcall]) g gas ks accu stack - | KMap_head (f, ks) -> (next [@ocaml.tailcall]) g gas ks (f accu) stack - | KLoop_in_left (ki, ks') -> + | KMap_head (f, ks), _, _ -> (next [@ocaml.tailcall]) g gas ks (f accu) stack + | KLoop_in_left (ki, ks'), (accu : _ union), _ -> let ks' = mk ks' in let ki = enable_log ki in (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KUndip (x, ks') -> + | KUndip (x, ks'), _, _ -> let ks' = mk ks' in let ks = KUndip (x, ks') in (next [@ocaml.tailcall]) g gas ks accu stack - | KIter (body, xs, ks') -> + | KIter (body, xs, ks'), _, _ -> let ks' = mk ks' in let body = enable_log body in (kiter [@ocaml.tailcall]) mk g gas body xs ks' accu stack - | KList_enter_body (body, xs, ys, len, ks') -> + | KList_enter_body (body, xs, ys, len, ks'), _, _ -> let ks' = mk ks' in (klist_enter [@ocaml.tailcall]) mk g gas body xs ys len ks' accu stack - | KList_exit_body (body, xs, ys, len, ks') -> + | KList_exit_body (body, xs, ys, len, ks'), _, (stack : _ * _) -> let ks' = mk ks' in (klist_exit [@ocaml.tailcall]) mk g gas body xs ys len ks' accu stack - | KMap_enter_body (body, xs, ys, ks') -> + | KMap_enter_body (body, xs, ys, ks'), _, _ -> let ks' = mk ks' in (kmap_enter [@ocaml.tailcall]) mk g gas body xs ys ks' accu stack - | KMap_exit_body (body, xs, ys, yk, ks') -> + | KMap_exit_body (body, xs, ys, yk, ks'), _, (stack : _ * _) -> let ks' = mk ks' in (kmap_exit [@ocaml.tailcall]) mk g gas body xs ys yk ks' accu stack - | KView_exit (orig_step_constants, ks') -> + | KView_exit (orig_step_constants, ks'), _, _ -> let g = (fst g, orig_step_constants) in (next [@ocaml.tailcall]) g gas ks' accu stack - | KLog (_, _) -> + | KLog (_, _), _, _ -> (* This case should never happen. *) (next [@ocaml.tailcall]) g gas ks accu stack [@@inline] -- GitLab From bfc2d97b1f09a529f0bde0ec87167a08adbe1439 Mon Sep 17 00:00:00 2001 From: emarzion Date: Fri, 15 Jul 2022 17:06:39 -0500 Subject: [PATCH 100/105] script_interpreter --- src/proto_alpha/lib_protocol/script_interpreter.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 7dddeea91790b..2bc874c6c6c53 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -441,7 +441,7 @@ and[@coq_mutual_as_notation] imul_teznat : | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = +and[@coq_mutual_as_notation] imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = fun logger g gas kinfo k ks accu stack -> let y = accu in let x, stack = stack in @@ -1091,7 +1091,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = ~allow_forged_in_storage:true ctxt script - >>=? fun ( Ex_script (Script {storage; storage_type; views; _}), + >>=? fun [@coq_match_gadt] ( Ex_script (Script {storage; storage_type; views; _}), ctxt ) -> Gas.consume ctxt (Interp_costs.view_get name views) >>?= fun ctxt -> @@ -1134,7 +1134,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (return_none [@ocaml.tailcall]) ctxt | Ok (Eq, Eq) -> ( let kkinfo = kinfo_of_kinstr k in - match kkinfo.kstack_ty with + match[@coq_match_with_default] kkinfo.kstack_ty with | Item_t (_, s) -> let kstack_ty = Item_t (output_ty, s) in let kkinfo = {kkinfo with kstack_ty} in -- GitLab From 60a4566d9c3175f0e616abcb929976ad75c464ec Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Sun, 17 Jul 2022 18:41:46 +0200 Subject: [PATCH 101/105] Proto: add changes to compile all the files in Coq --- src/proto_alpha/lib_protocol/apply.ml | 8 +- .../sc_rollup_management_protocol.ml | 67 +-- .../lib_protocol/sc_rollup_operations.ml | 2 +- .../lib_protocol/script_big_map.ml | 6 +- .../lib_protocol/script_interpreter.ml | 403 +++++++++++++----- .../lib_protocol/script_interpreter_defs.ml | 80 ++-- .../lib_protocol/script_typed_ir.ml | 7 +- .../lib_protocol/script_typed_ir.mli | 2 +- .../lib_protocol/tx_rollup_l2_apply.ml | 141 +++--- .../lib_protocol/tx_rollup_l2_apply.mli | 138 +++--- .../lib_protocol/tx_rollup_l2_batch.mli | 16 +- .../lib_protocol/tx_rollup_l2_verifier.ml | 15 +- .../lib_protocol/tx_rollup_ticket.ml | 8 +- 13 files changed, 539 insertions(+), 354 deletions(-) diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index b1be1de66e2d3..9f05a4c9b2c17 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -2340,7 +2340,7 @@ let apply_manager_contents (type kind) ctxt mode chain_id List.fold_left_es (fun (ctxt, storage_limit, res) imopr -> let (Internal_manager_operation_result (op, mopr)) = imopr in - match mopr with + match[@coq_match_gadt] mopr with | Applied smopr -> burn_internal_storage_fees ctxt @@ -2472,7 +2472,7 @@ let find_manager_public_key ctxt (op : _ Kind.manager contents_list) = let rec check_batch_tail_sanity : type kind. public_key_hash -> kind Kind.manager contents_list -> unit tzresult = - fun expected_source -> function + fun expected_source -> function[@coq_match_with_default] | Single (Manager_operation {operation = Reveal _key; _}) -> error Incorrect_reveal_position | Cons (Manager_operation {operation = Reveal _key; _}, _res) -> @@ -2492,7 +2492,7 @@ let find_manager_public_key ctxt (op : _ Kind.manager contents_list) = kind Kind.manager contents_list -> (public_key_hash * public_key option) tzresult = fun op -> - match op with + match[@coq_match_with_default] op with | Single (Manager_operation {source; operation = Reveal key; _}) -> ok (source, Some key) | Single (Manager_operation {source; _}) -> ok (source, None) @@ -2580,7 +2580,7 @@ let mark_backtracked results = Internal_manager_operation_result (kind, mark_internal_manager_operation_result result) in - match results with + match[@coq_match_with_default] results with | Manager_operation_result op -> Manager_operation_result { diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml index 98856c39a1eb4..10e047f642653 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -72,43 +72,46 @@ let transactions_batch_of_internal ctxt transactions = {Sc_rollup.Outbox.Message.unparsed_parameters; destination; entrypoint} = (* Lookup the contract-hash. *) (* Load the type and entrypoints of the script. *) - let* ( Script_ir_translator.Ex_script (Script {arg_type; entrypoints; _}), - ctxt ) = + let* res, ctxt = let* ctxt, _cache_key, cached = Script_cache.find ctxt destination in match cached with | Some (_script, ex_script) -> return (ex_script, ctxt) | None -> fail Sc_rollup_invalid_destination in - (* Find the entrypoint type for the given entrypoint. *) - let*? res, ctxt = - Gas_monad.run - ctxt - (Script_ir_translator.find_entrypoint - ~error_details:(Informative ()) - arg_type - entrypoints - entrypoint) - in - let*? (Ex_ty_cstr {ty = parameters_ty; _}) = res in - (* Parse the parameters according to the entrypoint type. *) - let* parameters, ctxt = - Script_ir_translator.parse_data - ctxt - ~legacy:false - ~allow_forged:true - parameters_ty - (Micheline.root unparsed_parameters) - in - return - ( Transaction - { - destination; - entrypoint; - parameters_ty; - parameters; - unparsed_parameters; - }, - ctxt ) + match[@coq_match_gadt] res with + | Script_ir_translator.Ex_script (Script {arg_type; entrypoints; _}) -> ( + (* Find the entrypoint type for the given entrypoint. *) + let*? res, ctxt = + Gas_monad.run + ctxt + ((Script_ir_translator.find_entrypoint [@coq_type_annotation]) + ~error_details:(Informative ()) + arg_type + entrypoints + entrypoint) + in + let*? res = res in + match[@coq_match_gadt] res with + | Script_ir_translator.Ex_ty_cstr {ty = parameters_ty; _} -> + (* Parse the parameters according to the entrypoint type. *) + let* parameters, ctxt = + (Script_ir_translator.parse_data [@coq_type_annotation]) + ctxt + ~legacy:false + ~allow_forged:true + parameters_ty + (Micheline.root unparsed_parameters) + in + return + ( Transaction + { + destination; + entrypoint; + parameters_ty; + parameters; + unparsed_parameters; + }, + ctxt )) in let+ ctxt, transactions = List.fold_left_map_es diff --git a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml index 74d469570a150..aecbeb23221c3 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_operations.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_operations.ml @@ -106,7 +106,7 @@ let rec validate_ty : | Chest_key_t -> error Sc_rollup_invalid_parameters_type | Lambda_t (_, _, _) -> error Sc_rollup_invalid_parameters_type -and validate_two_tys : +and[@coq_mutual_as_notation] validate_two_tys : type a ac b bc ret. (a, ac) Script_typed_ir.ty -> (b, bc) Script_typed_ir.ty -> diff --git a/src/proto_alpha/lib_protocol/script_big_map.ml b/src/proto_alpha/lib_protocol/script_big_map.ml index 7116f8fdec62c..cf4f290a8798e 100644 --- a/src/proto_alpha/lib_protocol/script_big_map.ml +++ b/src/proto_alpha/lib_protocol/script_big_map.ml @@ -48,7 +48,8 @@ let mem ctxt key (Big_map {id; diff; key_type; _}) = | Some (_, None), _ -> return (false, ctxt) | Some (_, Some _), _ -> return (true, ctxt) -let[@coq_axiom_with_reason "type issues"] get_by_hash ctxt key (Big_map {id; diff; value_type; _}) = +let[@coq_axiom_with_reason "type issues"] get_by_hash ctxt key + (Big_map {id; diff; value_type; _}) = match (Big_map_overlay.find key diff.map, id) with | Some (_, x), _ -> return (x, ctxt) | None, None -> return (None, ctxt) @@ -68,7 +69,8 @@ let get ctxt key (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> get_by_hash ctxt key_hash map -let[@coq_axiom_with_reason "type issues"] update_by_hash key_hash key value (Big_map map) = +let[@coq_axiom_with_reason "type issues"] update_by_hash key_hash key value + (Big_map map) = let contains = Big_map_overlay.mem key_hash map.diff.map in Big_map { diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 2bc874c6c6c53..a7896682576df 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -265,11 +265,11 @@ let[@coq_mutual_as_notation] rec kmap_exit : let ys = Script_map.update yk (Some accu) ys in let ks = mk (KMap_enter_body (body, xs, ys, ks)) in let accu, stack = stack in - ((next [@ocaml.tailcall]) g gas ks accu stack - [@coq_type_annotation]) + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] -and[@coq_mutual_as_notation] kmap_enter : type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = +and[@coq_mutual_as_notation] kmap_enter : + type a b c d i j k. (a, b, c, d, i, j, k) kmap_enter_type = fun mk g gas body xs ys ks accu stack -> match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks ys (accu, stack) @@ -280,12 +280,12 @@ and[@coq_mutual_as_notation] kmap_enter : type a b c d i j k. (a, b, c, d, i, j, (step [@ocaml.tailcall]) g gas body ks res stack [@@inline] -and[@coq_mutual_as_notation] klist_exit : type a b c d i j. (a, b, c, d, i, j) klist_exit_type = +and[@coq_mutual_as_notation] klist_exit : + type a b c d i j. (a, b, c, d, i, j) klist_exit_type = fun mk g gas body xs ys len ks accu stack -> let ks = mk (KList_enter_body (body, xs, accu :: ys, len, ks)) in let accu, stack = stack in - ((next [@ocaml.tailcall]) g gas ks accu stack - [@coq_type_annotation]) + ((next [@ocaml.tailcall]) g gas ks accu stack [@coq_type_annotation]) [@@inline] and[@coq_mutual_as_notation] klist_enter : @@ -317,7 +317,8 @@ and[@coq_mutual_as_notation] kloop_in : else (next [@ocaml.tailcall]) g gas ks' accu' stack' [@@inline] -and[@coq_mutual_as_notation] kiter : type a b s r f. (a, b, s, r, f) kiter_type = +and[@coq_mutual_as_notation] kiter : type a b s r f. (a, b, s, r, f) kiter_type + = fun mk g gas body xs ks accu stack -> match[@coq_type_annotation] xs with | [] -> (next [@ocaml.tailcall]) g gas ks accu stack @@ -339,15 +340,18 @@ and[@coq_struct "gas"] next : match consume_control gas ks0 with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match[@coq_match_gadt] ks0, accu, stack with + match[@coq_match_gadt] (ks0, accu, stack) with | KLog (ks, logger), _, _ -> (klog [@ocaml.tailcall]) logger g gas ks0 ks accu stack - | KNil, (accu : r), (stack : f) -> Lwt.return (Ok (accu, stack, ctxt, gas)) + | KNil, (accu : r), (stack : f) -> + Lwt.return (Ok (accu, stack, ctxt, gas)) | KCons (k, ks), _, _ -> (step [@ocaml.tailcall]) g gas k ks accu stack | KLoop_in (ki, ks'), (accu : bool), (stack : _ * _) -> (kloop_in [@ocaml.tailcall]) g gas ks0 ki ks' accu stack - | KReturn (stack', ks), _, _ -> (next [@ocaml.tailcall]) g gas ks accu stack' - | KMap_head (f, ks), _, _ -> (next [@ocaml.tailcall]) g gas ks (f accu) stack + | KReturn (stack', ks), _, _ -> + (next [@ocaml.tailcall]) g gas ks accu stack' + | KMap_head (f, ks), _, _ -> + (next [@ocaml.tailcall]) g gas ks (f accu) stack | KLoop_in_left (ki, ks'), (accu : _ union), _ -> (kloop_in_left [@ocaml.tailcall]) g gas ks0 ki ks' accu stack | KUndip (x, ks), _, _ -> (next [@ocaml.tailcall]) g gas ks x (accu, stack) @@ -359,7 +363,7 @@ and[@coq_struct "gas"] next : (klist_exit [@ocaml.tailcall]) id g gas body xs ys len ks accu stack | KMap_enter_body (body, xs, ys, ks), _, _ -> (kmap_enter [@ocaml.tailcall]) id g gas body xs ys ks accu stack - | KMap_exit_body (body, xs, ys, yk, ks), _, (stack : _ * _) -> + | KMap_exit_body (body, xs, ys, yk, ks), _, (stack : _ * _) -> (kmap_exit [@ocaml.tailcall]) id g gas body xs ys yk ks accu stack | KView_exit (orig_step_constants, ks), _, _ -> let g = (fst g, orig_step_constants) in @@ -441,7 +445,8 @@ and[@coq_mutual_as_notation] imul_teznat : | Some y -> Tez.(x *? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack -and[@coq_mutual_as_notation] imul_nattez : type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = +and[@coq_mutual_as_notation] imul_nattez : + type a b c d e f. (a, b, c, d, e, f) imul_nattez_type = fun logger g gas kinfo k ks accu stack -> let y = accu in let x, stack = stack in @@ -494,7 +499,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = match consume_instr gas i accu stack with | None -> fail Gas.Operation_quota_exceeded | Some gas -> ( - match[@coq_match_gadt] [@coq_match_with_default] i, accu, stack with + match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with | ILog (_, event, logger, k), _, _ -> (log [@ocaml.tailcall]) (logger, event) g gas k ks accu stack | IHalt _, _, _ -> (next [@ocaml.tailcall]) g gas ks accu stack @@ -502,17 +507,27 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = | IDrop (_, k), _, (stack : _ * _) -> let accu, stack = stack in (step [@ocaml.tailcall]) g gas k ks accu stack - | IDup (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) + | IDup (_, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks accu (accu, stack) | ISwap (_, k), _, (stack : _ * _) -> let top, stack = stack in (step [@ocaml.tailcall]) g gas k ks top (accu, stack) - | IConst (_, v, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks v (accu, stack) + | IConst (_, v, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks v (accu, stack) (* options *) | ICons_some (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks (Some accu) stack | ICons_none (_, k), _, _ -> - (step [@ocaml.tailcall]) g gas k ks (None [@coq_type_annotation]) (accu, stack) - | IIf_none {branch_if_none; branch_if_some; k; _}, (accu : _ option), (stack : _ * _) -> ( + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + (accu, stack) + | ( IIf_none {branch_if_none; branch_if_some; k; _}, + (accu : _ option), + (stack : _ * _) ) -> ( match accu with | None -> let accu, stack = stack in @@ -533,9 +548,18 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = stack) | IOpt_map {body; k; kinfo = _}, (accu : _ option), _ -> ( match accu with - | None -> (step [@ocaml.tailcall]) g gas k ks (None [@coq_type_annotation]) stack + | None -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack | Some v -> - let ks' = KMap_head ((Option.some [@coq_type_annotation]), KCons (k, ks)) in + let ks' = + KMap_head ((Option.some [@coq_type_annotation]), KCons (k, ks)) + in (step [@ocaml.tailcall]) g gas body ks' v stack) (* pairs *) | ICons_pair (_, k), _, (stack : _ * _) -> @@ -551,9 +575,24 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = let _, b = accu in (step [@ocaml.tailcall]) g gas k ks b stack (* unions *) - | ICons_left (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks (L accu [@coq_type_annotation]) stack - | ICons_right (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks (R accu [@coq_type_annotation]) stack - | IIf_left {branch_if_left; branch_if_right; k; _}, (accu : _ union), _ -> ( + | ICons_left (_, k), _, _ -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (L accu [@coq_type_annotation]) + stack + | ICons_right (_, k), _, _ -> + (step [@ocaml.tailcall]) + g + gas + k + ks + (R accu [@coq_type_annotation]) + stack + | IIf_left {branch_if_left; branch_if_right; k; _}, (accu : _ union), _ + -> ( match accu with | L v -> (step [@ocaml.tailcall]) @@ -579,8 +618,16 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = | INil (_, k), _, _ -> let stack = (accu, stack) in let accu = Script_list.empty in - (step [@ocaml.tailcall]) g gas k ks (accu [@coq_implicit "E" "__INil_'b"]) stack - | IIf_cons {branch_if_cons; branch_if_nil; k; _}, (accu : _ boxed_list), (stack : _ * _) -> ( + (step [@ocaml.tailcall]) + g + gas + k + ks + (accu [@coq_implicit "E" "__INil_'b"]) + stack + | ( IIf_cons {branch_if_cons; branch_if_nil; k; _}, + (accu : _ boxed_list), + (stack : _ * _) ) -> ( match accu.elements with | [] -> let accu, stack = stack in @@ -601,7 +648,15 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = hd (tl, stack)) | IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _) -> - (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b"]) id g gas body k ks accu stack + (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b"]) + id + g + gas + body + k + ks + accu + stack | IList_size (_, k), (accu : _ boxed_list), _ -> let list = accu in let len = Script_int.(abs (of_int list.length)) in @@ -632,7 +687,15 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = let stack = (accu, stack) in (step [@ocaml.tailcall]) g gas k ks res stack | IMap_map (_, body, k), (accu : _ map), (stack : _ * _) -> - (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c"]) id g gas body k ks accu stack + (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c"]) + id + g + gas + body + k + ks + accu + stack | IMap_iter (_, body, k), (accu : _ map), (stack : _ * _) -> (imap_iter [@ocaml.tailcall]) id g gas body k ks accu stack | IMap_mem (_, k), _, (stack : _ * _) -> @@ -659,9 +722,13 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (step [@ocaml.tailcall]) g gas k ks res stack (* Big map operations *) | IEmpty_big_map (_, tk, tv, k), _, _ -> - let ebm = (Script_big_map.empty - [@coq_implicit "a" "__IEmpty_big_map_'b"] - [@coq_implicit "b" "__IEmpty_big_map_'c"]) tk tv in + let ebm = + (Script_big_map.empty + [@coq_implicit "a" "__IEmpty_big_map_'b"] + [@coq_implicit "b" "__IEmpty_big_map_'c"]) + tk + tv + in (step [@ocaml.tailcall]) g gas k ks ebm (accu, stack) | IBig_map_mem (_, k), _, (stack : _ * _) -> let map, stack = stack in @@ -676,7 +743,13 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = ( use_gas_counter_in_context ctxt gas @@ fun ctxt -> Script_big_map.get ctxt key map ) >>=? fun (res, ctxt, gas) -> - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks (res [@coq_type_annotation]) stack + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (res [@coq_type_annotation]) + stack | IBig_map_update (_, k), _, (stack : _ * (_ * _)) -> let key = accu in let maybe_value, (map, stack) = stack in @@ -692,17 +765,23 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = >>=? fun ((v', map'), ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks v' (map', stack) (* timestamp operations *) - | IAdd_seconds_to_timestamp (_, k), (accu : _ Script_int.num), (stack : _ * _) -> + | ( IAdd_seconds_to_timestamp (_, k), + (accu : _ Script_int.num), + (stack : _ * _) ) -> let n = accu in let t, stack = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | IAdd_timestamp_to_seconds (_, k), (accu : Script_timestamp.t), (stack : _ * _) -> + | ( IAdd_timestamp_to_seconds (_, k), + (accu : Script_timestamp.t), + (stack : _ * _) ) -> let t = accu in let n, stack = stack in let result = Script_timestamp.add_delta t n in (step [@ocaml.tailcall]) g gas k ks result stack - | ISub_timestamp_seconds (_, k), (accu : Script_timestamp.t), (stack : _ * _) -> + | ( ISub_timestamp_seconds (_, k), + (accu : Script_timestamp.t), + (stack : _ * _) ) -> let t = accu in let s, stack = stack in let result = Script_timestamp.sub_delta t s in @@ -730,7 +809,9 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = consume gas (Interp_costs.concat_string total_length) >>?= fun gas -> let s = Script_string.concat ss.elements in (step [@ocaml.tailcall]) g gas k ks s stack - | ISlice_string (_, k), (accu : _ Script_int.num), (stack : _ * (Script_string.t * _)) -> + | ( ISlice_string (_, k), + (accu : _ Script_int.num), + (stack : _ * (Script_string.t * _)) ) -> let offset = accu in let length, (s, stack) = stack in let s_length = Z.of_int (Script_string.length s) in @@ -740,7 +821,14 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Script_string.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks (None [@coq_type_annotation]) stack + else + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack | IString_size (_, k), (accu : Script_string.t), _ -> let s = accu in let result = Script_int.(abs (of_int (Script_string.length s))) in @@ -773,7 +861,14 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = then let s = Bytes.sub s (Z.to_int offset) (Z.to_int length) in (step [@ocaml.tailcall]) g gas k ks (Some s) stack - else (step [@ocaml.tailcall]) g gas k ks (None [@coq_type_annotation]) stack + else + (step [@ocaml.tailcall]) + g + gas + k + ks + (None [@coq_type_annotation]) + stack | IBytes_size (_, k), (accu : bytes), _ -> let s = accu in let result = Script_int.(abs (of_int (Bytes.length s))) in @@ -794,8 +889,12 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = let y, stack = stack in Tez.(x -? y) >>?= fun res -> (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _) -> imul_teznat None g gas kinfo k ks accu stack - | IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _) -> imul_nattez None g gas kinfo k ks accu stack + | IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _) + -> + imul_teznat None g gas kinfo k ks accu stack + | IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _) + -> + imul_nattez None g gas kinfo k ks accu stack (* boolean operations *) | IOr (_, k), (accu : bool), (stack : _ * _) -> let x = accu in @@ -890,7 +989,9 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = | Some r -> Some (q, r))) in (step [@ocaml.tailcall]) g gas k ks result stack - | IEdiv_int (_, k), (accu : _ Script_int.num), (stack : _ Script_int.num * _) -> + | ( IEdiv_int (_, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> let x = accu in let y, stack = stack in let res = Script_int.ediv x y in @@ -900,8 +1001,14 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = let y, stack = stack in let res = Script_int.ediv_n x y in (step [@ocaml.tailcall]) g gas k ks res stack - | ILsl_nat (kinfo, k), (accu : _ Script_int.num), (stack : _ Script_int.num * _) -> ilsl_nat None g gas kinfo k ks accu stack - | ILsr_nat (kinfo, k), (accu : _ Script_int.num), (stack : _ Script_int.num * _) -> ilsr_nat None g gas kinfo k ks accu stack + | ( ILsl_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> + ilsl_nat None g gas kinfo k ks accu stack + | ( ILsr_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> + ilsr_nat None g gas kinfo k ks accu stack | IOr_nat (_, k), (accu : _ Script_int.num), (stack : _ * _) -> let x = accu in let y, stack = stack in @@ -927,7 +1034,9 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = let res = Script_int.lognot x in (step [@ocaml.tailcall]) g gas k ks res stack (* control *) - | IIf {branch_if_true; branch_if_false; k; _}, (accu : bool), (stack : _ * _) -> + | ( IIf {branch_if_true; branch_if_false; k; _}, + (accu : bool), + (stack : _ * _) ) -> let res, stack = stack in if accu then (step [@ocaml.tailcall]) @@ -956,7 +1065,8 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = let ks = KUndip (ign, KCons (k, ks)) in let accu, stack = stack in (step [@ocaml.tailcall]) g gas b ks accu stack - | IExec (_, k), _, (stack : _ lambda * _) -> iexec None g gas k ks accu stack + | IExec (_, k), _, (stack : _ lambda * _) -> + iexec None g gas k ks accu stack | IApply (_, capture_ty, k), _, (stack : _ lambda * _) -> let capture = accu in let lam, stack = stack in @@ -1019,7 +1129,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (unpack [@coq_type_annotation]) ctxt ~ty ~bytes ) >>=? fun (opt, ctxt, gas) -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks opt stack - | IAddress (_, k), (accu : _ Script_typed_ir.typed_contract), _ -> + | IAddress (_, k), (accu : _ Script_typed_ir.typed_contract), _ -> let (Typed_contract {address; _}) = accu in (step [@ocaml.tailcall]) g gas k ks address stack | IContract (kinfo, t, entrypoint, k), (accu : address), _ -> ( @@ -1042,7 +1152,14 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = let gas, ctxt = local_gas_counter_and_outdated_context ctxt in let accu = maybe_contract in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks accu stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks (None [@coq_type_annotation]) stack) + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) | ITransfer_tokens (kinfo, k), _, (stack : _ * (_ typed_contract * _)) -> let p = accu in let amount, (Typed_contract {arg_ty; address}, stack) = stack in @@ -1069,14 +1186,22 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = in let res = Typed_contract {arg_ty; address} in (step [@ocaml.tailcall]) g gas k ks res stack - | IView (_, View_signature {name; input_ty; output_ty}, k), _, (stack : address * _) -> ( + | ( IView (_, View_signature {name; input_ty; output_ty}, k), + _, + (stack : address * _) ) -> ( let input = accu in let addr, stack = stack in let c = addr.destination in let ctxt = update_context gas ctxt in let return_none ctxt = let gas, ctxt = local_gas_counter_and_outdated_context ctxt in - (step [@ocaml.tailcall]) (ctxt, sc) gas k ks (None [@coq_type_annotation]) stack + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack in match c with | Contract (Implicit _) | Tx_rollup _ | Sc_rollup _ -> @@ -1091,8 +1216,15 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = ~allow_forged_in_storage:true ctxt script - >>=? fun [@coq_match_gadt] ( Ex_script (Script {storage; storage_type; views; _}), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_script + (Script + { + storage; + storage_type; + views; + _; + }), + ctxt ) -> Gas.consume ctxt (Interp_costs.view_get name views) >>?= fun ctxt -> match Script_map.get name views with @@ -1164,7 +1296,9 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (KView_exit (sc, KReturn (stack, ks))) (input, storage) (EmptyCell, EmptyCell)))))) - | ICreate_contract {storage_type; code; k; kinfo = _}, (accu : public_key_hash option), (stack : _ * (_ * _)) -> + | ( ICreate_contract {storage_type; code; k; kinfo = _}, + (accu : public_key_hash option), + (stack : _ * (_ * _)) ) -> (* Removed the instruction's arguments manager, spendable and delegatable *) let delegate = accu in let credit, (init, stack) = stack in @@ -1182,7 +1316,13 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = Internal_operation {source = Contract.Originated sc.self; operation; nonce} in - let res = {piop; lazy_storage_diff = (None [@coq_type_annotation] : Lazy_storage.diffs option)} in + let res = + { + piop; + lazy_storage_diff = + (None [@coq_type_annotation] : Lazy_storage.diffs option); + } + in let gas, ctxt = local_gas_counter_and_outdated_context ctxt in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks res stack | IBalance (_, k), _, _ -> @@ -1192,7 +1332,8 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (step [@ocaml.tailcall]) g gas k ks sc.balance (accu, stack) | ILevel (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks sc.level (accu, stack) - | INow (_, k), _, _ -> (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) + | INow (_, k), _, _ -> + (step [@ocaml.tailcall]) g gas k ks sc.now (accu, stack) | IMin_block_time (_, k), _, _ -> let ctxt = update_context gas ctxt in let min_block_time = @@ -1266,9 +1407,17 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = accu stack in - (step [@ocaml.tailcall]) g gas k ks (accu [@coq_type_annotation]) (stack [@coq_type_annotation]) + (step [@ocaml.tailcall]) + g + gas + k + ks + (accu [@coq_type_annotation]) + (stack [@coq_type_annotation]) | IDipn (_, _n, n', b, k), _, _ -> - let accu, stack, restore_prefix = (kundip [@coq_type_annotation]) n' accu stack k in + let accu, stack, restore_prefix = + (kundip [@coq_type_annotation]) n' accu stack k + in let ks = KCons (restore_prefix, ks) in (step [@ocaml.tailcall]) g gas b ks accu stack | IDropn (_, _n, n', k), _, _ -> @@ -1280,7 +1429,7 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = s -> b * t = fun w accu stack -> - match[@coq_match_gadt] w, accu, stack with + match[@coq_match_gadt] (w, accu, stack) with | KRest, (accu : b), (stack : t) -> (accu, stack) | KPrefix (_, w), _, (stack : _ * _) -> let accu, stack = stack in @@ -1293,7 +1442,9 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = | ISapling_empty_state (_, memo_size, k), _, _ -> let state = Sapling.empty_state ~memo_size () in (step [@ocaml.tailcall]) g gas k ks state (accu, stack) - | ISapling_verify_update (_, k), (accu : Sapling.transaction), (stack : _ * _) -> ( + | ( ISapling_verify_update (_, k), + (accu : Sapling.transaction), + (stack : _ * _) ) -> ( let transaction = accu in let state, stack = stack in let address = Contract_hash.to_b58check sc.self in @@ -1312,8 +1463,17 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (Script_int.of_int64 balance, state) ) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks (None [@coq_type_annotation]) stack) - | ISapling_verify_update_deprecated (_, k), (accu : Sapling_repr.legacy_transaction), (stack : _ * _) -> ( + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) + | ( ISapling_verify_update_deprecated (_, k), + (accu : Sapling_repr.legacy_transaction), + (stack : _ * _) ) -> ( let transaction = accu in let state, stack = stack in let address = Contract_hash.to_b58check sc.self in @@ -1328,11 +1488,18 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = | Some (balance, state) -> let state = Some (Script_int.of_int64 balance, state) in (step [@ocaml.tailcall]) (ctxt, sc) gas k ks state stack - | None -> (step [@ocaml.tailcall]) (ctxt, sc) gas k ks (None [@coq_type_annotation]) stack) + | None -> + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + k + ks + (None [@coq_type_annotation]) + stack) | IChainId (_, k), _, _ -> let stack = (accu, stack) in let accu = Script_chain_id.make sc.chain_id in - (step [@ocaml.tailcall]) g gas k ks accu stack + (step [@ocaml.tailcall]) g gas k ks accu stack | INever _, _, _ -> . | IVoting_power (_, k), (accu : public_key_hash), _ -> let key_hash = accu in @@ -1356,43 +1523,59 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = let bytes = accu in let hash = Raw_hashes.sha3_256 bytes in (step [@ocaml.tailcall]) g gas k ks hash stack - | IAdd_bls12_381_g1 (_, k), (accu : Script_bls.G1.t), (stack : Script_bls.G1.t * _) -> + | ( IAdd_bls12_381_g1 (_, k), + (accu : Script_bls.G1.t), + (stack : Script_bls.G1.t * _) ) -> let x = accu in let y, stack = stack in let accu = Script_bls.G1.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_g2 (_, k), (accu : Script_bls.G2.t), (stack : Script_bls.G2.t * _) -> + | ( IAdd_bls12_381_g2 (_, k), + (accu : Script_bls.G2.t), + (stack : Script_bls.G2.t * _) ) -> let x = accu in let y, stack = stack in let accu = Script_bls.G2.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IAdd_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), (stack : Script_bls.Fr.t * _) -> + | ( IAdd_bls12_381_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : Script_bls.Fr.t * _) ) -> let x = accu in let y, stack = stack in let accu = Script_bls.Fr.add x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g1 (_, k), (accu : Script_bls.G1.t), (stack : Script_bls.Fr.t * _) -> + | ( IMul_bls12_381_g1 (_, k), + (accu : Script_bls.G1.t), + (stack : Script_bls.Fr.t * _) ) -> let x = accu in let y, stack = stack in let accu = Script_bls.G1.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_g2 (_, k), (accu : Script_bls.G2.t), (stack : Script_bls.Fr.t * _) -> + | ( IMul_bls12_381_g2 (_, k), + (accu : Script_bls.G2.t), + (stack : Script_bls.Fr.t * _) ) -> let x = accu in let y, stack = stack in let accu = Script_bls.G2.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr (_, k), (accu : Script_bls.Fr.t), (stack : Script_bls.Fr.t * _) -> + | ( IMul_bls12_381_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : Script_bls.Fr.t * _) ) -> let x = accu in let y, stack = stack in let accu = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks accu stack - | IMul_bls12_381_fr_z (_, k), (accu : _ Script_int.num), (stack : Script_bls.Fr.t * _) -> + | ( IMul_bls12_381_fr_z (_, k), + (accu : _ Script_int.num), + (stack : Script_bls.Fr.t * _) ) -> let x = accu in let y, stack = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in let res = Script_bls.Fr.mul x y in (step [@ocaml.tailcall]) g gas k ks res stack - | IMul_bls12_381_z_fr (_, k), (accu : Script_bls.Fr.t), (stack : _ Script_int.num * _) -> + | ( IMul_bls12_381_z_fr (_, k), + (accu : Script_bls.Fr.t), + (stack : _ Script_int.num * _) ) -> let y = accu in let x, stack = stack in let x = Script_bls.Fr.of_z (Script_int.to_zint x) in @@ -1424,10 +1607,10 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (before, after) comb_gadt_witness -> before -> after = fun witness stack -> match[@coq_match_gadt] (witness, stack) with - | (Comb_one, (stack : after)) -> stack - | (Comb_succ witness', (stack : _ * _)) -> - let (a, tl) = stack in - let (b, tl') = (aux [@coq_type_annotation]) witness' tl in + | Comb_one, (stack : after) -> stack + | Comb_succ witness', (stack : _ * _) -> + let a, tl = stack in + let b, tl' = (aux [@coq_type_annotation]) witness' tl in ((((a, b), tl') [@coq_cast]) : after) in let stack = (aux [@coq_type_annotation]) witness (accu, stack) in @@ -1439,9 +1622,9 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (before, after) uncomb_gadt_witness -> before -> after = fun witness stack -> match[@coq_match_gadt] (witness, stack) with - | (Uncomb_one, (stack : after)) -> stack - | (Uncomb_succ witness', (stack : (_ * _) * _)) -> - let ((a, b), tl) = stack in + | Uncomb_one, (stack : after) -> stack + | Uncomb_succ witness', (stack : (_ * _) * _) -> + let (a, b), tl = stack in (((a, (aux [@coq_type_annotation]) witness' (b, tl)) [@coq_cast]) : after) @@ -1456,12 +1639,12 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (before, after) comb_get_gadt_witness -> before -> after = fun witness comb -> match[@coq_match_gadt] (witness, comb) with - | (Comb_get_zero, (v : after)) -> v - | (Comb_get_one, (comb : after * _)) -> - let (a, _) = comb in + | Comb_get_zero, (v : after) -> v + | Comb_get_one, (comb : after * _) -> + let a, _ = comb in a - | (Comb_get_plus_two witness', (comb : _ * _)) -> - let (_, b) = comb in + | Comb_get_plus_two witness', (comb : _ * _) -> + let _, b = comb in aux witness' b in let accu = (aux [@coq_type_annotation]) witness comb in @@ -1477,17 +1660,17 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = after = fun witness value item -> match[@coq_match_gadt] (witness, value, item) with - | (Comb_set_zero, (value : after), _) -> value - | (Comb_set_one, _, (item : _ * _)) -> - let (_hd, tl) = item in + | Comb_set_zero, (value : after), _ -> value + | Comb_set_one, _, (item : _ * _) -> + let _hd, tl = item in (((value, tl) [@coq_cast]) : after) - | (Comb_set_plus_two witness', _, (item : _ * _)) -> - let (hd, tl) = item in + | Comb_set_plus_two witness', _, (item : _ * _) -> + let hd, tl = item in (((hd, (aux [@coq_type_annotation]) witness' value tl) [@coq_cast]) : after) in - let accu = (aux [@coq_type_annotation]) witness value comb in + let accu = (aux [@coq_type_annotation]) witness value comb in (step [@ocaml.tailcall]) g gas k ks accu stack | IDup_n (_, _, witness, k), _, _ -> let[@coq_struct "witness"] rec aux : @@ -1495,11 +1678,11 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = (before, after) dup_n_gadt_witness -> before -> after = fun witness stack -> match[@coq_match_gadt] (witness, stack) with - | (Dup_n_zero, (stack : after * _)) -> - let (a, _) = stack in + | Dup_n_zero, (stack : after * _) -> + let a, _ = stack in a - | (Dup_n_succ witness', (stack : _ * _)) -> - let (_, tl) = stack in + | Dup_n_succ witness', (stack : _ * _) -> + let _, tl = stack in aux witness' tl in let stack = (accu, stack) in @@ -1554,7 +1737,9 @@ and[@coq_struct "gas"] step : type a s b t r f. (a, s, b, t, r, f) step_type = else None in (step [@ocaml.tailcall]) g gas k ks result stack - | IOpen_chest (_, k), (accu : Script_timelock.chest_key), (stack : Script_timelock.chest * (_ Script_int.num * _)) -> + | ( IOpen_chest (_, k), + (accu : Script_timelock.chest_key), + (stack : Script_timelock.chest * (_ Script_int.num * _)) ) -> let open Timelock in let chest_key = accu in let chest, (time_z, stack) = stack in @@ -1605,15 +1790,31 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] log : | _, LogExit prev_kinfo -> log_exit logger ctxt gas prev_kinfo k accu stack) ; let k = log_next_kinstr logger k in let with_log k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match[@coq_match_gadt] k, accu, stack with + match[@coq_match_gadt] (k, accu, stack) with | IList_map (_, body, k), (accu : _ boxed_list), (stack : _ * _) -> - (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b2"]) with_log g gas body k ks accu stack + (ilist_map [@ocaml.tailcall] [@coq_implicit "f" "__IList_map_'b2"]) + with_log + g + gas + body + k + ks + accu + stack | IList_iter (_, body, k), (accu : _ boxed_list), (stack : _ * _) -> (ilist_iter [@ocaml.tailcall]) with_log g gas body k ks accu stack | ISet_iter (_, body, k), (accu : _ set), (stack : _ * _) -> (iset_iter [@ocaml.tailcall]) with_log g gas body k ks accu stack | IMap_map (_, body, k), (accu : _ map), (stack : _ * _) -> - (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c2"]) with_log g gas body k ks accu stack + (imap_map [@ocaml.tailcall] [@coq_implicit "g" "__IMap_map_'c2"]) + with_log + g + gas + body + k + ks + accu + stack | IMap_iter (_, body, k), (accu : _ map), (stack : _ * _) -> (imap_iter [@ocaml.tailcall]) with_log g gas body k ks accu stack | ILoop (_, body, k), _, _ -> @@ -1624,11 +1825,15 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] log : (next [@ocaml.tailcall]) g gas ks accu stack | IMul_teznat (kinfo, k), (accu : Tez.t), (stack : _ Script_int.num * _) -> (imul_teznat [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack - | IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _) -> + | IMul_nattez (kinfo, k), (accu : _ Script_int.num), (stack : Tez.t * _) -> (imul_nattez [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack - | ILsl_nat (kinfo, k), (accu : _ Script_int.num), (stack : _ Script_int.num * _) -> + | ( ILsl_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> (ilsl_nat [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack - | ILsr_nat (kinfo, k), (accu : _ Script_int.num), (stack : _ Script_int.num * _) -> + | ( ILsr_nat (kinfo, k), + (accu : _ Script_int.num), + (stack : _ Script_int.num * _) ) -> (ilsr_nat [@ocaml.tailcall]) (Some logger) g gas kinfo k ks accu stack | IFailwith (_, kloc, tv), _, _ -> let {ifailwith} = ifailwith in @@ -1652,7 +1857,7 @@ and[@coq_axiom_with_reason "we ignore the logging operations"] klog : (match ks with KLog _ -> () | _ -> log_control logger ks) ; let enable_log ki = log_kinstr logger ki in let mk k = match k with KLog _ -> k | _ -> KLog (k, logger) in - match[@coq_match_gadt] ks, accu, stack with + match[@coq_match_gadt] (ks, accu, stack) with | KCons (ki, ks'), _, _ -> let log = enable_log ki in let ks = mk ks' in diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index d1bd91a1eed4e..7d35b8efc1b49 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -480,42 +480,46 @@ let[@coq_struct "w_value"] rec kundip : let apply ctxt gas capture_ty capture lam = let (Lam (descr, expr)) = lam in match[@coq_match_with_default] descr.kbef with - | Item_t (full_arg_ty, _) -> - let ctxt = update_context gas ctxt in - unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> - let loc = Micheline.dummy_location in - unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> - match[@coq_match_with_default] full_arg_ty with - | Pair_t (capture_ty, arg_ty, _, _) -> - let arg_stack_ty = Item_t (arg_ty, Bot_t) in - let full_descr = - { - kloc = descr.kloc; - kbef = arg_stack_ty; - kaft = descr.kaft; - kinstr = - (let kinfo_const = {iloc = descr.kloc; kstack_ty = arg_stack_ty} in - let kinfo_pair = - { - iloc = descr.kloc; - kstack_ty = Item_t (capture_ty, arg_stack_ty); - } - in - IConst (kinfo_const, capture, ICons_pair (kinfo_pair, descr.kinstr))); - } - in - let full_expr = - Micheline.Seq - ( loc, - [ - Prim (loc, I_PUSH, [ty_expr; const_expr], []); - Prim (loc, I_PAIR, [], []); - expr; - ] ) - in - let lam' = Lam (full_descr, full_expr) in - let gas, ctxt = local_gas_counter_and_outdated_context ctxt in - return (lam', ctxt, gas) + | Item_t (full_arg_ty, _) -> ( + let ctxt = update_context gas ctxt in + unparse_data ctxt Optimized capture_ty capture + >>=? fun (const_expr, ctxt) -> + let loc = Micheline.dummy_location in + unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> + match[@coq_match_with_default] full_arg_ty with + | Pair_t (capture_ty, arg_ty, _, _) -> + let arg_stack_ty = Item_t (arg_ty, Bot_t) in + let full_descr = + { + kloc = descr.kloc; + kbef = arg_stack_ty; + kaft = descr.kaft; + kinstr = + (let kinfo_const = + {iloc = descr.kloc; kstack_ty = arg_stack_ty} + in + let kinfo_pair = + { + iloc = descr.kloc; + kstack_ty = Item_t (capture_ty, arg_stack_ty); + } + in + IConst + (kinfo_const, capture, ICons_pair (kinfo_pair, descr.kinstr))); + } + in + let full_expr = + Micheline.Seq + ( loc, + [ + Prim (loc, I_PUSH, [ty_expr; const_expr], []); + Prim (loc, I_PAIR, [], []); + expr; + ] ) + in + let lam' = Lam (full_descr, full_expr) in + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in + return (lam', ctxt, gas)) let make_transaction_to_contract ctxt ~destination ~amount ~entrypoint ~location ~parameters_ty ~parameters = @@ -714,10 +718,10 @@ let[@coq_struct "n_value"] rec interp_stack_prefix_preserving_operation : (d * w) * result = fun f n accu stk -> match[@coq_match_gadt_with_result] (n, accu, stk) with - | (KPrefix (_, n), _, (rest : _ * _)) -> + | KPrefix (_, n), _, (rest : _ * _) -> interp_stack_prefix_preserving_operation f n (fst rest) (snd rest) |> fun ((v, rest'), result) -> ((accu, (v, rest')), result) - | (KRest, (accu : a), (v : s)) -> f accu v + | KRest, (accu : a), (v : s) -> f accu v (* diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 949357db496f4..3647b228454d8 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -442,6 +442,7 @@ and 'arg nested_entrypoints = } -> ('l, 'r) union nested_entrypoints | Entrypoints_None : _ nested_entrypoints +[@@coq_force_gadt] let no_entrypoints = {at_node = None; nested = Entrypoints_None} @@ -1210,7 +1211,7 @@ and (_, _, _, _) continuation = | KLog : ('a, 's, 'r, 'f) continuation * logger -> ('a, 's, 'r, 'f) continuation - [@@coq_force_gadt] +[@@coq_force_gadt] and ('a, 's, 'b, 'f, 'c, 'u) logging_function = ('a, 's, 'b, 'f) kinstr -> @@ -1288,7 +1289,7 @@ and ('ty, 'comparable) ty = | Ticket_t : 'a comparable_ty * 'a ticket ty_metadata -> ('a ticket, no) ty | Chest_key_t : (Script_timelock.chest_key, no) ty | Chest_t : (Script_timelock.chest, no) ty - [@@coq_force_gadt] +[@@coq_force_gadt] and 'ty comparable_ty = ('ty, yes) ty @@ -1306,7 +1307,7 @@ and ('key, 'value) big_map = value_type : ('value, _) ty; } -> ('key, 'value) big_map - [@@coq_force_gadt] +[@@coq_force_gadt] and ('a, 's, 'r, 'f) kdescr = { kloc : Script.location; diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 8c2c38533f95e..ece8c036e0059 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1381,7 +1381,7 @@ and ('ty, 'comparable) ty = | Ticket_t : 'a comparable_ty * 'a ticket ty_metadata -> ('a ticket, no) ty | Chest_key_t : (Script_timelock.chest_key, no) ty | Chest_t : (Script_timelock.chest, no) ty - [@@coq_force_gadt] +[@@coq_force_gadt] and 'ty comparable_ty = ('ty, yes) ty diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml index 787ee04d7c7a0..5ff39b2de8c9e 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.ml @@ -317,73 +317,35 @@ type parameters = { tx_rollup_max_withdrawals_per_batch : int; } -module type S = sig - type ctxt +module type BATCH_V1 = sig + open Tx_rollup_l2_batch.V1 + + type ctxt_type type 'a m - (** The operations are versioned (see {!Tx_rollup_l2_batch}), - so their interpretations are. *) + val apply_batch : + ctxt_type -> + parameters -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m - module Batch_V1 : sig - open Tx_rollup_l2_batch.V1 + val check_signature : + ctxt_type -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * indexes * (Indexable.index_only, Indexable.unknown) t) m +end - (** [apply_batch ctxt parameters batch] interprets the batch - {!Tx_rollup_l2_batch.V1.t}. +module type S = sig + type ctxt_type - By construction, a failing transaction will not affect the [ctxt] - and other transactions will still be interpreted. - That is, this function can only fail because of internals errors. - Otherwise, the errors that caused the transactions to fail can be - observed in the result (see {!Message_result.Batch_V1.t}). + type 'a m - The counters are incremented when the operation is part of a transaction - that is correctly signed and whose every operations have the expected - counter. In particular, the result of the application is not important - (i.e. the counters are updated even if the transaction failed). + (** The operations are versioned (see {!Tx_rollup_l2_batch}), + so their interpretations are. *) - In addition, the list of withdrawals resulting from each - layer2-to-layer1 transfer message in the batch is returned. - *) - val apply_batch : - ctxt -> - parameters -> - (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m - - (** [check_signature ctxt batch] asserts that [batch] is correctly signed. - - We recall that [batch] may contain indexes, that is integers which - replace larger values. The [signer] field of the - {!Tx_rollup_l2_batch.operation} type is concerned. This field is either - the public key to be used to check the signature, or an index. - In case of the public key, [check_signature] will check whether or not - the related {!Tx_rollup_l2_address.t} has already an index assigned, - and allocate one if not. - - Overall, [check_signature] returns the revised context, the list of - newly allocated indexes, and an updated version of the batches where - all [signer] field have been replaced by valid indexes. - - {b Note:} What a user is expected to sign is the version of the - operation it sends to the network. This is potentially unsafe, - because it means the user signs indexes, not addresses nor - ticket hashes. This poses two threats: Tezos reorganization, - and malicious provider of indexes. A Tezos reorganization may - imply that an index allocated to one address in a given branch - is allocated to another address in another branch. We deal with - this issue by making the rollup node aware of the Tezos level at - each time an index is allocated. This allows to implement a RPC that - can safely tell a client to use either the full value or the index, - thanks to Tenderbake finality. To prevent the rollup node to lie, - we will make the rollup node provide Merkle proofs that allows the - client to verify that the index is correct. - *) - val check_signature : - ctxt -> - (Indexable.unknown, Indexable.unknown) t -> - (ctxt * indexes * (Indexable.index_only, Indexable.unknown) t) m - end + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2 address in [ctxt]. @@ -394,9 +356,9 @@ module type S = sig the funds to the deposit's sender is returned. *) val apply_deposit : - ctxt -> + ctxt_type -> Tx_rollup_message.deposit -> - (ctxt * Message_result.deposit_result * Tx_rollup_withdraw.t option) m + (ctxt_type * Message_result.deposit_result * Tx_rollup_withdraw.t option) m (** [apply_message ctxt parameters message] interprets the [message] in the [ctxt]. @@ -417,15 +379,19 @@ module type S = sig of the contents in the message. *) val apply_message : - ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m end -module Make (Context : CONTEXT) = struct +module Make (Context : CONTEXT) : + S with type ctxt_type = Context.t and type 'a m := 'a Context.m = struct open Context open Syntax open Message_result - type ctxt = Context.t + type ctxt_type = Context.t (** {3. Indexes. } *) @@ -475,7 +441,7 @@ module Make (Context : CONTEXT) = struct (** [get_metadata ctxt idx] returns the metadata associated to [idx] in [ctxt]. It must have an associated metadata in the context, otherwise, something went wrong in {!check_signature}. *) - let get_metadata : ctxt -> address_index -> metadata m = + let get_metadata : ctxt_type -> address_index -> metadata m = fun ctxt idx -> let open Address_metadata in let* metadata = get ctxt idx in @@ -485,7 +451,7 @@ module Make (Context : CONTEXT) = struct (** [get_metadata_signer] gets the metadata for a signer using {!get_metadata}. It transforms a signer index to an address one. *) - let get_metadata_signer : ctxt -> Signer_indexable.index -> metadata m = + let get_metadata_signer : ctxt_type -> Signer_indexable.index -> metadata m = fun ctxt signer_idx -> get_metadata ctxt (address_of_signer_index signer_idx) (** [transfers ctxt source_idx destination_idx tidx amount] transfers [amount] @@ -505,7 +471,8 @@ module Make (Context : CONTEXT) = struct we only handle the creation part (i.e. in the layer2) in this module. *) let deposit ctxt aidx tidx amount = Ticket_ledger.credit ctxt tidx aidx amount - module Batch_V1 = struct + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m = struct open Tx_rollup_l2_batch.V1 (** [operation_with_signer_index ctxt indexes op] takes an operation @@ -522,10 +489,10 @@ module Make (Context : CONTEXT) = struct {b Note:} If the context already contains all the required information, we only read from it. *) let operation_with_signer_index : - ctxt -> + ctxt_type -> indexes -> ('signer, 'content) operation -> - (ctxt + (ctxt_type * indexes * (Indexable.index_only, 'content) operation * Bls_signature.pk) @@ -645,9 +612,9 @@ module Make (Context : CONTEXT) = struct return (ctxt, indexes, transmitted, List.rev rev_ops) let check_signature : - ctxt -> + ctxt_type -> ('signer, 'content) t -> - (ctxt * indexes * (Indexable.index_only, 'content) t) m = + (ctxt_type * indexes * (Indexable.index_only, 'content) t) m = fun ctxt ({contents = transactions; aggregated_signature} as batch) -> let* ctxt, indexes, transmitted, rev_new_transactions = list_fold_left_m @@ -681,11 +648,11 @@ module Make (Context : CONTEXT) = struct {li The ticket exchanged index.}} *) let apply_operation_content : - ctxt -> + ctxt_type -> indexes -> Signer_indexable.index -> 'content operation_content -> - (ctxt * indexes * Tx_rollup_withdraw.t option) m = + (ctxt_type * indexes * Tx_rollup_withdraw.t option) m = fun ctxt indexes source_idx op_content -> match op_content with | Withdraw {destination = claimer; ticket_hash; qty = amount} -> @@ -717,7 +684,8 @@ module Make (Context : CONTEXT) = struct (** [check_counter ctxt signer counter] asserts that the provided [counter] is the successor of the one associated to the [signer] in the [ctxt]. *) let check_counter : - ctxt -> Indexable.index_only Signer_indexable.t -> int64 -> unit m = + ctxt_type -> Indexable.index_only Signer_indexable.t -> int64 -> unit m + = fun ctxt signer counter -> let* metadata = get_metadata_signer ctxt signer in fail_unless @@ -732,10 +700,10 @@ module Make (Context : CONTEXT) = struct (** [apply_operation ctxt indexes op] checks the counter validity for the [op.signer] with {!check_counter}, and then calls {!apply_operation_content} for each content in [op]. *) let apply_operation : - ctxt -> + ctxt_type -> indexes -> (Indexable.index_only, Indexable.unknown) operation -> - (ctxt * indexes * Tx_rollup_withdraw.t list) m = + (ctxt_type * indexes * Tx_rollup_withdraw.t list) m = fun ctxt indexes {signer; counter; contents} -> (* Before applying any operation, we check the counter *) let* () = check_counter ctxt signer counter in @@ -758,12 +726,14 @@ module Make (Context : CONTEXT) = struct is left untouched. *) let apply_transaction : - ctxt -> + ctxt_type -> indexes -> (Indexable.index_only, Indexable.unknown) transaction -> - (ctxt * indexes * transaction_result * Tx_rollup_withdraw.t list) m = + (ctxt_type * indexes * transaction_result * Tx_rollup_withdraw.t list) m + = fun initial_ctxt initial_indexes transaction -> - let rec fold (ctxt, prev_indexes, withdrawals) index ops = + let rec fold params index ops = + let ctxt, prev_indexes, withdrawals = params in match ops with | [] -> return (ctxt, prev_indexes, Transaction_success, withdrawals) | op :: rst -> @@ -804,10 +774,10 @@ module Make (Context : CONTEXT) = struct transaction let apply_batch : - ctxt -> + ctxt_type -> parameters -> (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m = + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m = fun ctxt parameters batch -> let* ctxt, indexes, batch = check_signature ctxt batch in let {contents; _} = batch in @@ -840,9 +810,9 @@ module Make (Context : CONTEXT) = struct end let apply_deposit : - ctxt -> + ctxt_type -> Tx_rollup_message.deposit -> - (ctxt * deposit_result * Tx_rollup_withdraw.t option) m = + (ctxt_type * deposit_result * Tx_rollup_withdraw.t option) m = fun initial_ctxt Tx_rollup_message.{sender; destination; ticket_hash; amount} -> let apply_deposit () = let* ctxt, indexes, aidx = @@ -867,7 +837,10 @@ module Make (Context : CONTEXT) = struct return (initial_ctxt, Deposit_failure reason, Some withdrawal)) let apply_message : - ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m = + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m = fun ctxt parameters msg -> let open Tx_rollup_message in match msg with diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli index 4aaa7ad4c10e1..33e8af74ad1f3 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_apply.mli @@ -122,73 +122,80 @@ type parameters = { tx_rollup_max_withdrawals_per_batch : int; } +module type BATCH_V1 = sig + open Tx_rollup_l2_batch.V1 + + type ctxt_type + + type 'a m + + (** [apply_batch ctxt parameters batch] interprets the batch + {!Tx_rollup_l2_batch.V1.t}. + + By construction, a failing transaction will not affect the [ctxt] + and other transactions will still be interpreted. + That is, this function can only fail because of internals errors. + Otherwise, the errors that caused the transactions to fail can be + observed in the result (see {!Message_result.Batch_V1.t}). + + The counters are incremented when the operation is part of a transaction + that is correctly signed and whose every operations have the expected + counter. In particular, the result of the application is not important + (i.e. the counters are updated even if the transaction failed). + + In addition, the list of withdrawals resulting from each + layer2-to-layer1 transfer message in the batch is returned. + *) + val apply_batch : + ctxt_type -> + parameters -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m + + (** [check_signature ctxt batch] asserts that [batch] is correctly signed. + + We recall that [batch] may contain indexes, that is integers which + replace larger values. The [signer] field of the + {!Tx_rollup_l2_batch.operation} type is concerned. This field is either + the public key to be used to check the signature, or an index. + In case of the public key, [check_signature] will check whether or not + the related {!Tx_rollup_l2_address.t} has already an index assigned, + and allocate one if not. + + Overall, [check_signature] returns the revised context, the list of + newly allocated indexes, and an updated version of the batches where + all [signer] field have been replaced by valid indexes. + + {b Note:} What a user is expected to sign is the version of the + operation it sends to the network. This is potentially unsafe, + because it means the user signs indexes, not addresses nor + ticket hashes. This poses two threats: Tezos reorganization, + and malicious provider of indexes. A Tezos reorganization may + imply that an index allocated to one address in a given branch + is allocated to another address in another branch. We deal with + this issue by making the rollup node aware of the Tezos level at + each time an index is allocated. This allows to implement a RPC that + can safely tell a client to use either the full value or the index, + thanks to Tenderbake finality. To prevent the rollup node to lie, + we will make the rollup node provide Merkle proofs that allows the + client to verify that the index is correct. + *) + val check_signature : + ctxt_type -> + (Indexable.unknown, Indexable.unknown) t -> + (ctxt_type * indexes * (Indexable.index_only, Indexable.unknown) t) m +end + module type S = sig - type ctxt + type ctxt_type type 'a m (** The operations are versioned (see {!Tx_rollup_l2_batch}), so their interpretations are. *) - module Batch_V1 : sig - open Tx_rollup_l2_batch.V1 - - (** [apply_batch ctxt parameters batch] interprets the batch - {!Tx_rollup_l2_batch.V1.t}. - - By construction, a failing transaction will not affect the [ctxt] - and other transactions will still be interpreted. - That is, this function can only fail because of internals errors. - Otherwise, the errors that caused the transactions to fail can be - observed in the result (see {!Message_result.Batch_V1.t}). - - The counters are incremented when the operation is part of a transaction - that is correctly signed and whose every operations have the expected - counter. In particular, the result of the application is not important - (i.e. the counters are updated even if the transaction failed). - - In addition, the list of withdrawals resulting from each - layer2-to-layer1 transfer message in the batch is returned. - *) - val apply_batch : - ctxt -> - parameters -> - (Indexable.unknown, Indexable.unknown) t -> - (ctxt * Message_result.Batch_V1.t * Tx_rollup_withdraw.t list) m - - (** [check_signature ctxt batch] asserts that [batch] is correctly signed. - - We recall that [batch] may contain indexes, that is integers which - replace larger values. The [signer] field of the - {!Tx_rollup_l2_batch.operation} type is concerned. This field is either - the public key to be used to check the signature, or an index. - In case of the public key, [check_signature] will check whether or not - the related {!Tx_rollup_l2_address.t} has already an index assigned, - and allocate one if not. - - Overall, [check_signature] returns the revised context, the list of - newly allocated indexes, and an updated version of the batches where - all [signer] field have been replaced by valid indexes. - - {b Note:} What a user is expected to sign is the version of the - operation it sends to the network. This is potentially unsafe, - because it means the user signs indexes, not addresses nor - ticket hashes. This poses two threats: Tezos reorganization, - and malicious provider of indexes. A Tezos reorganization may - imply that an index allocated to one address in a given branch - is allocated to another address in another branch. We deal with - this issue by making the rollup node aware of the Tezos level at - each time an index is allocated. This allows to implement a RPC that - can safely tell a client to use either the full value or the index, - thanks to Tenderbake finality. To prevent the rollup node to lie, - we will make the rollup node provide Merkle proofs that allows the - client to verify that the index is correct. - *) - val check_signature : - ctxt -> - (Indexable.unknown, Indexable.unknown) t -> - (ctxt * indexes * (Indexable.index_only, Indexable.unknown) t) m - end + module Batch_V1 : + BATCH_V1 with type ctxt_type := ctxt_type and type 'a m := 'a m (** [apply_deposit ctxt deposit] credits a quantity of tickets to a layer2 address in [ctxt]. @@ -199,9 +206,9 @@ module type S = sig the funds to the deposit's sender is returned. *) val apply_deposit : - ctxt -> + ctxt_type -> Tx_rollup_message.deposit -> - (ctxt * Message_result.deposit_result * Tx_rollup_withdraw.t option) m + (ctxt_type * Message_result.deposit_result * Tx_rollup_withdraw.t option) m (** [apply_message ctxt parameters message] interprets the [message] in the [ctxt]. @@ -222,8 +229,11 @@ module type S = sig of the contents in the message. *) val apply_message : - ctxt -> parameters -> Tx_rollup_message.t -> (ctxt * Message_result.t) m + ctxt_type -> + parameters -> + Tx_rollup_message.t -> + (ctxt_type * Message_result.t) m end module Make (Context : CONTEXT) : - S with type ctxt = Context.t and type 'a m := 'a Context.m + S with type ctxt_type = Context.t and type 'a m := 'a Context.m diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli index e59261c998aad..ef323fe52c745 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_batch.mli @@ -77,21 +77,7 @@ type signer = (** A signer identified by a layer-2 address. Each such adress is in turn identified with a BLS public key. *) -module Signer_indexable : sig - type nonrec 'state t = ('state, signer) Indexable.t - - type nonrec index = signer Indexable.index - - type nonrec value = signer Indexable.value - - type either = signer Indexable.either - - val encoding : either Data_encoding.t - - val compare : either -> either -> int - - val pp : Format.formatter -> either -> unit -end +module Signer_indexable : Indexable.INDEXABLE with type v_t := signer (** {1 Layer-2 Batches Definitions} *) diff --git a/src/proto_alpha/lib_protocol/tx_rollup_l2_verifier.ml b/src/proto_alpha/lib_protocol/tx_rollup_l2_verifier.ml index 18aba02d2b14e..11cd53048590d 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_l2_verifier.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_l2_verifier.ml @@ -75,17 +75,18 @@ module Verifier_storage : type 'a m = ('a, error) result Lwt.t module Syntax = struct - let ( let* ) = ( >>=? ) + let ( let* ) : 'a m -> ('a -> 'b m) -> 'b m = ( >>=? ) - let ( let+ ) = ( >|=? ) + let ( let+ ) : 'a m -> ('a -> 'b) -> 'b m = ( >|=? ) - let return = return + let return : 'a -> 'a m = return - let fail e = Lwt.return (Error e) + let fail (e : error) : 'a m = Lwt.return (Error e) let catch (m : 'a m) k h = m >>= function Ok x -> k x | Error e -> h e - let list_fold_left_m = List.fold_left_es + let list_fold_left_m : ('a -> 'b -> 'a m) -> 'a -> 'b list -> 'a m = + List.fold_left_es end let path k = [Bytes.to_string k] @@ -124,8 +125,8 @@ let verify_l2_proof proof parameters message = Note that if the proof is incorrect this function fails and the commit can not be rejected. *) -let compute_proof_after_hash ~max_proof_size ctxt parameters agreed proof - message = +let[@coq_axiom_with_reason "nested pattern with polymorphic variant"] compute_proof_after_hash + ~max_proof_size ctxt parameters agreed proof message = let proof_length = Data_encoding.Binary.length Tx_rollup_l2_proof.encoding proof in diff --git a/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml b/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml index bc944c895596b..ddece37a0b1ad 100644 --- a/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml +++ b/src/proto_alpha/lib_protocol/tx_rollup_ticket.ml @@ -31,8 +31,8 @@ let parse_ticket ~consume_deserialization_gas ~ticketer ~contents ~ty ctxt = Script.force_decode_in_context ~consume_deserialization_gas ctxt contents >>?= fun (contents, ctxt) -> Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) - >>?= fun (Ex_comparable_ty contents_type, ctxt) -> - (Script_ir_translator.parse_comparable_data [@coq_implicit "a" "a"]) + >>?= fun [@coq_match_gadt] (Ex_comparable_ty contents_type, ctxt) -> + (Script_ir_translator.parse_comparable_data [@coq_type_annotation]) ctxt contents_type (Micheline.root contents) @@ -46,8 +46,8 @@ let parse_ticket_and_operation ~consume_deserialization_gas ~ticketer ~contents Script.force_decode_in_context ~consume_deserialization_gas ctxt contents >>?= fun (contents, ctxt) -> Script_ir_translator.parse_comparable_ty ctxt (Micheline.root ty) - >>?= fun (Ex_comparable_ty contents_type, ctxt) -> - (Script_ir_translator.parse_comparable_data [@coq_implicit "a" "a"]) + >>?= fun [@coq_match_gadt] (Ex_comparable_ty contents_type, ctxt) -> + (Script_ir_translator.parse_comparable_data [@coq_type_annotation]) ctxt contents_type (Micheline.root contents) -- GitLab From 87dde20bd5e9cf32ea0296b00b8759a44227efe2 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Mon, 18 Jul 2022 18:48:43 +0200 Subject: [PATCH 102/105] Proto: more changes to help the translation of script_ir_translator.ml to Coq --- .../lib_protocol/script_ir_translator.ml | 972 ++++++++++-------- 1 file changed, 526 insertions(+), 446 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index fce2d31ed2514..cadbb6c2e33b7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -302,7 +302,7 @@ let serialize_ty_for_error ty = *) unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations -let[@coq_axiom_with_reason "gadt"] check_comparable : +let check_comparable : type a ac. Script.location -> (a, ac) ty -> (ac, Dependent_bool.yes) eq tzresult = fun loc ty -> @@ -532,7 +532,7 @@ let comb_witness2 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : +let[@coq_struct "ty"] rec unparse_comparable_data : type a loc. loc:loc -> context -> @@ -550,33 +550,37 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_comparable_data : [unparse_data] for now. *) >>?= fun ctxt -> - match (ty, a) with - | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v - | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v - | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v - | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s - | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s - | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b - | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address - | Tx_rollup_l2_address_t, address -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + | Unit_t, (v : unit) -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, (s : Script_string.t) -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, (s : bytes) -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, (b : bool) -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, (t : Script_timestamp.t) -> + Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, (address : address) -> + Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, (address : tx_rollup_l2_address) -> Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v - | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k - | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | Chain_id_t, chain_id -> + | Signature_t, (s : Script_signature.t) -> + Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, (v : Tez_repr.t) -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, (k : public_key) -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, (k : public_key_hash) -> + Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Chain_id_t, (chain_id : Script_chain_id.t) -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | Pair_t (tl, tr, _, YesYes), pair -> + | Pair_t (tl, tr, _, YesYes), (pair : _ * _) -> let r_witness = comb_witness2 tr in let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | Union_t (tl, tr, _, YesYes), v -> + | Union_t (tl, tr, _, YesYes), (v : _ union) -> let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v - | Option_t (t, _, Yes), v -> + | Option_t (t, _, Yes), (v : _ option) -> let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in unparse_option ~loc unparse_v ctxt v | Never_t, _ -> . @@ -607,10 +611,11 @@ let hash_comparable_data ctxt ty data = (* ---- Tickets ------------------------------------------------------------ *) (* - All comparable types are dupable, this function exists only to not forget - checking this property when adding new types. -*) -let check_dupable_comparable_ty : type a. a comparable_ty -> unit = function[@coq_match_with_default] + All comparable types are dupable, this function exists only to not forget + checking this property when adding new types. + *) +let check_dupable_comparable_ty : type a. a comparable_ty -> unit = + function[@coq_match_with_default] | Unit_t | Never_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t | Bool_t | Key_hash_t | Key_t | Timestamp_t | Chain_id_t | Address_t | Tx_rollup_l2_address_t | Pair_t _ | Union_t _ | Option_t _ -> @@ -656,13 +661,13 @@ let check_dupable_ty ctxt loc ty = aux loc ty_b | Lambda_t (_, _, _) -> (* - Lambda are dupable as long as: - - they don't contain non-dupable values, e.g. in `PUSH` - (mostly non-dupable values should probably be considered forged) - - they are not the result of a partial application on a non-dupable - value. `APPLY` rejects non-packable types (because of `PUSH`). - Hence non-dupable should imply non-packable. - *) + Lambda are dupable as long as: + - they don't contain non-dupable values, e.g. in `PUSH` + (mostly non-dupable values should probably be considered forged) + - they are not the result of a partial application on a non-dupable + value. `APPLY` rejects non-packable types (because of `PUSH`). + Hence non-dupable should imply non-packable. + *) return_unit | Option_t (ty, _, _) -> aux loc ty | List_t (ty, _) -> aux loc ty @@ -733,27 +738,18 @@ let rec ty_eq : (ta, tac) ty -> (tb, tbc) ty -> (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = - fun ty1 ty2 -> - help0 ty1 ty2 - |> Gas_monad.record_trace_eval ~error_details (fun loc -> - default_ty_eq_error loc ty1 ty2) - and help0 : - type ta tac tb tbc. - (ta, tac) ty -> - (tb, tbc) ty -> - (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = fun ty1 ty2 -> let open Gas_monad.Syntax in let* () = Gas_monad.consume_gas Typecheck_costs.merge_cycle in let not_equal () = Gas_monad.of_result @@ Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : error_trace) | Informative loc -> trace_of_error @@ default_ty_eq_error loc ty1 ty2) in - match (ty1, ty2) with + (match (ty1, ty2) with | Unit_t, Unit_t -> return (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) | Unit_t, _ -> not_equal () | Int_t, Int_t -> return Eq @@ -865,10 +861,13 @@ let rec ty_eq : | Chest_t, Chest_t -> return Eq | Chest_t, _ -> not_equal () | Chest_key_t, Chest_key_t -> return Eq - | Chest_key_t, _ -> not_equal () + | Chest_key_t, _ -> not_equal ()) + |> Gas_monad.record_trace_eval ~error_details (fun loc -> + default_ty_eq_error loc ty1 ty2) in help ty1 ty2 - [@@coq_axiom_with_reason "non-top-level mutual recursion"] + |> Gas_monad.record_trace_eval ~error_details (fun loc -> + default_ty_eq_error loc ty1 ty2) (* Same as ty_eq but for stacks. A single error monad is used here because there is no need to @@ -901,7 +900,7 @@ type ('a, 's) judgement = descr : 'b 'u. ('b, 'u) stack_ty -> ('a, 's, 'b, 'u) descr; } -> ('a, 's) judgement - [@@coq_force_gadt] +[@@coq_force_gadt] (* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*) @@ -954,8 +953,7 @@ let parse_memo_size (n : (location, _) Micheline.node) : type ex_comparable_ty = | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty -type ex_ty = Ex_ty : ('a, _) ty -> ex_ty -[@@coq_force_gadt] +type ex_ty = Ex_ty : ('a, _) ty -> ex_ty [@@coq_force_gadt] type ex_parameter_ty_and_entrypoints_node = | Ex_parameter_ty_and_entrypoints_node : { @@ -965,20 +963,20 @@ type ex_parameter_ty_and_entrypoints_node = -> ex_parameter_ty_and_entrypoints_node (** [parse_ty] can be used to parse regular types as well as parameter types - together with their entrypoints. + together with their entrypoints. - In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty] will - return an [ex_ty]. + In the first case, use [~ret:Don't_parse_entrypoints], [parse_ty] will + return an [ex_ty]. - In the second case, use [~ret:Parse_entrypoints], [parse_ty] will return - an [ex_parameter_ty_and_entrypoints_node]. -*) + In the second case, use [~ret:Parse_entrypoints], [parse_ty] will return + an [ex_parameter_ty_and_entrypoints_node]. + *) type ('ret, 'name) parse_ty_ret = | Don't_parse_entrypoints : (ex_ty, unit) parse_ty_ret | Parse_entrypoints : (ex_parameter_ty_and_entrypoints_node, Entrypoint.t option) parse_ty_ret -let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty_aux : +let[@coq_struct "node_value"] rec parse_ty_aux : type ret name. context -> stack_depth:int -> @@ -1004,13 +1002,13 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty error Typechecking_too_many_recursive_calls else (match ret with - | Don't_parse_entrypoints -> ok (node, (() : name)) + | Don't_parse_entrypoints -> ok (node, None) | Parse_entrypoints -> extract_entrypoint_annot node) >>? fun (node, name) -> let return ctxt ty : ret * context = - match ret with - | Don't_parse_entrypoints -> (Ex_ty ty, ctxt) - | Parse_entrypoints -> + match[@coq_match_gadt_with_result] (ret, name) with + | Don't_parse_entrypoints, _ -> (Ex_ty ty, ctxt) + | Parse_entrypoints, (name : Alpha_context.Entrypoint.t option) -> let at_node = Option.map (fun name -> {name; original_type_expr = node}) name in @@ -1083,7 +1081,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty else error (Unexpected_contract loc) | Prim (loc, T_pair, utl :: utr, annot) -> remove_field_annot utl >>? fun utl -> - parse_ty_aux + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1100,7 +1098,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (* Unfold [pair t1 ... tn] as [pair t1 (... (pair tn-1 tn))] *) ok (Prim (loc, T_pair, utr, []))) >>? fun utr -> - parse_ty_aux + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1120,7 +1118,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty remove_field_annot utr >|? fun utr -> (utl, utr) | Parse_entrypoints -> ok (utl, utr)) >>? fun (utl, utr) -> - parse_ty_aux + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1131,7 +1129,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty ~ret utl >>? fun (parsed_l, ctxt) -> - parse_ty_aux + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1143,12 +1141,15 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty utr >>? fun (parsed_r, ctxt) -> check_type_annot loc annot >>? fun () -> - match ret with - | Don't_parse_entrypoints -> + match[@coq_match_gadt_with_result] (ret, parsed_l, parsed_r, name) with + | Don't_parse_entrypoints, _, _, _ -> let (Ex_ty tl) = parsed_l in let (Ex_ty tr) = parsed_r in union_t loc tl tr >|? fun (Ty_ex_c ty) -> ((Ex_ty ty : ret), ctxt) - | Parse_entrypoints -> + | ( Parse_entrypoints, + (parsed_l : ex_parameter_ty_and_entrypoints_node), + (parsed_r : ex_parameter_ty_and_entrypoints_node), + (name : Alpha_context.Entrypoint.t option) ) -> let (Ex_parameter_ty_and_entrypoints_node {arg_type = tl; entrypoints = left}) = parsed_l @@ -1167,9 +1168,9 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty (Ex_parameter_ty_and_entrypoints_node {arg_type; entrypoints}, ctxt) ) | Prim (loc, T_lambda, [uta; utr], annot) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy uta + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy uta >>? fun (Ex_ty ta, ctxt) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy utr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy utr >>? fun (Ex_ty tr, ctxt) -> check_type_annot loc annot >>? fun () -> lambda_t loc ta tr >|? fun ty -> return ctxt ty @@ -1180,7 +1181,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty check_composed_type_annot loc annot >>? fun () -> ok ut else check_type_annot loc annot >>? fun () -> ok ut) >>? fun ut -> - parse_ty_aux + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1193,7 +1194,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty >>? fun (Ex_ty t, ctxt) -> option_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_list, [ut], annot) -> - parse_ty_aux + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1214,14 +1215,14 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty ticket_t loc t >|? fun ty -> return ctxt ty else error (Unexpected_ticket loc) | Prim (loc, T_set, [ut], annot) -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt ut >>? fun (Ex_comparable_ty t, ctxt) -> check_type_annot loc annot >>? fun () -> set_t loc t >|? fun ty -> return ctxt ty | Prim (loc, T_map, [uta; utr], annot) -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt uta + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt uta >>? fun (Ex_comparable_ty ta, ctxt) -> - parse_ty_aux + parse_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1245,11 +1246,11 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty return ctxt (sapling_transaction_deprecated_t ~memo_size) else error (Deprecated_instruction T_sapling_transaction_deprecated) (* - /!\ When adding new lazy storage kinds, be careful to use - [when allow_lazy_storage] /!\ - Lazy storage should not be packable to avoid stealing a lazy storage - from another contract with `PUSH t id` or `UNPACK`. - *) + /!\ When adding new lazy storage kinds, be careful to use + [when allow_lazy_storage] /!\ + Lazy storage should not be packable to avoid stealing a lazy storage + from another contract with `PUSH t id` or `UNPACK`. + *) | Prim (loc, T_big_map, args, annot) when allow_lazy_storage -> parse_big_map_ty ctxt @@ -1318,8 +1319,7 @@ let[@coq_axiom_with_reason "complex mutually recursive definition"] rec parse_ty T_unit; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_comparable_ty_aux - : +and[@coq_struct "stack_depth"] parse_comparable_ty_aux : context -> stack_depth:int -> Script.node -> @@ -1342,7 +1342,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_compar error (Comparable_type_expected (location node, Micheline.strip_locations node)) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passable_ty_aux_with_ret : +and[@coq_mutual_as_notation] parse_passable_ty_aux_with_ret : type ret name. context -> stack_depth:int -> @@ -1351,41 +1351,40 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_passab Script.node -> (ret * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty_aux [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:false - ~allow_contract:true - ~allow_ticket:true + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:false + ~allow_contract:true + ~allow_ticket:true [@coq_type_annotation]) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_any_ty_aux - : +and[@coq_mutual_as_notation] parse_any_ty_aux : context -> stack_depth:int -> legacy:bool -> Script.node -> (ex_ty * context) tzresult = fun ctxt ~stack_depth ~legacy -> - (parse_ty_aux [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:true - ~allow_operation:true - ~allow_contract:true - ~allow_ticket:true - ~ret:Don't_parse_entrypoints - -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_ty - ctxt ~stack_depth ~legacy big_map_loc args map_annot = + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:true + ~allow_operation:true + ~allow_contract:true + ~allow_ticket:true + ~ret:Don't_parse_entrypoints [@coq_type_annotation]) + +and[@coq_struct "args"] parse_big_map_ty ctxt ~stack_depth ~legacy big_map_loc + args map_annot = Gas.consume ctxt Typecheck_costs.parse_type_cycle >>? fun ctxt -> match args with | [key_ty; value_ty] -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt key_ty + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt key_ty >>? fun (Ex_comparable_ty key_ty, ctxt) -> - parse_big_map_value_ty_aux + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy @@ -1396,18 +1395,18 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_ma (Ex_ty big_map_ty, ctxt) | args -> error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_big_map_value_ty_aux - ctxt ~stack_depth ~legacy value_ty = - (parse_ty_aux [@tailcall]) - ctxt - ~stack_depth - ~legacy - ~allow_lazy_storage:false - ~allow_operation:false - ~allow_contract:legacy - ~allow_ticket:true - ~ret:Don't_parse_entrypoints - value_ty +and[@coq_mutual_as_notation] parse_big_map_value_ty_aux ctxt ~stack_depth + ~legacy value_ty = + ((parse_ty_aux [@tailcall]) + ctxt + ~stack_depth + ~legacy + ~allow_lazy_storage:false + ~allow_operation:false + ~allow_contract:legacy + ~allow_ticket:true + ~ret:Don't_parse_entrypoints + value_ty [@coq_type_annotation]) let parse_packable_ty_aux ctxt ~stack_depth ~legacy node = (parse_ty_aux [@tailcall]) @@ -1562,7 +1561,7 @@ type ('arg, 'storage) code = code_size : Cache_memory_helpers.sint; } -> ('arg, 'storage) code - [@@coq_force_gadt] +[@@coq_force_gadt] type ex_script = Ex_script : ('a, 'c) Script_typed_ir.script -> ex_script @@ -1576,7 +1575,7 @@ type 'storage typed_view = original_code_expr : Script.node; } -> 'storage typed_view - [@@coq_force_gadt] +[@@coq_force_gadt] type 'storage typed_view_map = (Script_string.t, 'storage typed_view) map @@ -1715,29 +1714,31 @@ let find_entrypoint (type full fullc error_context error_trace) | _, {at_node = Some {name; original_type_expr}; _} when Entrypoint.(name = entrypoint) -> return (Ex_ty_cstr {ty; construct = (fun e -> e); original_type_expr}) - | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> ( - Gas_monad.bind_recover (find_entrypoint tl left entrypoint) @@ function [@coq_match_gadt] - | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> - return - (Ex_ty_cstr - { - ty; - construct = (fun e -> L (construct e)); - original_type_expr; - }) - | Error () -> ( - let+ x = - (find_entrypoint tr right entrypoint [@coq_type_annotation]) - in - match[@coq_match_gadt] x with - | Ex_ty_cstr {ty; construct; original_type_expr} -> - Ex_ty_cstr - { - ty; - construct = (fun e -> R (construct e)); - original_type_expr; - })) - [@coq_cast] + | Union_t (tl, tr, _, _), {nested = Entrypoints_Union {left; right}; _} -> + Gas_monad.bind_recover + (find_entrypoint tl left entrypoint) + (function [@coq_match_gadt] + | Ok (Ex_ty_cstr {ty; construct; original_type_expr}) -> + return + (Ex_ty_cstr + { + ty; + construct = (fun e -> L (construct e)); + original_type_expr; + }) + | Error () -> ( + let+ x = + (find_entrypoint tr right entrypoint [@coq_type_annotation]) + in + match[@coq_match_gadt] x with + | Ex_ty_cstr {ty; construct; original_type_expr} -> + Ex_ty_cstr + { + ty; + construct = (fun e -> R (construct e)); + original_type_expr; + })) + [@coq_cast] | _, {nested = Entrypoints_None; _} -> Gas_monad.of_result (Error ()) in let {root; original_type_expr} = entrypoints in @@ -1759,7 +1760,13 @@ let find_entrypoint_for_type (type full fullc exp expc error_trace) entrypoints entrypoint : (Entrypoint.t * (exp, expc) ty, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let* res = (find_entrypoint ~error_details full entrypoints entrypoint [@coq_type_annotation]) in + let* res = + (find_entrypoint + ~error_details + full + entrypoints + entrypoint [@coq_type_annotation]) + in match res with | Ex_ty_cstr {ty; _} -> ( match entrypoints.root.at_node with @@ -1858,7 +1865,8 @@ let parse_parameter_ty_and_entrypoints_aux : let entrypoints = {root = entrypoints; original_type_expr = node} in (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -let parse_passable_ty_aux = parse_passable_ty_aux_with_ret ~ret:Don't_parse_entrypoints +let parse_passable_ty_aux = + parse_passable_ty_aux_with_ret ~ret:Don't_parse_entrypoints let parse_uint ~nb_bits = assert (Compare.Int.(nb_bits >= 0 && nb_bits <= 30)) ; @@ -2314,19 +2322,19 @@ let parse_toplevel_aux : (* -- parse data of any type -- *) (* - Some values, such as operations, tickets, or big map ids, are used only - internally and are not allowed to be forged by users. - In [parse_data], [allow_forged] should be [false] for: - - PUSH - - UNPACK - - user-provided script parameters - - storage on origination - And [true] for: - - internal calls parameters - - storage after origination -*) + Some values, such as operations, tickets, or big map ids, are used only + internally and are not allowed to be forged by users. + In [parse_data], [allow_forged] should be [false] for: + - PUSH + - UNPACK + - user-provided script parameters + - storage on origination + And [true] for: + - internal calls parameters + - storage after origination + *) -let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : +let[@coq_struct "ctxt"] rec parse_data_aux : type a ac. ?type_logger:type_logger -> stack_depth:int -> @@ -2470,7 +2478,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : |> traced >|=? fun (_, map, ctxt) -> (map, ctxt) in - match (ty, script_data) with + match[@coq_match_gadt_with_result] (ty, script_data) with | Unit_t, expr -> Lwt.return @@ traced_no_lwt @@ (parse_unit ctxt ~legacy expr : (a * context) tzresult) @@ -2538,7 +2546,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : tr script_instr | Lambda_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) | Option_t (t, _, _), expr -> let parse_v ctxt v = @@ -2555,7 +2564,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : items (Script_list.empty, ctxt) | List_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Tickets *) | Ticket_t (t, _ty_name), expr -> if allow_forged then @@ -2563,7 +2573,10 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : non_terminal_recursion ?type_logger ctxt ~legacy ty expr >>=? fun (({destination; entrypoint = _}, (contents, amount)), ctxt) -> match destination with - | Contract ticketer -> return ({ticketer; contents; amount}, ctxt) + | Contract ticketer -> + return + ( {ticketer; contents = contents [@coq_type_annotation]; amount}, + ctxt ) | Tx_rollup _ | Sc_rollup _ -> fail (Unexpected_ticket_owner destination) else traced_fail (Unexpected_forged_value (location expr)) @@ -2600,16 +2613,28 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : vs >|=? fun (_, set, ctxt) -> (set, ctxt) | Set_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Maps *) | Map_t (tk, tv, _ty_name), (Seq (_, vs) as expr) -> - parse_items ?type_logger ctxt expr tk tv vs (fun x -> x) + ((parse_items [@coq_type_annotation]) + ?type_logger + ctxt + expr + tk + tv + vs + (fun x -> x) + : (_ map * _) tzresult Lwt.t) | Map_t _, expr -> - traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Seq_kind], kind expr)) | Big_map_t (tk, tv, _ty_name), expr -> (match expr with | Int (loc, id) -> - return (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + return + (Some (id, loc), {map = Big_map_overlay.empty; size = 0}, ctxt) + [@coq_type_annotation] | Seq (_, vs) -> parse_big_map_items ?type_logger ctxt expr tk tv vs (fun x -> Some x) >|=? fun (diff, ctxt) -> (None, diff, ctxt) @@ -2667,14 +2692,16 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | Bls12_381_g1_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Bls12_381_g2_t, Bytes (_, bs) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_g2 >>?= fun ctxt -> match Script_bls.G2.of_bytes_opt bs with | Some pt -> return (pt, ctxt) | None -> fail_parse_data ()) | Bls12_381_g2_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Bls12_381_fr_t, Bytes (_, bs) -> ( Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> match Script_bls.Fr.of_bytes_opt bs with @@ -2684,11 +2711,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : Gas.consume ctxt Typecheck_costs.bls12_381_fr >>?= fun ctxt -> return (Script_bls.Fr.of_z v, ctxt) | Bls12_381_fr_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) (* - /!\ When adding new lazy storage kinds, you may want to guard the parsing - of identifiers with [allow_forged]. - *) + /!\ When adding new lazy storage kinds, you may want to guard the parsing + of identifiers with [allow_forged]. + *) (* Sapling *) | Sapling_transaction_t memo_size, Bytes (_, bytes) -> ( match @@ -2706,7 +2734,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | Sapling_transaction_t _, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Sapling_transaction_deprecated_t memo_size, Bytes (_, bytes) -> ( match Data_encoding.Binary.of_bytes_opt @@ -2725,7 +2754,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : >|? fun () -> (transaction, ctxt) )) | None -> fail_parse_data ()) | Sapling_transaction_deprecated_t _, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Sapling_state_t memo_size, Int (loc, id) -> if allow_forged then let id = Sapling.Id.parse_z id in @@ -2739,11 +2769,12 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : >|? fun () -> (state, ctxt) ) else traced_fail (Unexpected_forged_value loc) | Sapling_state_t memo_size, Seq (_, []) -> - return (Sapling.empty_state ~memo_size (), ctxt) + ((return [@coq_type_annotation]) (Sapling.empty_state ~memo_size (), ctxt) + : (Sapling.state * _) tzresult Lwt.t) | Sapling_state_t _, expr -> (* Do not allow to input diffs as they are untrusted and may not be the result of a verify_update. *) - traced_fail + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) (Invalid_kind (location expr, [Int_kind; Seq_kind], kind expr)) (* Time lock*) | Chest_key_t, Bytes (_, bytes) -> ( @@ -2756,7 +2787,8 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : | Some chest_key -> return (chest_key, ctxt) | None -> fail_parse_data ()) | Chest_key_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) | Chest_t, Bytes (_, bytes) -> ( Gas.consume ctxt (Typecheck_costs.chest ~bytes:(Bytes.length bytes)) >>?= fun ctxt -> @@ -2766,9 +2798,10 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data_aux : | Some chest -> return (chest, ctxt) | None -> fail_parse_data ()) | Chest_t, expr -> - traced_fail (Invalid_kind (location expr, [Bytes_kind], kind expr)) + (traced_fail [@coq_implicit "B" "a * Raw_context.t"]) + (Invalid_kind (location expr, [Bytes_kind], kind expr)) -and[@coq_axiom_with_reason "gadt"] parse_view : +and[@coq_struct "ctxt"] parse_view : type storage storagec. ?type_logger:type_logger -> context -> @@ -2832,7 +2865,7 @@ and[@coq_axiom_with_reason "gadt"] parse_view : ctxt ) | _ -> error (ill_type_view aft loc)) -and[@coq_axiom_with_reason "gadt"] parse_views : +and[@coq_mutual_as_notation] parse_views : type storage storagec. ?type_logger:type_logger -> context -> @@ -2849,7 +2882,7 @@ and[@coq_axiom_with_reason "gadt"] parse_views : in Script_map.map_es_in_context aux ctxt views -and[@coq_axiom_with_reason "gadt"] parse_returning : +and[@coq_mutual_as_notation] parse_returning : type arg argc ret retc. ?type_logger:type_logger -> stack_depth:int -> @@ -2892,7 +2925,7 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : : (arg, ret) lambda), ctxt ) -and[@coq_axiom_with_reason "gadt"] parse_instr_aux : +and[@coq_struct "ctxt"] parse_instr_aux : type a s. ?type_logger:type_logger -> stack_depth:int -> @@ -3069,8 +3102,8 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : typed ctxt loc swap stack_ty | Prim (loc, I_PUSH, [t; d], annot), stack -> check_var_annot loc annot >>?= fun () -> - parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t - >>?= fun (Ex_ty t, ctxt) -> + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t + >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> parse_data_aux ?type_logger ~stack_depth:(stack_depth + 1) @@ -3080,7 +3113,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : t d >>=? fun (v, ctxt) -> - let const = {apply = (fun kinfo k -> IConst (kinfo, v, k))} in + let const = + {apply = (fun kinfo k -> IConst (kinfo, (v [@coq_type_annotation]), k))} + in typed ctxt loc const (Item_t (t, stack)) | Prim (loc, I_UNIT, [], annot), stack -> check_var_type_annot loc annot >>?= fun () -> @@ -3092,7 +3127,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : let cons_some = {apply = (fun kinfo k -> ICons_some (kinfo, k))} in option_t loc t >>?= fun ty -> typed ctxt loc cons_some (Item_t (ty, rest)) | Prim (loc, I_NONE, [t], annot), stack -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let cons_none = {apply = (fun kinfo k -> ICons_none (kinfo, k))} in @@ -3176,8 +3211,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : ok (Comb_proof_argument (Comb_one, Item_t (a_ty, tl_ty))) | n, Item_t (a_ty, tl_ty) -> make_proof_argument (n - 1) tl_ty - >>? fun (Comb_proof_argument (comb_witness, Item_t (b_ty, tl_ty'))) - -> + >>? fun [@coq_match_with_default] (Comb_proof_argument + ( comb_witness, + Item_t (b_ty, tl_ty') )) -> pair_t loc a_ty b_ty >|? fun (Ty_ex_c pair_t) -> Comb_proof_argument (Comb_succ comb_witness, Item_t (pair_t, tl_ty')) | _ -> @@ -3194,7 +3230,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : typed ctxt loc comb after_ty | Prim (loc, I_UNPAIR, [n], annot), stack_ty -> error_unexpected_annot loc annot >>?= fun () -> - let rec make_proof_argument : + let[@coq_struct "n_value"] rec make_proof_argument : type a s. int -> (a, s) stack_ty -> (a * s) uncomb_proof_argument tzresult = fun n stack_ty -> @@ -3257,7 +3293,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : typed ctxt loc cdr (Item_t (b, rest)) (* unions *) | Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tr + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tr >>?= fun (Ex_ty tr, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_left = {apply = (fun kinfo k -> ICons_left (kinfo, k))} in @@ -3265,7 +3301,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : let stack_ty = Item_t (ty, rest) in typed ctxt loc cons_left stack_ty | Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tl + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tl >>?= fun (Ex_ty tl, ctxt) -> check_constr_annot loc annot >>?= fun () -> let cons_right = {apply = (fun kinfo k -> ICons_right (kinfo, k))} in @@ -3310,7 +3346,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : Lwt.return @@ merge_branches ctxt loc btr bfr {branch} (* lists *) | Prim (loc, I_NIL, [t], annot), stack -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy t >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let nil = {apply = (fun kinfo k -> INil (kinfo, k))} in @@ -3431,7 +3467,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : ) (* sets *) | Prim (loc, I_EMPTY_SET, [t], annot), rest -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt t >>?= fun (Ex_comparable_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_set (kinfo, t, k))} in @@ -3491,9 +3527,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : typed ctxt loc instr (Item_t (nat_t, rest)) (* maps *) | Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = {apply = (fun kinfo k -> IEmpty_map (kinfo, tk, k))} in @@ -3617,9 +3653,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : typed ctxt loc instr (Item_t (nat_t, rest)) (* big_map *) | Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack -> - parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk + parse_comparable_ty_aux ~stack_depth:(stack_depth + 1) ctxt tk >>?= fun (Ex_comparable_ty tk, ctxt) -> - parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv + parse_big_map_value_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy tv >>?= fun (Ex_ty tv, ctxt) -> check_var_type_annot loc annot >>?= fun () -> let instr = @@ -3856,9 +3892,9 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : let stack = Item_t (tr, rest) in typed_no_lwt ctxt loc instr stack) | Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy arg + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy arg >>?= fun (Ex_ty arg, ctxt) -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ret + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ret >>?= fun (Ex_ty ret, ctxt) -> check_kind [Seq_kind] code >>?= fun () -> check_var_annot loc annot >>?= fun () -> @@ -4302,7 +4338,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : (* annotations *) | Prim (loc, I_CAST, [cast_t], annot), (Item_t (t, _) as stack) -> check_var_annot loc annot >>?= fun () -> - parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t + parse_any_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t >>?= fun (Ex_ty cast_t, ctxt) -> Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) cast_t t >>?= fun (eq, ctxt) -> @@ -4327,7 +4363,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : let stack = Item_t (bytes_t, rest) in typed ctxt loc instr stack | Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t, rest) -> - parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> check_var_type_annot loc annot >>?= fun () -> option_t loc t >>?= fun res_ty -> @@ -4341,7 +4377,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : let stack = Item_t (address_t, rest) in typed ctxt loc instr stack | Prim (loc, I_CONTRACT, [ty], annot), Item_t (Address_t, rest) -> - parse_passable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_passable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> contract_t loc t >>?= fun contract_ty -> option_t loc contract_ty >>?= fun res_ty -> @@ -4433,10 +4469,14 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : arg_type_full ret_type_full code_field) - >>=? fun ( Lam - ( {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, - _ ), - ctxt ) -> + >>=? fun [@coq_match_with_default] ( Lam + ( { + kbef = Item_t (arg, Bot_t); + kaft = Item_t (ret, Bot_t); + _; + }, + _ ), + ctxt ) -> let views_result = parse_views ctxt ?type_logger ~legacy storage_type views in @@ -4517,7 +4557,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : Lwt.return ( parse_entrypoint_annot_lax loc annot >>? fun entrypoint -> let open Tc_context in - match tc_context.callsite with + match[@coq_match_gadt] tc_context.callsite with | _ when is_in_lambda tc_context -> error (Forbidden_instr_in_context (loc, Script_tc_errors.Lambda, prim)) @@ -4530,11 +4570,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : (Forbidden_instr_in_context (loc, Script_tc_errors.View, prim)) | Toplevel {param_type; entrypoints; storage_type = _} -> Gas_monad.run ctxt - @@ find_entrypoint - ~error_details:(Informative ()) - param_type - entrypoints - entrypoint + @@ (find_entrypoint + ~error_details:(Informative ()) + param_type + entrypoints + entrypoint [@coq_type_annotation]) >>? fun (r, ctxt) -> r >>? fun (Ex_ty_cstr {ty = param_type; _}) -> contract_t loc param_type >>? fun res_ty -> @@ -4915,27 +4955,6 @@ and[@coq_axiom_with_reason "gadt"] parse_instr_aux : I_XOR; ] -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract_data_aux : - type arg argc. - stack_depth:int -> - context -> - Script.location -> - (arg, argc) ty -> - Destination.t -> - entrypoint:Entrypoint.t -> - (context * arg typed_contract) tzresult Lwt.t = - fun ~stack_depth ctxt loc arg destination ~entrypoint -> - let error_details = Informative loc in - parse_contract - ~stack_depth:(stack_depth + 1) - ctxt - ~error_details - loc - arg - destination - ~entrypoint - >>=? fun (ctxt, res) -> Lwt.return (res >|? fun res -> (ctxt, res)) - (* [parse_contract] is used both to: - parse contract data by [parse_data] ([parse_contract_data]) - to execute the [CONTRACT] instruction ([parse_contract_for_script]). @@ -4947,7 +4966,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra The inner [result] is turned into an [option] by [parse_contract_for_script]. Both [tzresult] are merged by [parse_contract_data]. *) -and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contract : +and[@coq_mutual_as_notation] parse_contract : type arg argc err. stack_depth:int -> context -> @@ -4961,7 +4980,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra let error ctxt f_err : context * (_, err) result = ( ctxt, Error - (match error_details with + (match[@coq_match_gadt_with_result] error_details with | Fast -> (Inconsistent_types_fast : err) | Informative loc -> trace_of_error @@ f_err loc) ) in @@ -5000,16 +5019,18 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra (* can only fail because of gas *) parse_toplevel_aux ctxt ~legacy:true code >>? fun ({arg_type; _}, ctxt) -> - parse_parameter_ty_and_entrypoints_aux + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy:true arg_type - >>? fun ( Ex_parameter_ty_and_entrypoints - {arg_type = targ; entrypoints}, - ctxt ) -> + >>? fun [@coq_match_gadt] ( Ex_parameter_ty_and_entrypoints + {arg_type = targ; entrypoints}, + ctxt ) -> Gas_monad.run ctxt - @@ find_entrypoint_for_type + @@ (find_entrypoint_for_type + [@coq_implicit + "full" "__Ex_parameter_ty_and_entrypoints_'a1"]) ~error_details ~full:targ ~expected:arg @@ -5048,16 +5069,17 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra ctxt parameters_type >>? fun (parameters_type, ctxt) -> - parse_parameter_ty_and_entrypoints_aux + parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy:true (root parameters_type) - >>? fun ( Ex_parameter_ty_and_entrypoints - {arg_type = full; entrypoints}, - ctxt ) -> + >>? fun [@coq_match_gadt] ( Ex_parameter_ty_and_entrypoints + {arg_type = full; entrypoints}, + ctxt ) -> Gas_monad.run ctxt - @@ find_entrypoint_for_type + @@ (find_entrypoint_for_type + [@coq_implicit "full" "__Ex_parameter_ty_and_entrypoints_'a2"]) ~error_details ~full ~expected:arg @@ -5069,6 +5091,27 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra let address = {destination; entrypoint} in Typed_contract {arg_ty; address} )) +and[@coq_mutual_as_notation] parse_contract_data_aux : + type arg argc. + stack_depth:int -> + context -> + Script.location -> + (arg, argc) ty -> + Destination.t -> + entrypoint:Entrypoint.t -> + (context * arg typed_contract) tzresult Lwt.t = + fun ~stack_depth ctxt loc arg destination ~entrypoint -> + let error_details = Informative loc in + parse_contract + ~stack_depth:(stack_depth + 1) + ctxt + ~error_details + loc + arg + destination + ~entrypoint + >>=? fun (ctxt, res) -> Lwt.return (res >|? fun res -> (ctxt, res)) + (* Same as [parse_contract], but does not fail when the contact is missing or if the expected type doesn't match the actual one. In that case None is returned and some overapproximation of the typechecking gas is consumed. @@ -5131,7 +5174,11 @@ let parse_code : let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux + ctxt + ~stack_depth:0 + ~legacy + arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5188,7 +5235,7 @@ let parse_storage : storage_type (root storage)) -let[@coq_axiom_with_reason "gadt"] parse_script : +let parse_script : ?type_logger:type_logger -> context -> legacy:bool -> @@ -5197,10 +5244,17 @@ let[@coq_axiom_with_reason "gadt"] parse_script : (ex_script * context) tzresult Lwt.t = fun ?type_logger ctxt ~legacy ~allow_forged_in_storage {code; storage} -> parse_code ~legacy ctxt ?type_logger ~code - >>=? fun ( Ex_code - (Code - {code; arg_type; storage_type; views; entrypoints; code_size}), - ctxt ) -> + >>=? fun [@coq_match_gadt] ( Ex_code + (Code + { + code; + arg_type; + storage_type; + views; + entrypoints; + code_size; + }), + ctxt ) -> parse_storage ?type_logger ctxt @@ -5211,7 +5265,15 @@ let[@coq_axiom_with_reason "gadt"] parse_script : >|=? fun (storage, ctxt) -> ( Ex_script (Script - {code_size; code; arg_type; storage; storage_type; views; entrypoints}), + { + code_size; + code; + arg_type; + storage = storage [@coq_type_annotation]; + storage_type; + views; + entrypoints; + }), ctxt ) type typechecked_code_internal = @@ -5240,7 +5302,11 @@ let typecheck_code_aux : let arg_type_loc = location arg_type in record_trace (Ill_formed_type (Some "parameter", code, arg_type_loc)) - (parse_parameter_ty_and_entrypoints_aux ctxt ~stack_depth:0 ~legacy arg_type) + (parse_parameter_ty_and_entrypoints_aux + ctxt + ~stack_depth:0 + ~legacy + arg_type) >>?= fun (Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, ctxt) -> let storage_type_loc = location storage_type in record_trace @@ -5328,13 +5394,12 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) (Entrypoint.Map.singleton name (Ex_ty full, original_type_expr), true) in fold_tree full entrypoints.root [] reachable ([], init) - [@@coq_axiom_with_reason "unsupported syntax"] (* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) (* -- Unparsing data of any type -- *) -let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : +let[@coq_struct "ctxt"] rec unparse_data_aux : type a ac. context -> stack_depth:int -> @@ -5350,43 +5415,50 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : else unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode ty a in let loc = Micheline.dummy_location in - match (ty, a) with - | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v - | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v - | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v - | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s - | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s - | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b - | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address - | Tx_rollup_l2_address_t, address -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, a) with + | Unit_t, (v : unit) -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, (v : _ Script_int.num) -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, (s : Script_string.t) -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, (s : bytes) -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, (b : bool) -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, (t : Script_timestamp.t) -> + Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, (address : address) -> + Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, (address : tx_rollup_l2_address) -> Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | Contract_t _, contract -> + | Contract_t _, (contract : _ typed_contract) -> Lwt.return @@ unparse_contract ~loc ctxt mode contract - | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v - | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k - | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | Operation_t, operation -> + | Signature_t, (s : signature) -> + Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, (v : Tez_repr.t) -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, (k : public_key) -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, (k : public_key_hash) -> + Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Operation_t, (operation : operation) -> Lwt.return @@ unparse_operation ~loc ctxt operation - | Chain_id_t, chain_id -> + | Chain_id_t, (chain_id : Script_chain_id.t) -> Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | Bls12_381_g1_t, x -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x - | Bls12_381_g2_t, x -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x - | Bls12_381_fr_t, x -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x - | Pair_t (tl, tr, _, _), pair -> + | Bls12_381_g1_t, (x : Script_bls.G1.t) -> + Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x + | Bls12_381_g2_t, (x : Script_bls.G2.t) -> + Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x + | Bls12_381_fr_t, (x : Script_bls.Fr.t) -> + Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x + | Pair_t (tl, tr, _, _), (pair : _ * _) -> let r_witness = comb_witness2 tr in let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | Union_t (tl, tr, _, _), v -> + | Union_t (tl, tr, _, _), (v : _ union) -> let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in unparse_union ~loc unparse_l unparse_r ctxt v - | Option_t (t, _, _), v -> + | Option_t (t, _, _), (v : _ option) -> let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in unparse_option ~loc unparse_v ctxt v - | List_t (t, _), items -> + | List_t (t, _), (items : _ boxed_list) -> List.fold_left_es (fun (l, ctxt) element -> non_terminal_recursion ctxt mode t element @@ -5394,7 +5466,8 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : ([], ctxt) items.elements >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) - | Ticket_t (t, _), {ticketer; contents; amount} -> + | Ticket_t (t, _), (x : _ ticket) -> + let {ticketer; contents; amount} = x in (* ideally we would like to allow a little overhead here because it is only used for unparsing *) opened_ticket_type loc t >>?= fun t -> let destination : Destination.t = Contract ticketer in @@ -5405,7 +5478,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : mode t (addr, (contents, amount)) - | Set_t (t, _), set -> + | Set_t (t, _), (set : _ set) -> List.fold_left_es (fun (l, ctxt) item -> unparse_comparable_data ~loc ctxt mode t item >|=? fun (item, ctxt) -> @@ -5413,65 +5486,68 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : ([], ctxt) (Script_set.fold (fun e acc -> e :: acc) set []) >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Map_t (kt, vt, _), map -> + | Map_t (kt, vt, _), (map : _ map) -> let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _} - when Compare.Int.( = ) size 0 -> - return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) - | Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _} -> - let items = - Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] - in - let items = - (* Sort the items in Michelson comparison order and not in key - hash order. This code path is only exercised for tracing, - so we don't bother carbonating this sort operation - precisely. Also, the sort uses a reverse compare because - [unparse_items] will reverse the result. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - (* this can't fail if the original type is well-formed - because [option vt] is always strictly smaller than [big_map kt vt] *) - option_t loc vt >>?= fun vt -> - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> - ( Micheline.Prim - ( loc, - D_Pair, - [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], - [] ), - ctxt ) - | Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _} -> - let items = - Big_map_overlay.fold - (fun _ (k, v) acc -> - match v with None -> acc | Some v -> (k, v) :: acc) - map - [] - in - let items = - (* See note above. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Lambda_t _, Lam (_, original_code) -> + | Big_map_t (kt, vt, _), (x : _ big_map) -> ( + match x with + | Big_map {id = Some id; diff = {size; _}; _} + when Compare.Int.( = ) size 0 -> + return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) + | Big_map {id = Some id; diff = {map; _}; _} -> + let items = + Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] + in + let items = + (* Sort the items in Michelson comparison order and not in key + hash order. This code path is only exercised for tracing, + so we don't bother carbonating this sort operation + precisely. Also, the sort uses a reverse compare because + [unparse_items] will reverse the result. *) + List.sort + (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) + items + in + (* this can't fail if the original type is well-formed + because [option vt] is always strictly smaller than [big_map kt vt] *) + option_t loc vt >>?= fun vt -> + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> + ( Micheline.Prim + ( loc, + D_Pair, + [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], + [] ), + ctxt ) + | Big_map {id = None; diff = {map; _}; _} -> + let items = + Big_map_overlay.fold + (fun _ (k, v) acc -> + match v with None -> acc | Some v -> (k, v) :: acc) + map + [] + in + let items = + (* See note above. *) + List.sort + (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) + items + in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt)) + | Lambda_t _, (x : _ lambda) -> + let (Lam (_, original_code)) = x in unparse_code_aux ctxt ~stack_depth:(stack_depth + 1) mode original_code | Never_t, _ -> . - | Sapling_transaction_t _, s -> + | Sapling_transaction_t _, (s : Sapling.transaction) -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) >|? fun ctxt -> let bytes = Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s in (Bytes (loc, bytes), ctxt) ) - | Sapling_transaction_deprecated_t _, s -> + | Sapling_transaction_deprecated_t _, (s : Sapling_repr.legacy_transaction) -> Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) >|? fun ctxt -> @@ -5481,7 +5557,8 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : s in (Bytes (loc, bytes), ctxt) ) - | Sapling_state_t _, {id; diff; _} -> + | Sapling_state_t _, (x : Sapling.state) -> + let {Sapling.id; diff; _} = x in Lwt.return ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> ( (match diff with @@ -5503,14 +5580,14 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : Micheline.Prim (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), ctxt ) ) - | Chest_key_t, s -> + | Chest_key_t, (s : Script_timelock.chest_key) -> unparse_with_data_encoding ~loc ctxt s Unparse_costs.chest_key Script_timelock.chest_key_encoding - | Chest_t, s -> + | Chest_t, (s : Script_timelock.chest) -> unparse_with_data_encoding ~loc ctxt @@ -5519,7 +5596,7 @@ let[@coq_axiom_with_reason "gadt"] rec unparse_data_aux : ~plaintext_size:(Script_timelock.get_plaintext_size s)) Script_timelock.chest_encoding -and unparse_items : +and[@coq_mutual_as_notation] unparse_items : type k v vc. context -> stack_depth:int -> @@ -5538,7 +5615,7 @@ and unparse_items : ([], ctxt) items -and[@coq_axiom_with_reason "gadt"] unparse_code_aux ctxt ~stack_depth mode code = +and[@coq_struct "ctxt"] unparse_code_aux ctxt ~stack_depth mode code = let legacy = true in Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> let non_terminal_recursion ctxt mode code = @@ -5548,7 +5625,7 @@ and[@coq_axiom_with_reason "gadt"] unparse_code_aux ctxt ~stack_depth mode code in match code with | Prim (loc, I_PUSH, [ty; data], annot) -> - parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty >>?= fun (Ex_ty t, ctxt) -> let allow_forged = false @@ -5595,7 +5672,7 @@ let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage ctxt code >>?= fun (code, ctxt) -> - typecheck_code_aux ~legacy ~show_types:false ctxt code + typecheck_code_aux ~legacy ~show_types:false ctxt code >>=? fun ( Typechecked_code_internal { toplevel = @@ -5700,59 +5777,60 @@ let diff_of_big_map ctxt mode ~temporary ~ids_to_copy (big_map : ('a, 'b) big_map) = match[@coq_match_gadt] big_map with | Big_map {id; key_type; value_type; diff} -> - (match id with - | Some id -> - if Lazy_storage.IdSet.mem Big_map id ids_to_copy then - Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> - (ctxt, Lazy_storage.Copy {src = id}, duplicate) - else - (* The first occurrence encountered of a big_map reuses the - ID. This way, the payer is only charged for the diff. - For this to work, this diff has to be put at the end of - the global diff, otherwise the duplicates will use the - updated version as a base. This is true because we add - this diff first in the accumulator of - `extract_lazy_storage_updates`, and this accumulator is not - reversed. *) - return (ctxt, Lazy_storage.Existing, id) - | None -> - Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> - Lwt.return - (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in - Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> - unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> - let key_type = Micheline.strip_locations kt in - let value_type = Micheline.strip_locations kv in - (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) - >>=? fun (ctxt, init, id) -> - let pairs = - Big_map_overlay.fold - (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) - diff.map - [] - in - List.fold_left_es - (fun (acc, ctxt) (key_hash, key, value) -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - unparse_comparable_data ~loc:() ctxt mode key_type key - >>=? fun (key_node, ctxt) -> - Gas.consume ctxt (Script.strip_locations_cost key_node) >>?= fun ctxt -> - let key = Micheline.strip_locations key_node in - (match value with - | None -> return (None, ctxt) - | Some x -> - unparse_data_aux ~stack_depth:0 ctxt mode value_type x - >>=? fun (node, ctxt) -> + (match id with + | Some id -> + if Lazy_storage.IdSet.mem Big_map id ids_to_copy then + Big_map.fresh ~temporary ctxt >|=? fun (ctxt, duplicate) -> + (ctxt, Lazy_storage.Copy {src = id}, duplicate) + else + (* The first occurrence encountered of a big_map reuses the + ID. This way, the payer is only charged for the diff. + For this to work, this diff has to be put at the end of + the global diff, otherwise the duplicates will use the + updated version as a base. This is true because we add + this diff first in the accumulator of + `extract_lazy_storage_updates`, and this accumulator is not + reversed. *) + return (ctxt, Lazy_storage.Existing, id) + | None -> + Big_map.fresh ~temporary ctxt >>=? fun (ctxt, id) -> Lwt.return - ( Gas.consume ctxt (Script.strip_locations_cost node) >|? fun ctxt -> - (Some (Micheline.strip_locations node), ctxt) )) - >|=? fun (value, ctxt) -> - let diff_item = Big_map.{key; key_hash; value} in - (diff_item :: acc, ctxt)) - ([], ctxt) - (List.rev pairs) - >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) + (let kt = unparse_comparable_ty_uncarbonated ~loc:() key_type in + Gas.consume ctxt (Script.strip_locations_cost kt) >>? fun ctxt -> + unparse_ty ~loc:() ctxt value_type >>? fun (kv, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost kv) >|? fun ctxt -> + let key_type = Micheline.strip_locations kt in + let value_type = Micheline.strip_locations kv in + (ctxt, Lazy_storage.(Alloc Big_map.{key_type; value_type}), id))) + >>=? fun (ctxt, init, id) -> + let pairs = + Big_map_overlay.fold + (fun key_hash (key, value) acc -> (key_hash, key, value) :: acc) + diff.map + [] + in + List.fold_left_es + (fun (acc, ctxt) (key_hash, key, value) -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> + unparse_comparable_data ~loc:() ctxt mode key_type key + >>=? fun (key_node, ctxt) -> + Gas.consume ctxt (Script.strip_locations_cost key_node) + >>?= fun ctxt -> + let key = Micheline.strip_locations key_node in + (match value with + | None -> return (None, ctxt) + | Some x -> + unparse_data_aux ~stack_depth:0 ctxt mode value_type x + >>=? fun (node, ctxt) -> + Lwt.return + ( Gas.consume ctxt (Script.strip_locations_cost node) + >|? fun ctxt -> (Some (Micheline.strip_locations node), ctxt) )) + >|=? fun (value, ctxt) -> + let diff_item = Big_map.{key; key_hash; value} in + (diff_item :: acc, ctxt)) + ([], ctxt) + (List.rev pairs) + >|=? fun (updates, ctxt) -> (Lazy_storage.Update {init; updates}, id, ctxt) let diff_of_sapling_state ctxt ~temporary ~ids_to_copy ({id; diff; memo_size} : Sapling.state) = @@ -5769,21 +5847,21 @@ let diff_of_sapling_state ctxt ~temporary ~ids_to_copy (Lazy_storage.Update {init; updates = diff}, id, ctxt) (** - Witness flag for whether a type can be populated by a value containing a - lazy storage. - [False_f] must be used only when a value of the type cannot contain a lazy - storage. + Witness flag for whether a type can be populated by a value containing a + lazy storage. + [False_f] must be used only when a value of the type cannot contain a lazy + storage. - This flag is built in [has_lazy_storage] and used only in - [extract_lazy_storage_updates] and [collect_lazy_storage]. + This flag is built in [has_lazy_storage] and used only in + [extract_lazy_storage_updates] and [collect_lazy_storage]. - This flag is necessary to avoid these two functions to have a quadratic - complexity in the size of the type. + This flag is necessary to avoid these two functions to have a quadratic + complexity in the size of the type. - Add new lazy storage kinds here. + Add new lazy storage kinds here. - Please keep the usage of this GADT local. -*) + Please keep the usage of this GADT local. + *) type 'ty has_lazy_storage = | Big_map_f : ('a, 'b) big_map has_lazy_storage @@ -5800,11 +5878,11 @@ type 'ty has_lazy_storage = | Map_f : 'v has_lazy_storage -> (_, 'v) map has_lazy_storage (** - This function is called only on storage and parameter types of contracts, - once per typechecked contract. It has a complexity linear in the size of - the types, which happen to be literally written types, so the gas for them - has already been paid. -*) + This function is called only on storage and parameter types of contracts, + once per typechecked contract. It has a complexity linear in the size of + the types, which happen to be literally written types, so the gas for them + has already been paid. + *) let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = fun ty -> let aux1 cons t = @@ -5852,15 +5930,14 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = | Map_t (_, t, _) -> aux1 (fun h -> Map_f h) t (** - Transforms a value potentially containing lazy storage in an intermediary - state to a value containing lazy storage only represented by identifiers. + Transforms a value potentially containing lazy storage in an intermediary + state to a value containing lazy storage only represented by identifiers. - Returns the updated value, the updated set of ids to copy, and the lazy - storage diff to show on the receipt and apply on the storage. + Returns the updated value, the updated set of ids to copy, and the lazy + storage diff to show on the receipt and apply on the storage. -*) -let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode - ~temporary ids_to_copy acc ty x = + *) +let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = let rec aux : type a ac. context -> @@ -5937,7 +6014,8 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode (ctxt, M.OPS.empty, ids_to_copy, acc) (bindings M.boxed) >|=? fun (ctxt, m, ids_to_copy, acc) -> - let module M = struct + let module M : + Boxed_map with type key = M.key and type value = M.value = struct module OPS = M.OPS type key = M.key @@ -5963,7 +6041,7 @@ let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_updates ctxt mode aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage (** We namespace an error type for [fold_lazy_storage]. The error case is only - available when the ['error] parameter is equal to unit. *) + available when the ['error] parameter is equal to unit. *) module Fold_lazy_storage = struct type ('acc, 'error) result = | Ok : 'acc -> ('acc, 'error) result @@ -5971,9 +6049,9 @@ module Fold_lazy_storage = struct end (** Prematurely abort if [f] generates an error. Use this function without the - [unit] type for [error] if you are in a case where errors are impossible. -*) -let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : + [unit] type for [error] if you are in a case where errors are impossible. + *) +let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : type a ac error. f:('acc, error) Fold_lazy_storage.result Lazy_storage.IdSet.fold_f -> init:'acc -> @@ -5984,7 +6062,9 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : (('acc, error) Fold_lazy_storage.result * context) tzresult = fun ~f ~init ctxt ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - match (has_lazy_storage, ty, x) with + match[@coq_match_gadt] [@coq_match_with_default] + (has_lazy_storage, ty, x) + with | Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _} -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) @@ -6032,7 +6112,7 @@ let[@coq_axiom_with_reason "gadt"] rec fold_lazy_storage : m (ok (Fold_lazy_storage.Ok init, ctxt)) -let[@coq_axiom_with_reason "gadt"] collect_lazy_storage ctxt ty x = +let collect_lazy_storage ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f kind id (acc : (_, never) Fold_lazy_storage.result) = let acc = match acc with Fold_lazy_storage.Ok acc -> acc in @@ -6042,13 +6122,13 @@ let[@coq_axiom_with_reason "gadt"] collect_lazy_storage ctxt ty x = >>? fun (ids, ctxt) -> match ids with Fold_lazy_storage.Ok ids -> ok (ids, ctxt) -let[@coq_axiom_with_reason "gadt"] extract_lazy_storage_diff ctxt mode - ~temporary ~to_duplicate ~to_update ty v = +let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v + = (* - Basically [to_duplicate] are ids from the argument and [to_update] are ids - from the storage before execution (i.e. it is safe to reuse them since they - will be owned by the same contract). - *) + Basically [to_duplicate] are ids from the argument and [to_update] are ids + from the storage before execution (i.e. it is safe to reuse them since they + will be owned by the same contract). + *) let to_duplicate = Lazy_storage.IdSet.diff to_duplicate to_update in extract_lazy_storage_updates ctxt mode ~temporary to_duplicate [] ty v >|=? fun (ctxt, v, alive, diffs) -> @@ -6120,7 +6200,7 @@ let parse_ty = parse_ty_aux ~stack_depth:0 ~ret:Don't_parse_entrypoints let parse_parameter_ty_and_entrypoints = parse_parameter_ty_and_entrypoints_aux ~stack_depth:0 -let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = +let get_single_sapling_state ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i) single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result = @@ -6141,31 +6221,31 @@ let[@coq_axiom_with_reason "gadt"] get_single_sapling_state ctxt ty x = (* - {!Script_cache} needs a measure of the script size in memory. - Determining this size is not easy in OCaml because of sharing. - - Indeed, many values present in the script share the same memory - area. This is especially true for types and stack types: they are - heavily shared in every typed IR internal representation. As a - consequence, computing the size of the typed IR without taking - sharing into account leads to a size which is sometimes two order - of magnitude bigger than the actual size. - - We could track down this sharing. Unfortunately, sharing is not - part of OCaml semantics: for this reason, a compiler can optimize - memory representation by adding more sharing. If two nodes use - different optimization flags or compilers, such a precise - computation of the memory footprint of scripts would lead to two - distinct sizes. As these sizes occur in the blockchain context, - this situation would lead to a fork. - - For this reason, we introduce a *size model* for the script size. - This model provides an overapproximation of the actual size in - memory. The risk is to be too far from the actual size: the cache - would then be wrongly marked as full. This situation would make the - cache less useful but should present no security risk . + {!Script_cache} needs a measure of the script size in memory. + Determining this size is not easy in OCaml because of sharing. + + Indeed, many values present in the script share the same memory + area. This is especially true for types and stack types: they are + heavily shared in every typed IR internal representation. As a + consequence, computing the size of the typed IR without taking + sharing into account leads to a size which is sometimes two order + of magnitude bigger than the actual size. + + We could track down this sharing. Unfortunately, sharing is not + part of OCaml semantics: for this reason, a compiler can optimize + memory representation by adding more sharing. If two nodes use + different optimization flags or compilers, such a precise + computation of the memory footprint of scripts would lead to two + distinct sizes. As these sizes occur in the blockchain context, + this situation would lead to a fork. + + For this reason, we introduce a *size model* for the script size. + This model provides an overapproximation of the actual size in + memory. The risk is to be too far from the actual size: the cache + would then be wrongly marked as full. This situation would make the + cache less useful but should present no security risk . -*) + *) let script_size (Ex_script (Script -- GitLab From 8511d94e03ba816a83564a9a315b031f1fdaea6e Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 19 Jul 2022 10:12:23 +0200 Subject: [PATCH 103/105] Proto: more changes to translate all of script_ir_translator.ml to Coq --- .../lib_protocol/script_ir_translator.ml | 158 ++++++++++++------ 1 file changed, 109 insertions(+), 49 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index cadbb6c2e33b7..622d6c37e1658 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -5491,7 +5491,7 @@ let[@coq_struct "ctxt"] rec unparse_data_aux : unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) | Big_map_t (kt, vt, _), (x : _ big_map) -> ( - match x with + match[@coq_match_gadt] x with | Big_map {id = Some id; diff = {size; _}; _} when Compare.Int.( = ) size 0 -> return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) @@ -5626,7 +5626,7 @@ and[@coq_struct "ctxt"] unparse_code_aux ctxt ~stack_depth mode code = match code with | Prim (loc, I_PUSH, [ty; data], annot) -> parse_packable_ty_aux ctxt ~stack_depth:(stack_depth + 1) ~legacy ty - >>?= fun (Ex_ty t, ctxt) -> + >>?= fun [@coq_match_gadt] (Ex_ty t, ctxt) -> let allow_forged = false (* Forgeable in PUSH data are already forbidden at parsing, @@ -5642,7 +5642,12 @@ and[@coq_struct "ctxt"] unparse_code_aux ctxt ~stack_depth mode code = t data >>=? fun (data, ctxt) -> - unparse_data_aux ctxt ~stack_depth:(stack_depth + 1) mode t data + unparse_data_aux + ctxt + ~stack_depth:(stack_depth + 1) + mode + t + (data [@coq_type_annotation]) >>=? fun (data, ctxt) -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) | Seq (loc, items) -> @@ -5938,7 +5943,7 @@ let rec has_lazy_storage : type t tc. (t, tc) ty -> t has_lazy_storage = *) let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = - let rec aux : + let[@coq_struct "has_lazy_storage_value"] rec aux : type a ac. context -> unparsing_mode -> @@ -5951,9 +5956,11 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = (context * a * Lazy_storage.IdSet.t * Lazy_storage.diffs) tzresult Lwt.t = fun ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage -> Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>?= fun ctxt -> - match (has_lazy_storage, ty, x) with - | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc) - | Big_map_f, Big_map_t (_, _, _), map -> + match[@coq_match_gadt_with_result] [@coq_match_with_default] + (has_lazy_storage, ty, x) + with + | False_f, _, _ -> return (ctxt, x, ids_to_copy, acc) [@coq_type_annotation] + | Big_map_f, Big_map_t (_, _, _), (map : _ big_map) -> diff_of_big_map ctxt mode ~temporary ~ids_to_copy map >|=? fun (diff, id, ctxt) -> let map = @@ -5968,7 +5975,7 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = let diff = Lazy_storage.make Big_map id diff in let ids_to_copy = Lazy_storage.IdSet.add Big_map id ids_to_copy in (ctxt, map, ids_to_copy, diff :: acc) - | Sapling_state_f, Sapling_state_t _, sapling_state -> + | Sapling_state_f, Sapling_state_t _, (sapling_state : Sapling.state) -> diff_of_sapling_state ctxt ~temporary ~ids_to_copy sapling_state >|=? fun (diff, id, ctxt) -> let sapling_state = @@ -5977,22 +5984,48 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = let diff = Lazy_storage.make Sapling_state id diff in let ids_to_copy = Lazy_storage.IdSet.add Sapling_state id ids_to_copy in (ctxt, sapling_state, ids_to_copy, diff :: acc) - | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> + | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ * _) -> + let xl, xr = x in aux ctxt mode ~temporary ids_to_copy acc tyl xl ~has_lazy_storage:hl >>=? fun (ctxt, xl, ids_to_copy, acc) -> aux ctxt mode ~temporary ids_to_copy acc tyr xr ~has_lazy_storage:hr >|=? fun (ctxt, xr, ids_to_copy, acc) -> (ctxt, (xl, xr), ids_to_copy, acc) - | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) - | Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) - | Option_f has_lazy_storage, Option_t (ty, _, _), Some x -> - aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage - >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, Some x, ids_to_copy, acc) - | List_f has_lazy_storage, List_t (ty, _), l -> + | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), + Union_t (tyl, tyr, _, _), + (x : _ union) ) -> ( + match x with + | L x -> + aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyl + x + ~has_lazy_storage:has_lazy_storage_l + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, L x, ids_to_copy, acc) + | R x -> + aux + ctxt + mode + ~temporary + ids_to_copy + acc + tyr + x + ~has_lazy_storage:has_lazy_storage_r + >|=? fun (ctxt, x, ids_to_copy, acc) -> (ctxt, R x, ids_to_copy, acc) + ) + | Option_f has_lazy_storage, Option_t (ty, _, _), (x : _ option) -> ( + match x with + | Some x -> + aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage + >|=? fun (ctxt, x, ids_to_copy, acc) -> + (ctxt, Some x, ids_to_copy, acc) + | None -> return (ctxt, None, ids_to_copy, acc)) + | List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list) -> List.fold_left_es (fun (ctxt, l, ids_to_copy, acc) x -> aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage @@ -6003,7 +6036,7 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = >|=? fun (ctxt, l, ids_to_copy, acc) -> let reversed = {length = l.length; elements = List.rev l.elements} in (ctxt, reversed, ids_to_copy, acc) - | Map_f has_lazy_storage, Map_t (_, ty, _), map -> + | Map_f has_lazy_storage, Map_t (_, ty, _), (map : _ map) -> let (module M) = Script_map.get_module map in let bindings m = M.OPS.fold (fun k v bs -> (k, v) :: bs) m [] in List.fold_left_es @@ -6035,7 +6068,6 @@ let extract_lazy_storage_updates ctxt mode ~temporary ids_to_copy acc ty x = and type value = M.value), ids_to_copy, acc ) - | _, Option_t (_, _, _), None -> return (ctxt, None, ids_to_copy, acc) in let has_lazy_storage = has_lazy_storage ty in aux ctxt mode ~temporary ids_to_copy acc ty x ~has_lazy_storage @@ -6065,32 +6097,52 @@ let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : match[@coq_match_gadt] [@coq_match_with_default] (has_lazy_storage, ty, x) with - | Big_map_f, Big_map_t (_, _, _), Big_map {id = Some id; _} -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) - | Sapling_state_f, Sapling_state_t _, {id = Some id; _} -> - Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> - ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) + | Big_map_f, Big_map_t (_, _, _), (x : _ big_map) -> ( + match x with + | Big_map {id = Some id; _} -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> + ok (f.f Big_map id (Fold_lazy_storage.Ok init), ctxt) + | Big_map {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) + | Sapling_state_f, Sapling_state_t _, (x : Alpha_context.Sapling.state) -> ( + match x with + | {id = Some id; _} -> + Gas.consume ctxt Typecheck_costs.parse_instr_cycle >>? fun ctxt -> + ok (f.f Sapling_state id (Fold_lazy_storage.Ok init), ctxt) + | {id = None; _} -> ok (Fold_lazy_storage.Ok init, ctxt)) | False_f, _, _ -> ok (Fold_lazy_storage.Ok init, ctxt) - | Big_map_f, Big_map_t (_, _, _), Big_map {id = None; _} -> - ok (Fold_lazy_storage.Ok init, ctxt) - | Sapling_state_f, Sapling_state_t _, {id = None; _} -> - ok (Fold_lazy_storage.Ok init, ctxt) - | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (xl, xr) -> ( + | Pair_f (hl, hr), Pair_t (tyl, tyr, _, _), (x : _ pair) -> ( + let xl, xr = x in fold_lazy_storage ~f ~init ctxt tyl xl ~has_lazy_storage:hl >>? fun (init, ctxt) -> match init with | Fold_lazy_storage.Ok init -> fold_lazy_storage ~f ~init ctxt tyr xr ~has_lazy_storage:hr | Fold_lazy_storage.Error -> ok (init, ctxt)) - | Union_f (has_lazy_storage, _), Union_t (ty, _, _, _), L x -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | Union_f (_, has_lazy_storage), Union_t (_, ty, _, _), R x -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | _, Option_t (_, _, _), None -> ok (Fold_lazy_storage.Ok init, ctxt) - | Option_f has_lazy_storage, Option_t (ty, _, _), Some x -> - fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage - | List_f has_lazy_storage, List_t (ty, _), l -> + | ( Union_f (has_lazy_storage_l, has_lazy_storage_r), + Union_t (tyl, tyr, _, _), + (x : _ union) ) -> ( + match x with + | L x -> + fold_lazy_storage + ~f + ~init + ctxt + tyl + x + ~has_lazy_storage:has_lazy_storage_l + | R x -> + fold_lazy_storage + ~f + ~init + ctxt + tyr + x + ~has_lazy_storage:has_lazy_storage_r) + | Option_f has_lazy_storage, Option_t (ty, _, _), (x : _ option) -> ( + match x with + | Some x -> fold_lazy_storage ~f ~init ctxt ty x ~has_lazy_storage + | None -> ok (Fold_lazy_storage.Ok init, ctxt)) + | List_f has_lazy_storage, List_t (ty, _), (l : _ boxed_list) -> List.fold_left_e (fun ((init, ctxt) : ('acc, error) Fold_lazy_storage.result * context) x -> match init with @@ -6099,7 +6151,7 @@ let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : | Fold_lazy_storage.Error -> ok (init, ctxt)) (Fold_lazy_storage.Ok init, ctxt) l.elements - | Map_f has_lazy_storage, Map_t (_, ty, _), m -> + | Map_f has_lazy_storage, Map_t (_, ty, _), (m : _ map) -> Script_map.fold (fun _ v @@ -6115,12 +6167,15 @@ let[@coq_struct "has_lazy_storage_value"] rec fold_lazy_storage : let collect_lazy_storage ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f kind id (acc : (_, never) Fold_lazy_storage.result) = - let acc = match acc with Fold_lazy_storage.Ok acc -> acc in + let acc = + match[@coq_match_with_default] acc with Fold_lazy_storage.Ok acc -> acc + in Fold_lazy_storage.Ok (Lazy_storage.IdSet.add kind id acc) in fold_lazy_storage ~f:{f} ~init:no_lazy_storage_id ctxt ty x ~has_lazy_storage >>? fun (ids, ctxt) -> - match ids with Fold_lazy_storage.Ok ids -> ok (ids, ctxt) + match[@coq_match_with_default] ids with + | Fold_lazy_storage.Ok ids -> ok (ids, ctxt) let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v = @@ -6136,10 +6191,15 @@ let extract_lazy_storage_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v if temporary then diffs else let dead = Lazy_storage.IdSet.diff to_update alive in - Lazy_storage.IdSet.fold_all - {f = (fun kind id acc -> Lazy_storage.make kind id Remove :: acc)} - dead - diffs + let f kind id acc = + (Lazy_storage.make + [@coq_implicit "a" "unit"] [@coq_implicit "u" "unit"]) + kind + id + Remove + :: acc + in + Lazy_storage.IdSet.fold_all {f} dead diffs in match diffs with | [] -> (v, None, ctxt) @@ -6204,8 +6264,8 @@ let get_single_sapling_state ctxt ty x = let has_lazy_storage = has_lazy_storage ty in let f (type i a u) (kind : (i, a, u) Lazy_storage.Kind.t) (id : i) single_id_opt : (Sapling.Id.t option, unit) Fold_lazy_storage.result = - match kind with - | Lazy_storage.Kind.Sapling_state -> ( + match[@coq_match_gadt] (kind, id) with + | Lazy_storage.Kind.Sapling_state, (id : Sapling.Id.t) -> ( match single_id_opt with | Fold_lazy_storage.Ok None -> Fold_lazy_storage.Ok (Some id) | Fold_lazy_storage.Ok (Some _) -> -- GitLab From 73291f04702581026c2f1e09e259aadf43d4305e Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 19 Jul 2022 15:22:56 +0200 Subject: [PATCH 104/105] Proto: better translation to Coq of script files --- .../lib_protocol/michelson_v1_gas.ml | 62 +-- .../lib_protocol/michelson_v1_primitives.ml | 16 +- .../lib_protocol/script_big_map.ml | 62 +-- .../lib_protocol/script_comparable.ml | 84 ++-- .../lib_protocol/script_interpreter_defs.ml | 428 +++++++++--------- .../lib_protocol/script_ir_translator.ml | 8 +- .../lib_protocol/script_typed_ir.ml | 99 ++-- .../lib_protocol/script_typed_ir_size.ml | 3 +- 8 files changed, 398 insertions(+), 364 deletions(-) diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml index 39f89d88f157c..8a6c0bf8d3ade 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml @@ -1380,31 +1380,37 @@ module Cost_of = struct | Compare : 'a Script_typed_ir.comparable_ty * 'a * 'a * cont -> cont | Return : cont - let compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost = - fun ty x y -> - let rec compare : + module Compare = struct + let[@coq_struct "ty_value"] rec compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost -> cont -> cost = fun ty x y acc k -> - match ty with - | Unit_t -> (apply [@tailcall]) Gas.(acc +@ compare_unit) k - | Never_t -> ( match x with _ -> .) - | Bool_t -> (apply [@tailcall]) Gas.(acc +@ compare_bool) k - | String_t -> (apply [@tailcall]) Gas.(acc +@ compare_string x y) k - | Signature_t -> (apply [@tailcall]) Gas.(acc +@ compare_signature) k - | Bytes_t -> (apply [@tailcall]) Gas.(acc +@ compare_bytes x y) k - | Mutez_t -> (apply [@tailcall]) Gas.(acc +@ compare_mutez) k - | Int_t -> (apply [@tailcall]) Gas.(acc +@ compare_int x y) k - | Nat_t -> (apply [@tailcall]) Gas.(acc +@ compare_nat x y) k - | Key_hash_t -> (apply [@tailcall]) Gas.(acc +@ compare_key_hash) k - | Key_t -> (apply [@tailcall]) Gas.(acc +@ compare_key) k - | Timestamp_t -> + match[@coq_match_gadt] [@coq_match_with_default] (ty, x, y) with + | Unit_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_unit) k + | Never_t, _, _ -> . + | Bool_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_bool) k + | String_t, (x : Script_string.t), (y : Script_string.t) -> + (apply [@tailcall]) Gas.(acc +@ compare_string x y) k + | Signature_t, _, _ -> + (apply [@tailcall]) Gas.(acc +@ compare_signature) k + | Bytes_t, (x : bytes), (y : bytes) -> + (apply [@tailcall]) Gas.(acc +@ compare_bytes x y) k + | Mutez_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_mutez) k + | Int_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) Gas.(acc +@ compare_int x y) k + | Nat_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) Gas.(acc +@ compare_nat x y) k + | Key_hash_t, _, _ -> + (apply [@tailcall]) Gas.(acc +@ compare_key_hash) k + | Key_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_key) k + | Timestamp_t, (x : Script_timestamp.t), (y : Script_timestamp.t) -> (apply [@tailcall]) Gas.(acc +@ compare_timestamp x y) k - | Address_t -> (apply [@tailcall]) Gas.(acc +@ compare_address) k - | Tx_rollup_l2_address_t -> + | Address_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_address) k + | Tx_rollup_l2_address_t, _, _ -> (apply [@tailcall]) Gas.(acc +@ compare_tx_rollup_l2_address) k - | Chain_id_t -> (apply [@tailcall]) Gas.(acc +@ compare_chain_id) k - | Pair_t (tl, tr, _, YesYes) -> + | Chain_id_t, _, _ -> + (apply [@tailcall]) Gas.(acc +@ compare_chain_id) k + | Pair_t (tl, tr, _, YesYes), (x : _ * _), (y : _ * _) -> (* Reasonable over-approximation of the cost of lexicographic comparison. *) let xl, xr = x in let yl, yr = y in @@ -1414,7 +1420,9 @@ module Cost_of = struct yl Gas.(acc +@ compare_pair_tag) (Compare (tr, xr, yr, k)) - | Union_t (tl, tr, _, YesYes) -> ( + | ( Union_t (tl, tr, _, YesYes), + (x : _ Script_typed_ir.union), + (y : _ Script_typed_ir.union) ) -> ( match (x, y) with | L x, L y -> (compare [@tailcall]) tl x y Gas.(acc +@ compare_union_tag) k @@ -1422,7 +1430,7 @@ module Cost_of = struct | R _, L _ -> (apply [@tailcall]) Gas.(acc +@ compare_union_tag) k | R x, R y -> (compare [@tailcall]) tr x y Gas.(acc +@ compare_union_tag) k) - | Option_t (t, _, Yes) -> ( + | Option_t (t, _, Yes), (x : _ option), (y : _ option) -> ( match (x, y) with | None, None -> (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k @@ -1432,13 +1440,15 @@ module Cost_of = struct (apply [@tailcall]) Gas.(acc +@ compare_option_tag) k | Some x, Some y -> (compare [@tailcall]) t x y Gas.(acc +@ compare_option_tag) k) - and apply cost k = + + and[@coq_mutual_as_notation] apply cost k = match k with | Compare (ty, x, y, k) -> (compare [@tailcall]) ty x y cost k | Return -> cost - in - compare ty x y Gas.free Return - [@@coq_axiom_with_reason "non top-level mutually recursive function"] + end + + let compare : type a. a Script_typed_ir.comparable_ty -> a -> a -> cost = + fun ty x y -> Compare.compare ty x y Gas.free Return let set_mem (type a) (elt : a) (set : a Script_typed_ir.set) = let open S_syntax in diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index 97464d4f6aee1..a276ff3b819b2 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -551,8 +551,10 @@ let prim_of_string = function else error (Invalid_case n) let prims_of_strings expr = - let rec convert = function - | (Int _ | String _ | Bytes _) as expr -> ok expr + let[@coq_struct "function_parameter"] rec convert = function + | Int (l, z) -> ok (Int (l, z)) + | String (l, s) -> ok (String (l, s)) + | Bytes (l, b) -> ok (Bytes (l, b)) | Prim (loc, prim, args, annot) -> Error_monad.record_trace (Invalid_primitive_name (expr, loc)) @@ -562,12 +564,12 @@ let prims_of_strings expr = | Seq (loc, args) -> List.map_e convert args >|? fun args -> Seq (loc, args) in convert (root expr) >|? fun expr -> strip_locations expr - [@@coq_axiom_with_reason - "implicit type conversion for expr in the constant cases"] let strings_of_prims expr = - let rec convert = function - | (Int _ | String _ | Bytes _) as expr -> expr + let[@coq_struct "function_parameter"] rec convert = function + | Int (l, z) -> Int (l, z) + | String (l, s) -> String (l, s) + | Bytes (l, b) -> Bytes (l, b) | Prim (loc, prim, args, annot) -> let prim = string_of_prim prim in let args = List.map convert args in @@ -577,8 +579,6 @@ let strings_of_prims expr = Seq (loc, args) in strip_locations (convert (root expr)) - [@@coq_axiom_with_reason - "implicit type conversion for expr in the constant cases"] let prim_encoding = let open Data_encoding in diff --git a/src/proto_alpha/lib_protocol/script_big_map.ml b/src/proto_alpha/lib_protocol/script_big_map.ml index cf4f290a8798e..7ed08fb4359b3 100644 --- a/src/proto_alpha/lib_protocol/script_big_map.ml +++ b/src/proto_alpha/lib_protocol/script_big_map.ml @@ -48,39 +48,41 @@ let mem ctxt key (Big_map {id; diff; key_type; _}) = | Some (_, None), _ -> return (false, ctxt) | Some (_, Some _), _ -> return (true, ctxt) -let[@coq_axiom_with_reason "type issues"] get_by_hash ctxt key - (Big_map {id; diff; value_type; _}) = - match (Big_map_overlay.find key diff.map, id) with - | Some (_, x), _ -> return (x, ctxt) - | None, None -> return (None, ctxt) - | None, Some id -> ( - Alpha_context.Big_map.get_opt ctxt id key >>=? function - | ctxt, None -> return (None, ctxt) - | ctxt, Some value -> - parse_data - ctxt - ~legacy:true - ~allow_forged:true - value_type - (Micheline.root value) - >|=? fun (x, ctxt) -> (Some x, ctxt)) +let get_by_hash ctxt key big_map = + match[@coq_match_gadt] big_map with + | Big_map {id; diff; value_type; _} -> ( + match (Big_map_overlay.find key diff.map, id) with + | Some (_, x), _ -> return (x, ctxt) + | None, None -> return (None, ctxt) + | None, Some id -> ( + Alpha_context.Big_map.get_opt ctxt id key >>=? function + | ctxt, None -> return (None, ctxt) + | ctxt, Some value -> + parse_data + ctxt + ~legacy:true + ~allow_forged:true + value_type + (Micheline.root value) + >|=? fun (x, ctxt) -> (Some x, ctxt))) let get ctxt key (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> - get_by_hash ctxt key_hash map + (get_by_hash [@coq_implicit "B" "A"]) ctxt key_hash map -let[@coq_axiom_with_reason "type issues"] update_by_hash key_hash key value - (Big_map map) = - let contains = Big_map_overlay.mem key_hash map.diff.map in - Big_map - { - map with - diff = +let update_by_hash key_hash key value big_map = + match[@coq_match_gadt] big_map with + | Big_map map -> + let contains = Big_map_overlay.mem key_hash map.diff.map in + Big_map { - map = Big_map_overlay.add key_hash (key, value) map.diff.map; - size = (if contains then map.diff.size else map.diff.size + 1); - }; - } + map with + diff = + { + map = Big_map_overlay.add key_hash (key, value) map.diff.map; + size = (if contains then map.diff.size else map.diff.size + 1); + }; + } let update ctxt key value (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> @@ -90,5 +92,5 @@ let update ctxt key value (Big_map {key_type; _} as map) = let get_and_update ctxt key value (Big_map {key_type; _} as map) = hash_comparable_data ctxt key_type key >>=? fun (key_hash, ctxt) -> let new_map = update_by_hash key_hash key value map in - get_by_hash ctxt key_hash map >>=? fun (old_value, ctxt) -> - return ((old_value, new_map), ctxt) + (get_by_hash [@coq_implicit "B" "A"]) ctxt key_hash map + >>=? fun (old_value, ctxt) -> return ((old_value, new_map), ctxt) diff --git a/src/proto_alpha/lib_protocol/script_comparable.ml b/src/proto_alpha/lib_protocol/script_comparable.ml index d570ef9bda766..391495985f44a 100644 --- a/src/proto_alpha/lib_protocol/script_comparable.ml +++ b/src/proto_alpha/lib_protocol/script_comparable.ml @@ -42,46 +42,63 @@ type compare_comparable_cont = -> compare_comparable_cont | Compare_comparable_return : compare_comparable_cont -let compare_comparable : type a. a comparable_ty -> a -> a -> int = - let rec compare_comparable : +module Compare_comparable = struct + let[@coq_struct "kind_value"] rec compare_comparable : type a. a comparable_ty -> compare_comparable_cont -> a -> a -> int = fun kind k x y -> - match (kind, x, y) with - | Unit_t, (), () -> (apply [@tailcall]) 0 k + match[@coq_match_gadt] [@coq_match_with_default] (kind, x, y) with + | Unit_t, _, _ -> (apply [@tailcall]) 0 k | Never_t, _, _ -> . - | Signature_t, x, y -> (apply [@tailcall]) (Script_signature.compare x y) k - | String_t, x, y -> (apply [@tailcall]) (Script_string.compare x y) k - | Bool_t, x, y -> (apply [@tailcall]) (Compare.Bool.compare x y) k - | Mutez_t, x, y -> (apply [@tailcall]) (Tez.compare x y) k - | Key_hash_t, x, y -> + | Signature_t, (x : signature), (y : signature) -> + (apply [@tailcall]) (Script_signature.compare x y) k + | String_t, (x : Script_string.t), (y : Script_string.t) -> + (apply [@tailcall]) (Script_string.compare x y) k + | Bool_t, (x : bool), (y : bool) -> + (apply [@tailcall]) (Compare.Bool.compare x y) k + | Mutez_t, (x : Tez.t), (y : Tez.t) -> + (apply [@tailcall]) (Tez.compare x y) k + | Key_hash_t, (x : public_key_hash), (y : public_key_hash) -> (apply [@tailcall]) (Signature.Public_key_hash.compare x y) k - | Key_t, x, y -> (apply [@tailcall]) (Signature.Public_key.compare x y) k - | Int_t, x, y -> (apply [@tailcall]) (Script_int.compare x y) k - | Nat_t, x, y -> (apply [@tailcall]) (Script_int.compare x y) k - | Timestamp_t, x, y -> (apply [@tailcall]) (Script_timestamp.compare x y) k - | Address_t, x, y -> (apply [@tailcall]) (compare_address x y) k - | Tx_rollup_l2_address_t, x, y -> + | Key_t, (x : public_key), (y : public_key) -> + (apply [@tailcall]) (Signature.Public_key.compare x y) k + | Int_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) (Script_int.compare x y) k + | Nat_t, (x : _ Script_int.num), (y : _ Script_int.num) -> + (apply [@tailcall]) (Script_int.compare x y) k + | Timestamp_t, (x : Script_timestamp.t), (y : Script_timestamp.t) -> + (apply [@tailcall]) (Script_timestamp.compare x y) k + | Address_t, (x : address), (y : address) -> + (apply [@tailcall]) (compare_address x y) k + | ( Tx_rollup_l2_address_t, + (x : tx_rollup_l2_address), + (y : tx_rollup_l2_address) ) -> (apply [@tailcall]) (compare_tx_rollup_l2_address x y) k - | Bytes_t, x, y -> (apply [@tailcall]) (Compare.Bytes.compare x y) k - | Chain_id_t, x, y -> (apply [@tailcall]) (Script_chain_id.compare x y) k - | Pair_t (tl, tr, _, YesYes), (lx, rx), (ly, ry) -> + | Bytes_t, (x : bytes), (y : bytes) -> + (apply [@tailcall]) (Compare.Bytes.compare x y) k + | Chain_id_t, (x : Script_chain_id.t), (y : Script_chain_id.t) -> + (apply [@tailcall]) (Script_chain_id.compare x y) k + | Pair_t (tl, tr, _, YesYes), (x : _ * _), (y : _ * _) -> + let lx, rx = x in + let ly, ry = y in (compare_comparable [@tailcall]) tl (Compare_comparable (tr, rx, ry, k)) lx ly - | Union_t (tl, _, _, YesYes), L x, L y -> - (compare_comparable [@tailcall]) tl k x y - | Union_t _, L _, R _ -> -1 - | Union_t _, R _, L _ -> 1 - | Union_t (_, tr, _, YesYes), R x, R y -> - (compare_comparable [@tailcall]) tr k x y - | Option_t _, None, None -> (apply [@tailcall]) 0 k - | Option_t _, None, Some _ -> -1 - | Option_t _, Some _, None -> 1 - | Option_t (t, _, Yes), Some x, Some y -> - (compare_comparable [@tailcall]) t k x y - and apply ret k = + | Union_t (tl, tr, _, YesYes), (x : (_, _) union), (y : (_, _) union) -> ( + match (x, y) with + | L x, L y -> (compare_comparable [@tailcall]) tl k x y + | L _, R _ -> -1 + | R _, L _ -> 1 + | R x, R y -> (compare_comparable [@tailcall]) tr k x y) + | Option_t (t, _, _), (x : _ option), (y : _ option) -> ( + match (x, y) with + | None, None -> (apply [@tailcall]) 0 k + | None, Some _ -> -1 + | Some _, None -> 1 + | Some x, Some y -> (compare_comparable [@tailcall]) t k x y) + + and[@coq_mutual_as_notation] apply ret k = match (ret, k) with | 0, Compare_comparable (ty, x, y, k) -> (compare_comparable [@tailcall]) ty k x y @@ -89,6 +106,7 @@ let compare_comparable : type a. a comparable_ty -> a -> a -> int = | ret, _ -> (* ret <> 0, we perform an early exit *) if Compare.Int.(ret > 0) then 1 else -1 - in - fun t -> compare_comparable t Compare_comparable_return - [@@coq_axiom_with_reason "non top-level mutually recursive function"] +end + +let compare_comparable : type a. a comparable_ty -> a -> a -> int = + fun t -> Compare_comparable.compare_comparable t Compare_comparable_return diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 7d35b8efc1b49..0bb0033e64388 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -73,289 +73,267 @@ module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter let cost_of_instr : type a s r f. (a, s, r, f) kinstr -> a -> s -> Gas.cost = fun i accu stack -> - match[@coq_match_gadt] [@coq_match_with_default] i with - | IList_map _ -> - let list = accu in - Interp_costs.list_map list - | IList_iter _ -> - let list = accu in - Interp_costs.list_iter list - | ISet_iter _ -> - let set = accu in - Interp_costs.set_iter set - | ISet_mem _ -> - let v = accu and set, _ = stack in + match[@coq_match_gadt] [@coq_match_with_default] (i, accu, stack) with + | IList_map _, (list : _ boxed_list), _ -> Interp_costs.list_map list + | IList_iter _, (list : _ boxed_list), _ -> Interp_costs.list_iter list + | ISet_iter _, (set : _ set), _ -> Interp_costs.set_iter set + | ISet_mem _, v, (stack : _ * _) -> + let set, _ = stack in Interp_costs.set_mem v set - | ISet_update _ -> - let v = accu and _, (set, _) = stack in + | ISet_update _, v, (stack : _ * (_ * _)) -> + let _, (set, _) = stack in Interp_costs.set_update v set - | IMap_map _ -> - let map = accu in - Interp_costs.map_map map - | IMap_iter _ -> - let map = accu in - Interp_costs.map_iter map - | IMap_mem _ -> - let v = accu and map, _ = stack in + | IMap_map _, (map : (_, _) map), _ -> Interp_costs.map_map map + | IMap_iter _, (map : (_, _) map), _ -> Interp_costs.map_iter map + | IMap_mem _, v, (stack : (a, _) map * _) -> + let map, _ = stack in Interp_costs.map_mem v map - | IMap_get _ -> - let v = accu and map, _ = stack in + | IMap_get _, v, (stack : (a, _) map * _) -> + let map, _ = stack in Interp_costs.map_get v map - | IMap_update _ -> - let k = accu and _, (map, _) = stack in + | IMap_update _, k, (stack : _ * ((a, _) map * _)) -> + let _, (map, _) = stack in Interp_costs.map_update k map - | IMap_get_and_update _ -> - let k = accu and _, (map, _) = stack in + | IMap_get_and_update _, k, (stack : _ * ((a, _) map * _)) -> + let _, (map, _) = stack in Interp_costs.map_get_and_update k map - | IBig_map_mem _ -> - let Big_map map, _ = stack in - Interp_costs.big_map_mem map.diff - | IBig_map_get _ -> + | IBig_map_get _, _, (stack : (a, _) big_map * _) -> let Big_map map, _ = stack in Interp_costs.big_map_get map.diff - | IBig_map_update _ -> + | IBig_map_mem _, _, (stack : (a, _) big_map * _) -> + let Big_map map, _ = stack in + Interp_costs.big_map_mem map.diff + | IBig_map_update _, _, (stack : _ * ((a, _) big_map * _)) -> let _, (Big_map map, _) = stack in Interp_costs.big_map_update map.diff - | IBig_map_get_and_update _ -> + | IBig_map_get_and_update _, _, (stack : _ * ((a, _) big_map * _)) -> let _, (Big_map map, _) = stack in Interp_costs.big_map_get_and_update map.diff - | IAdd_seconds_to_timestamp _ -> - let n = accu and t, _ = stack in + | ( IAdd_seconds_to_timestamp _, + (n : _ Script_int.num), + (stack : Script_timestamp.t * _) ) -> + let t, _ = stack in Interp_costs.add_seconds_timestamp n t - | IAdd_timestamp_to_seconds _ -> - let t = accu and n, _ = stack in + | ( IAdd_timestamp_to_seconds _, + (t : Script_timestamp.t), + (stack : _ Script_int.num * _) ) -> + let n, _ = stack in Interp_costs.add_timestamp_seconds t n - | ISub_timestamp_seconds _ -> - let t = accu and n, _ = stack in + | ( ISub_timestamp_seconds _, + (t : Script_timestamp.t), + (stack : _ Script_int.num * _) ) -> + let n, _ = stack in Interp_costs.sub_timestamp_seconds t n - | IDiff_timestamps _ -> - let t1 = accu and t2, _ = stack in + | ( IDiff_timestamps _, + (t1 : Script_timestamp.t), + (stack : Script_timestamp.t * _) ) -> + let t2, _ = stack in Interp_costs.diff_timestamps t1 t2 - | IConcat_string_pair _ -> - let x = accu and y, _ = stack in + | IConcat_string_pair _, (x : Script_string.t), (stack : Script_string.t * _) + -> + let y, _ = stack in Interp_costs.concat_string_pair x y - | IConcat_string _ -> - let ss = accu in + | IConcat_string _, (ss : _ boxed_list), _ -> Interp_costs.concat_string_precheck ss - | ISlice_string _ -> - let _offset = accu in + | ISlice_string _, _offset, (stack : _ Script_int.num * (Script_string.t * _)) + -> let _length, (s, _) = stack in Interp_costs.slice_string s - | IConcat_bytes_pair _ -> - let x = accu and y, _ = stack in + | IConcat_bytes_pair _, (x : bytes), (stack : bytes * _) -> + let y, _ = stack in Interp_costs.concat_bytes_pair x y - | IConcat_bytes _ -> - let ss = accu in + | IConcat_bytes _, (ss : _ boxed_list), _ -> Interp_costs.concat_string_precheck ss - | ISlice_bytes _ -> + | ISlice_bytes _, _, (stack : _ * (bytes * _)) -> let _, (s, _) = stack in Interp_costs.slice_bytes s - | IMul_teznat _ -> Interp_costs.mul_teznat - | IMul_nattez _ -> Interp_costs.mul_nattez - | IAbs_int _ -> - let x = accu in - Interp_costs.abs_int x - | INeg _ -> - let x = accu in - Interp_costs.neg x - | IAdd_int _ -> - let x = accu and y, _ = stack in + | IMul_teznat _, _, _ -> Interp_costs.mul_teznat + | IMul_nattez _, _, _ -> Interp_costs.mul_nattez + | IAbs_int _, (x : _ Script_int.num), _ -> Interp_costs.abs_int x + | INeg _, (x : _ Script_int.num), _ -> Interp_costs.neg x + | IAdd_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.add_int x y - | IAdd_nat _ -> - let x = accu and y, _ = stack in + | IAdd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.add_nat x y - | ISub_int _ -> - let x = accu and y, _ = stack in + | ISub_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.sub_int x y - | IMul_int _ -> - let x = accu and y, _ = stack in + | IMul_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.mul_int x y - | IMul_nat _ -> - let x = accu and y, _ = stack in + | IMul_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.mul_nat x y - | IEdiv_teznat _ -> - let x = accu and y, _ = stack in + | IEdiv_teznat _, x, (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.ediv_teznat x y - | IEdiv_int _ -> - let x = accu and y, _ = stack in + | IEdiv_int _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.ediv_int x y - | IEdiv_nat _ -> - let x = accu and y, _ = stack in + | IEdiv_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.ediv_nat x y - | ILsl_nat _ -> - let x = accu in - Interp_costs.lsl_nat x - | ILsr_nat _ -> - let x = accu in - Interp_costs.lsr_nat x - | IOr_nat _ -> - let x = accu and y, _ = stack in + | ILsl_nat _, (x : _ Script_int.num), _ -> Interp_costs.lsl_nat x + | ILsr_nat _, (x : _ Script_int.num), _ -> Interp_costs.lsr_nat x + | IOr_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.or_nat x y - | IAnd_nat _ -> - let x = accu and y, _ = stack in + | IAnd_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.and_nat x y - | IAnd_int_nat _ -> - let x = accu and y, _ = stack in + | IAnd_int_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.and_int_nat x y - | IXor_nat _ -> - let x = accu and y, _ = stack in + | IXor_nat _, (x : _ Script_int.num), (stack : _ Script_int.num * _) -> + let y, _ = stack in Interp_costs.xor_nat x y - | INot_int _ -> - let x = accu in - Interp_costs.not_int x - | ICompare (_, ty, _) -> - let a = accu and b, _ = stack in + | INot_int _, (x : _ Script_int.num), _ -> Interp_costs.not_int x + | ICompare (_, ty, _), a, (stack : a * _) -> + let b, _ = stack in Interp_costs.compare ty a b - | ICheck_signature _ -> - let key = accu and _, (message, _) = stack in + | ICheck_signature _, (key : public_key), (stack : _ * (bytes * _)) -> + let _, (message, _) = stack in Interp_costs.check_signature key message - | IHash_key _ -> - let pk = accu in - Interp_costs.hash_key pk - | IBlake2b _ -> - let bytes = accu in - Interp_costs.blake2b bytes - | ISha256 _ -> - let bytes = accu in - Interp_costs.sha256 bytes - | ISha512 _ -> - let bytes = accu in - Interp_costs.sha512 bytes - | IKeccak _ -> - let bytes = accu in - Interp_costs.keccak bytes - | ISha3 _ -> - let bytes = accu in - Interp_costs.sha3 bytes - | IPairing_check_bls12_381 _ -> - let pairs = accu in + | IHash_key _, (pk : public_key), _ -> Interp_costs.hash_key pk + | IBlake2b _, (bytes : bytes), _ -> Interp_costs.blake2b bytes + | ISha256 _, (bytes : bytes), _ -> Interp_costs.sha256 bytes + | ISha512 _, (bytes : bytes), _ -> Interp_costs.sha512 bytes + | IKeccak _, (bytes : bytes), _ -> Interp_costs.keccak bytes + | ISha3 _, (bytes : bytes), _ -> Interp_costs.sha3 bytes + | IPairing_check_bls12_381 _, (pairs : _ boxed_list), _ -> Interp_costs.pairing_check_bls12_381 pairs - | ISapling_verify_update _ -> + | ISapling_verify_update _, (accu : Sapling_repr.transaction), _ -> let tx = accu in let inputs = Gas_input_size.sapling_transaction_inputs tx in let outputs = Gas_input_size.sapling_transaction_outputs tx in let bound_data = Gas_input_size.sapling_transaction_bound_data tx in Interp_costs.sapling_verify_update ~inputs ~outputs ~bound_data - | ISapling_verify_update_deprecated _ -> + | ( ISapling_verify_update_deprecated _, + (accu : Sapling_repr.legacy_transaction), + _ ) -> let tx = accu in let inputs = List.length tx.inputs in let outputs = List.length tx.outputs in Interp_costs.sapling_verify_update_deprecated ~inputs ~outputs - | ISplit_ticket _ -> - let ticket = accu and (amount_a, amount_b), _ = stack in + | ISplit_ticket _, (accu : _ ticket), (stack : (_ * _) * _) -> + let ticket = accu in + let (amount_a, amount_b), _ = stack in Interp_costs.split_ticket ticket.amount amount_a amount_b - | IJoin_tickets (_, ty, _) -> - let ticket_a, ticket_b = accu in + | IJoin_tickets (_, ty, _), (ticket_a_b : _ ticket * _ ticket), _ -> + let ticket_a, ticket_b = ticket_a_b in Interp_costs.join_tickets ty ticket_a ticket_b - | IHalt _ -> Interp_costs.halt - | IDrop _ -> Interp_costs.drop - | IDup _ -> Interp_costs.dup - | ISwap _ -> Interp_costs.swap - | IConst _ -> Interp_costs.const - | ICons_some _ -> Interp_costs.cons_some - | ICons_none _ -> Interp_costs.cons_none - | IIf_none _ -> Interp_costs.if_none - | IOpt_map _ -> Interp_costs.opt_map - | ICons_pair _ -> Interp_costs.cons_pair - | IUnpair _ -> Interp_costs.unpair - | ICar _ -> Interp_costs.car - | ICdr _ -> Interp_costs.cdr - | ICons_left _ -> Interp_costs.cons_left - | ICons_right _ -> Interp_costs.cons_right - | IIf_left _ -> Interp_costs.if_left - | ICons_list _ -> Interp_costs.cons_list - | INil _ -> Interp_costs.nil - | IIf_cons _ -> Interp_costs.if_cons - | IList_size _ -> Interp_costs.list_size - | IEmpty_set _ -> Interp_costs.empty_set - | ISet_size _ -> Interp_costs.set_size - | IEmpty_map _ -> Interp_costs.empty_map - | IMap_size _ -> Interp_costs.map_size - | IEmpty_big_map _ -> Interp_costs.empty_big_map - | IString_size _ -> Interp_costs.string_size - | IBytes_size _ -> Interp_costs.bytes_size - | IAdd_tez _ -> Interp_costs.add_tez - | ISub_tez _ -> Interp_costs.sub_tez - | ISub_tez_legacy _ -> Interp_costs.sub_tez_legacy - | IOr _ -> Interp_costs.bool_or - | IAnd _ -> Interp_costs.bool_and - | IXor _ -> Interp_costs.bool_xor - | INot _ -> Interp_costs.bool_not - | IIs_nat _ -> Interp_costs.is_nat - | IInt_nat _ -> Interp_costs.int_nat - | IInt_bls12_381_fr _ -> Interp_costs.int_bls12_381_fr - | IEdiv_tez _ -> Interp_costs.ediv_tez - | IIf _ -> Interp_costs.if_ - | ILoop _ -> Interp_costs.loop - | ILoop_left _ -> Interp_costs.loop_left - | IDip _ -> Interp_costs.dip - | IExec _ -> Interp_costs.exec - | IApply _ -> Interp_costs.apply - | ILambda _ -> Interp_costs.lambda - | IFailwith _ -> Gas.free - | IEq _ -> Interp_costs.eq - | INeq _ -> Interp_costs.neq - | ILt _ -> Interp_costs.lt - | ILe _ -> Interp_costs.le - | IGt _ -> Interp_costs.gt - | IGe _ -> Interp_costs.ge - | IPack _ -> Gas.free - | IUnpack _ -> + | IHalt _, _, _ -> Interp_costs.halt + | IDrop _, _, _ -> Interp_costs.drop + | IDup _, _, _ -> Interp_costs.dup + | ISwap _, _, _ -> Interp_costs.swap + | IConst _, _, _ -> Interp_costs.const + | ICons_some _, _, _ -> Interp_costs.cons_some + | ICons_none _, _, _ -> Interp_costs.cons_none + | IIf_none _, _, _ -> Interp_costs.if_none + | IOpt_map _, _, _ -> Interp_costs.opt_map + | ICons_pair _, _, _ -> Interp_costs.cons_pair + | IUnpair _, _, _ -> Interp_costs.unpair + | ICar _, _, _ -> Interp_costs.car + | ICdr _, _, _ -> Interp_costs.cdr + | ICons_left _, _, _ -> Interp_costs.cons_left + | ICons_right _, _, _ -> Interp_costs.cons_right + | IIf_left _, _, _ -> Interp_costs.if_left + | ICons_list _, _, _ -> Interp_costs.cons_list + | INil _, _, _ -> Interp_costs.nil + | IIf_cons _, _, _ -> Interp_costs.if_cons + | IList_size _, _, _ -> Interp_costs.list_size + | IEmpty_set _, _, _ -> Interp_costs.empty_set + | ISet_size _, _, _ -> Interp_costs.set_size + | IEmpty_map _, _, _ -> Interp_costs.empty_map + | IMap_size _, _, _ -> Interp_costs.map_size + | IEmpty_big_map _, _, _ -> Interp_costs.empty_big_map + | IString_size _, _, _ -> Interp_costs.string_size + | IBytes_size _, _, _ -> Interp_costs.bytes_size + | IAdd_tez _, _, _ -> Interp_costs.add_tez + | ISub_tez _, _, _ -> Interp_costs.sub_tez + | ISub_tez_legacy _, _, _ -> Interp_costs.sub_tez_legacy + | IOr _, _, _ -> Interp_costs.bool_or + | IAnd _, _, _ -> Interp_costs.bool_and + | IXor _, _, _ -> Interp_costs.bool_xor + | INot _, _, _ -> Interp_costs.bool_not + | IIs_nat _, _, _ -> Interp_costs.is_nat + | IInt_nat _, _, _ -> Interp_costs.int_nat + | IInt_bls12_381_fr _, _, _ -> Interp_costs.int_bls12_381_fr + | IEdiv_tez _, _, _ -> Interp_costs.ediv_tez + | IIf _, _, _ -> Interp_costs.if_ + | ILoop _, _, _ -> Interp_costs.loop + | ILoop_left _, _, _ -> Interp_costs.loop_left + | IDip _, _, _ -> Interp_costs.dip + | IExec _, _, _ -> Interp_costs.exec + | IApply _, _, _ -> Interp_costs.apply + | ILambda _, _, _ -> Interp_costs.lambda + | IFailwith _, _, _ -> Gas.free + | IEq _, _, _ -> Interp_costs.eq + | INeq _, _, _ -> Interp_costs.neq + | ILt _, _, _ -> Interp_costs.lt + | ILe _, _, _ -> Interp_costs.le + | IGt _, _, _ -> Interp_costs.gt + | IGe _, _, _ -> Interp_costs.ge + | IPack _, _, _ -> Gas.free + | IUnpack _, (accu : bytes), _ -> let b = accu in Interp_costs.unpack b - | IAddress _ -> Interp_costs.address - | IContract _ -> Interp_costs.contract - | ITransfer_tokens _ -> Interp_costs.transfer_tokens - | IView _ -> Interp_costs.view - | IImplicit_account _ -> Interp_costs.implicit_account - | ISet_delegate _ -> Interp_costs.set_delegate - | IBalance _ -> Interp_costs.balance - | ILevel _ -> Interp_costs.level - | INow _ -> Interp_costs.now - | IMin_block_time _ -> Interp_costs.min_block_time - | ISapling_empty_state _ -> Interp_costs.sapling_empty_state - | ISource _ -> Interp_costs.source - | ISender _ -> Interp_costs.sender - | ISelf _ -> Interp_costs.self - | ISelf_address _ -> Interp_costs.self_address - | IAmount _ -> Interp_costs.amount - | IDig (_, n, _, _) -> Interp_costs.dign n - | IDug (_, n, _, _) -> Interp_costs.dugn n - | IDipn (_, n, _, _, _) -> Interp_costs.dipn n - | IDropn (_, n, _, _) -> Interp_costs.dropn n - | IChainId _ -> Interp_costs.chain_id - | ICreate_contract _ -> Interp_costs.create_contract - | INever _ -> ( match accu with _ -> .) - | IVoting_power _ -> Interp_costs.voting_power - | ITotal_voting_power _ -> Interp_costs.total_voting_power - | IAdd_bls12_381_g1 _ -> Interp_costs.add_bls12_381_g1 - | IAdd_bls12_381_g2 _ -> Interp_costs.add_bls12_381_g2 - | IAdd_bls12_381_fr _ -> Interp_costs.add_bls12_381_fr - | IMul_bls12_381_g1 _ -> Interp_costs.mul_bls12_381_g1 - | IMul_bls12_381_g2 _ -> Interp_costs.mul_bls12_381_g2 - | IMul_bls12_381_fr _ -> Interp_costs.mul_bls12_381_fr - | INeg_bls12_381_g1 _ -> Interp_costs.neg_bls12_381_g1 - | INeg_bls12_381_g2 _ -> Interp_costs.neg_bls12_381_g2 - | INeg_bls12_381_fr _ -> Interp_costs.neg_bls12_381_fr - | IMul_bls12_381_fr_z _ -> + | IAddress _, _, _ -> Interp_costs.address + | IContract _, _, _ -> Interp_costs.contract + | ITransfer_tokens _, _, _ -> Interp_costs.transfer_tokens + | IView _, _, _ -> Interp_costs.view + | IImplicit_account _, _, _ -> Interp_costs.implicit_account + | ISet_delegate _, _, _ -> Interp_costs.set_delegate + | IBalance _, _, _ -> Interp_costs.balance + | ILevel _, _, _ -> Interp_costs.level + | INow _, _, _ -> Interp_costs.now + | IMin_block_time _, _, _ -> Interp_costs.min_block_time + | ISapling_empty_state _, _, _ -> Interp_costs.sapling_empty_state + | ISource _, _, _ -> Interp_costs.source + | ISender _, _, _ -> Interp_costs.sender + | ISelf _, _, _ -> Interp_costs.self + | ISelf_address _, _, _ -> Interp_costs.self_address + | IAmount _, _, _ -> Interp_costs.amount + | IDig (_, n, _, _), _, _ -> Interp_costs.dign n + | IDug (_, n, _, _), _, _ -> Interp_costs.dugn n + | IDipn (_, n, _, _, _), _, _ -> Interp_costs.dipn n + | IDropn (_, n, _, _), _, _ -> Interp_costs.dropn n + | IChainId _, _, _ -> Interp_costs.chain_id + | ICreate_contract _, _, _ -> Interp_costs.create_contract + | INever _, _, _ -> . + | IVoting_power _, _, _ -> Interp_costs.voting_power + | ITotal_voting_power _, _, _ -> Interp_costs.total_voting_power + | IAdd_bls12_381_g1 _, _, _ -> Interp_costs.add_bls12_381_g1 + | IAdd_bls12_381_g2 _, _, _ -> Interp_costs.add_bls12_381_g2 + | IAdd_bls12_381_fr _, _, _ -> Interp_costs.add_bls12_381_fr + | IMul_bls12_381_g1 _, _, _ -> Interp_costs.mul_bls12_381_g1 + | IMul_bls12_381_g2 _, _, _ -> Interp_costs.mul_bls12_381_g2 + | IMul_bls12_381_fr _, _, _ -> Interp_costs.mul_bls12_381_fr + | INeg_bls12_381_g1 _, _, _ -> Interp_costs.neg_bls12_381_g1 + | INeg_bls12_381_g2 _, _, _ -> Interp_costs.neg_bls12_381_g2 + | INeg_bls12_381_fr _, _, _ -> Interp_costs.neg_bls12_381_fr + | IMul_bls12_381_fr_z _, (accu : _ Script_int.num), _ -> let z = accu in Interp_costs.mul_bls12_381_fr_z z - | IMul_bls12_381_z_fr _ -> + | IMul_bls12_381_z_fr _, _, (stack : _ Script_int.num * _) -> let z, _ = stack in Interp_costs.mul_bls12_381_z_fr z - | IDup_n (_, n, _, _) -> Interp_costs.dupn n - | IComb (_, n, _, _) -> Interp_costs.comb n - | IUncomb (_, n, _, _) -> Interp_costs.uncomb n - | IComb_get (_, n, _, _) -> Interp_costs.comb_get n - | IComb_set (_, n, _, _) -> Interp_costs.comb_set n - | ITicket _ -> Interp_costs.ticket - | IRead_ticket _ -> Interp_costs.read_ticket - | IOpen_chest _ -> - let _chest_key = accu and chest, (time, _) = stack in + | IDup_n (_, n, _, _), _, _ -> Interp_costs.dupn n + | IComb (_, n, _, _), _, _ -> Interp_costs.comb n + | IUncomb (_, n, _, _), _, _ -> Interp_costs.uncomb n + | IComb_get (_, n, _, _), _, _ -> Interp_costs.comb_get n + | IComb_set (_, n, _, _), _, _ -> Interp_costs.comb_set n + | ITicket _, _, _ -> Interp_costs.ticket + | IRead_ticket _, _, _ -> Interp_costs.read_ticket + | ( IOpen_chest _, + _chest_key, + (stack : Script_timelock.chest * (_ Script_int.num * _)) ) -> + let chest, (time, _) = stack in Interp_costs.open_chest ~chest ~time:(Script_int.to_zint time) - | ILog _ -> Gas.free + | ILog _, _, _ -> Gas.free [@@ocaml.inline always] - [@@coq_axiom_with_reason "unreachable expression `.` not handled"] let cost_of_control : type a s r f. (a, s, r, f) continuation -> Gas.cost = fun ks -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 622d6c37e1658..6009a0171a596 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -168,7 +168,7 @@ let unparse_memo_size ~loc memo_size = let z = Sapling.Memo_size.unparse_to_z memo_size in Int (loc, z) -let[@coq_struct "ty"] rec unparse_ty_and_entrypoints_uncarbonated : +let[@coq_struct "ty_value"] rec unparse_ty_and_entrypoints_uncarbonated : type a ac loc. loc:loc -> (a, ac) ty -> a entrypoints_node -> loc Script.michelson_node = fun ~loc ty {nested = nested_entrypoints; at_node} -> @@ -277,7 +277,7 @@ let[@coq_struct "ty"] rec unparse_ty_and_entrypoints_uncarbonated : in Prim (loc, name, args, annot) -and[@coq_struct "ty"] unparse_comparable_ty_uncarbonated : +and[@coq_struct "ty_value"] unparse_comparable_ty_uncarbonated : type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = fun ~loc ty -> unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints @@ -532,7 +532,7 @@ let comb_witness2 : | Pair_t _ -> Comb_Pair Comb_Any | _ -> Comb_Any -let[@coq_struct "ty"] rec unparse_comparable_data : +let[@coq_struct "ty_value"] rec unparse_comparable_data : type a loc. loc:loc -> context -> @@ -1702,7 +1702,7 @@ let find_entrypoint (type full fullc error_context error_trace) (full : (full, fullc) ty) (entrypoints : full entrypoints) entrypoint : (full ex_ty_cstr, error_trace) Gas_monad.t = let open Gas_monad.Syntax in - let[@coq_struct "ty"] rec find_entrypoint : + let[@coq_struct "ty_value"] rec find_entrypoint : type t tc. (t, tc) ty -> t entrypoints_node -> diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 3647b228454d8..c15ecdad5e276 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -2201,7 +2201,7 @@ let kinstr_traverse i init f = type 'a ty_traverse = {apply : 't 'tc. 'a -> ('t, 'tc) ty -> 'a} -let ty_traverse = +module Ty_traverse = struct let rec aux : type ret t tc accu. accu ty_traverse -> accu -> (t, tc) ty -> (accu -> ret) -> ret = @@ -2232,6 +2232,7 @@ let ty_traverse = (aux [@ocaml.tailcall]) f accu cty (fun accu -> (next [@ocaml.tailcall]) f accu ty1 continue) | Contract_t (ty1, _) -> (next [@ocaml.tailcall]) f accu ty1 continue + and[@coq_mutual_as_notation] next2 : type a ac b bc ret accu. accu ty_traverse -> @@ -2244,15 +2245,16 @@ let ty_traverse = (aux [@ocaml.tailcall]) f accu ty1 (fun accu -> (aux [@ocaml.tailcall]) f accu ty2 (fun accu -> (continue [@ocaml.tailcall]) accu)) + and[@coq_mutual_as_notation] next : type a ac ret accu. accu ty_traverse -> accu -> (a, ac) ty -> (accu -> ret) -> ret = fun f accu ty1 continue -> (aux [@ocaml.tailcall]) f accu ty1 (fun accu -> (continue [@ocaml.tailcall]) accu) - in - fun ty init f -> aux f init ty (fun accu -> accu) - [@@coq_axiom_with_reason "local mutually recursive definition not handled"] +end + +let ty_traverse ty init f = Ty_traverse.aux f init ty (fun accu -> accu) type 'accu stack_ty_traverse = { apply : 'ty 's. 'accu -> ('ty, 's) stack_ty -> 'accu; @@ -2269,78 +2271,103 @@ let stack_ty_traverse (type a t) (sty : (a, t) stack_ty) init f = type 'a value_traverse = {apply : 't 'tc. 'a -> ('t, 'tc) ty -> 't -> 'a} -let value_traverse (type t tc) (ty : (t, tc) ty) (x : t) init f = - let rec aux : type ret t tc. 'accu -> (t, tc) ty -> t -> ('accu -> ret) -> ret +module Value_traverse = struct + let[@coq_struct "ty_value"] rec aux : + type ret t tc. + 'accu value_traverse -> 'accu -> (t, tc) ty -> t -> ('accu -> ret) -> ret = - fun accu ty x continue -> + fun f accu ty x continue -> let accu = f.apply accu ty x in let next2 ty1 ty2 x1 x2 = - (aux [@ocaml.tailcall]) accu ty1 x1 (fun accu -> - (aux [@ocaml.tailcall]) accu ty2 x2 (fun accu -> + (aux [@ocaml.tailcall]) f accu ty1 x1 (fun accu -> + (aux [@ocaml.tailcall]) f accu ty2 x2 (fun accu -> (continue [@ocaml.tailcall]) accu)) in let next ty1 x1 = - (aux [@ocaml.tailcall]) accu ty1 x1 (fun accu -> + (aux [@ocaml.tailcall]) f accu ty1 x1 (fun accu -> (continue [@ocaml.tailcall]) accu) in let return () = (continue [@ocaml.tailcall]) accu in let rec on_list ty' accu = function | [] -> (continue [@ocaml.tailcall]) accu | x :: xs -> - (aux [@ocaml.tailcall]) accu ty' x (fun accu -> + (aux [@ocaml.tailcall]) f accu ty' x (fun accu -> (on_list [@ocaml.tailcall]) ty' accu xs) in - match ty with - | Unit_t | Int_t | Nat_t | Signature_t | String_t | Bytes_t | Mutez_t - | Key_hash_t | Key_t | Timestamp_t | Address_t | Tx_rollup_l2_address_t - | Bool_t | Sapling_transaction_t _ | Sapling_transaction_deprecated_t _ - | Sapling_state_t _ | Operation_t | Chain_id_t | Never_t | Bls12_381_g1_t - | Bls12_381_g2_t | Bls12_381_fr_t | Chest_key_t | Chest_t - | Lambda_t (_, _, _) -> + match[@coq_match_gadt] (ty, x) with + | Unit_t, _ + | Int_t, _ + | Nat_t, _ + | Signature_t, _ + | String_t, _ + | Bytes_t, _ + | Mutez_t, _ + | Key_hash_t, _ + | Key_t, _ + | Timestamp_t, _ + | Address_t, _ + | Tx_rollup_l2_address_t, _ + | Bool_t, _ + | Sapling_transaction_t _, _ + | Sapling_transaction_deprecated_t _, _ + | Sapling_state_t _, _ + | Operation_t, _ + | Chain_id_t, _ + | Never_t, _ + | Bls12_381_g1_t, _ + | Bls12_381_g2_t, _ + | Bls12_381_fr_t, _ + | Chest_key_t, _ + | Chest_t, _ + | Lambda_t (_, _, _), _ -> (return [@ocaml.tailcall]) () - | Pair_t (ty1, ty2, _, _) -> + | Pair_t (ty1, ty2, _, _), (x : _ * _) -> (next2 [@ocaml.tailcall]) ty1 ty2 (fst x) (snd x) - | Union_t (ty1, ty2, _, _) -> ( + | Union_t (ty1, ty2, _, _), (x : _ union) -> ( match x with | L l -> (next [@ocaml.tailcall]) ty1 l | R r -> (next [@ocaml.tailcall]) ty2 r) - | Option_t (ty, _, _) -> ( + | Option_t (ty, _, _), (x : _ option) -> ( match x with | None -> return () | Some v -> (next [@ocaml.tailcall]) ty v) - | Ticket_t (cty, _) -> (aux [@ocaml.tailcall]) accu cty x.contents continue - | List_t (ty', _) -> on_list ty' accu x.elements - | Map_t (kty, ty', _) -> + | Ticket_t (cty, _), (x : _ ticket) -> + (aux [@ocaml.tailcall]) f accu cty x.contents continue + | List_t (ty', _), (x : _ boxed_list) -> on_list ty' accu x.elements + | Map_t (kty, ty', _), (x : _ map) -> let (Map_tag (module M)) = x in let bindings = M.OPS.fold (fun k v bs -> (k, v) :: bs) M.boxed [] in - on_bindings accu kty ty' continue bindings - | Set_t (ty', _) -> + on_bindings f accu kty ty' continue bindings + | Set_t (ty', _), (x : _ set) -> let (Set_tag (module M)) = x in let elements = M.OPS.fold (fun x s -> x :: s) M.boxed [] in on_list ty' accu elements - | Big_map_t (_, _, _) -> + | Big_map_t (_, _, _), _ -> (* For big maps, there is no obvious recursion scheme so we delegate this case to the client. *) (return [@ocaml.tailcall]) () - | Contract_t (_, _) -> (return [@ocaml.tailcall]) () - and on_bindings : + | Contract_t (_, _), _ -> (return [@ocaml.tailcall]) () + + and[@coq_struct "xs"] on_bindings : type ret k v vc. + 'accu value_traverse -> 'accu -> k comparable_ty -> (v, vc) ty -> ('accu -> ret) -> (k * v) list -> ret = - fun accu kty ty' continue xs -> + fun f accu kty ty' continue xs -> match xs with | [] -> (continue [@ocaml.tailcall]) accu | (k, v) :: xs -> - (aux [@ocaml.tailcall]) accu kty k (fun accu -> - (aux [@ocaml.tailcall]) accu ty' v (fun accu -> - (on_bindings [@ocaml.tailcall]) accu kty ty' continue xs)) - in - aux init ty x (fun accu -> accu) - [@@coq_axiom_with_reason "local mutually recursive definition not handled"] + (aux [@ocaml.tailcall]) f accu kty k (fun accu -> + (aux [@ocaml.tailcall]) f accu ty' v (fun accu -> + (on_bindings [@ocaml.tailcall]) f accu kty ty' continue xs)) +end + +let value_traverse (type t tc) (ty : (t, tc) ty) (x : t) init f = + Value_traverse.aux f init ty x (fun accu -> accu) let stack_top_ty : type a b s. (a, b * s) stack_ty -> a ty_ex_c = function[@coq_match_with_default] diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 75b85a322d47f..04cefa4509c20 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -204,7 +204,7 @@ let kinfo_size {iloc = _; kstack_ty = _} = h2w tail-recursive and the only recursive call that is not a tailcall cannot be nested. (See [big_map_size].) For this reason, these functions should not trigger stack overflows. *) -let[@coq_struct "ty"] rec value_size_aux : +let[@coq_struct "ty_value"] rec value_size_aux : type a ac. count_lambda_nodes:bool -> nodes_and_size -> @@ -285,7 +285,6 @@ let[@coq_struct "ty"] rec value_size_aux : ret_succ_adding accu (chest_size x) in value_traverse ty x accu {apply} - [@@coq_axiom_with_reason "unreachable expressions '.' not handled for now"] and[@coq_mutual_as_notation] big_map_size_aux : type a b bc. -- GitLab From 689d86e7f40abfe78c68c2381e3af3f24327e781 Mon Sep 17 00:00:00 2001 From: Guillaume Claret Date: Tue, 2 Aug 2022 10:04:32 +0200 Subject: [PATCH 105/105] Proto: have error_context as a non-GADT parameter for Coq --- src/proto_alpha/lib_protocol/script_tc_errors.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_tc_errors.ml b/src/proto_alpha/lib_protocol/script_tc_errors.ml index 1f0c39d222b8b..13c4404495e29 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors.ml @@ -210,6 +210,6 @@ the error will be ignored later. For example, when types are compared during the interpretation of the [CONTRACT] instruction any error will lead to returning [None] but the content of the error will be ignored. *) -type (_, _) error_details = +type ('error_context, _) error_details = | Informative : 'error_context -> ('error_context, error trace) error_details - | Fast : (_, inconsistent_types_fast_error) error_details + | Fast : ('error_context, inconsistent_types_fast_error) error_details -- GitLab