From e0b486077cafc45fd3d63f9f1342a957fb6938bb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 14 Mar 2023 22:49:46 +0100 Subject: [PATCH 1/4] Proto/Michelson: Refactor elaboration of lists This commit should have no visible effect; in particular list element are still processed in the same order. --- src/proto_alpha/lib_protocol/script_ir_translator.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 567717c31fc9..e8934803b388 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2121,12 +2121,12 @@ let rec parse_data : (* Lists *) | List_t (t, _ty_name), Seq (_loc, items) -> traced - @@ List.fold_right_es - (fun v (rest, ctxt) -> + @@ List.fold_left_es + (fun (rest, ctxt) v -> non_terminal_recursion ctxt t v >|=? fun (v, ctxt) -> (Script_list.cons v rest, ctxt)) - items (Script_list.empty, ctxt) + (List.rev items) | List_t _, expr -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Tickets *) -- GitLab From 2b6d4fe3f554ee3174a275a5a432a0990628797b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 21 Mar 2023 14:37:14 +0100 Subject: [PATCH 2/4] Proto/Migration: Refactor patching of scripts Iterate in the opposite order. --- src/proto_alpha/lib_protocol/init_storage.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml index 0ea2a0baeaed..de27a6071d35 100644 --- a/src/proto_alpha/lib_protocol/init_storage.ml +++ b/src/proto_alpha/lib_protocol/init_storage.ml @@ -59,7 +59,7 @@ let invoice_contract ctxt ~address ~amount_mutez = See !3730 for an example. *) -let patch_script (address, hash, patched_code) ctxt = +let patch_script ctxt (address, hash, patched_code) = Contract_repr.of_b58check address >>?= fun contract -> Storage.Contract.Code.find ctxt contract >>=? fun (ctxt, code_opt) -> Logging.log Notice "Patching %s... " address ; @@ -174,7 +174,7 @@ let prepare_first_block _chain_id ctxt ~typecheck ~level ~timestamp ~predecessor let ctxt = Sc_rollup_inbox_storage.add_protocol_migration ctxt in return (ctxt, [])) >>=? fun (ctxt, balance_updates) -> - List.fold_right_es patch_script Legacy_script_patches.addresses_to_patch ctxt + List.fold_left_es patch_script ctxt Legacy_script_patches.addresses_to_patch >>=? fun ctxt -> Receipt_repr.group_balance_updates balance_updates >>?= fun balance_updates -> Storage.Pending_migration.Balance_updates.add ctxt balance_updates -- GitLab From da1b22f2c9aaee9a7c7275cd81a62afc5de89db8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 21 Mar 2023 14:40:03 +0100 Subject: [PATCH 3/4] Proto/Sapling: Refactor iterations --- src/proto_alpha/lib_protocol/sapling_storage.ml | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/src/proto_alpha/lib_protocol/sapling_storage.ml b/src/proto_alpha/lib_protocol/sapling_storage.ml index e043a080a46f..ec4bc18af523 100644 --- a/src/proto_alpha/lib_protocol/sapling_storage.ml +++ b/src/proto_alpha/lib_protocol/sapling_storage.ml @@ -259,20 +259,17 @@ module Nullifiers = struct let mem ctx id nf = Storage.Sapling.Nullifiers_hashed.mem (ctx, id) nf (* Allows for duplicates as they are already checked by verify_update before - updating the state. - Not tail-recursive so we put a hard limit on the size of the - list of nullifiers. *) + updating the state. *) let add ctx id nfs = - assert (Compare.Int.(List.compare_length_with nfs 1000 <= 0)) ; size ctx id >>=? fun nf_start_pos -> - List.fold_right_es - (fun nf (ctx, pos, acc_size) -> + List.fold_left_es + (fun (ctx, pos, acc_size) nf -> Storage.Sapling.Nullifiers_hashed.init (ctx, id) nf >>=? fun (ctx, size) -> Storage.Sapling.Nullifiers_ordered.init (ctx, id) pos nf >|=? fun ctx -> (ctx, Int64.succ pos, Z.add acc_size (Z.of_int size))) - nfs (ctx, nf_start_pos, Z.zero) + (List.rev nfs) >>=? fun (ctx, nf_end_pos, size) -> Storage.Sapling.Nullifiers_size.update (ctx, id) nf_end_pos >|=? fun ctx -> (ctx, size) @@ -405,12 +402,12 @@ let apply_diff ctx id diff = (ctx, id) (Int64.add cm_start_pos (Int64.of_int nb_commitments)) >>=? fun ctx -> - List.fold_right_es - (fun (_cm, cp) (ctx, pos, acc_size) -> + List.fold_left_es + (fun (ctx, pos, acc_size) (_cm, cp) -> Ciphertexts.add ctx id cp pos >|=? fun (ctx, size) -> (ctx, Int64.succ pos, Z.add acc_size (Z.of_int size))) - diff.commitments_and_ciphertexts (ctx, cm_start_pos, Z.of_int size) + (List.rev diff.commitments_and_ciphertexts) >>=? fun (ctx, _ct_end_pos, size) -> Nullifiers.add ctx id diff.nullifiers >>=? fun (ctx, size_nf) -> let size = Z.add size size_nf in -- GitLab From c04e16ffb8cd9f7ea1bded2ddbf28e6a14d47088 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Tue, 21 Mar 2023 15:05:35 +0100 Subject: [PATCH 4/4] Environment: remove fold_right and its variants --- src/lib_protocol_environment/sigs/v9.ml | 64 ------------------- src/lib_protocol_environment/sigs/v9/list.mli | 64 ------------------- 2 files changed, 128 deletions(-) diff --git a/src/lib_protocol_environment/sigs/v9.ml b/src/lib_protocol_environment/sigs/v9.ml index ef0cd1df6681..a6f2acd1782a 100644 --- a/src/lib_protocol_environment/sigs/v9.ml +++ b/src/lib_protocol_environment/sigs/v9.ml @@ -6504,11 +6504,6 @@ end {3 Special considerations} - Because they traverse the list from right-to-left, the {!fold_right2} - function and all its variants fail with [when_different_lengths] before any - of the processing starts. Whilst this is still within the fail-early - behaviour, it may be surprising enough that it requires mentioning here. - Because they may return early, {!for_all2} and {!exists2} and all their variants may return [Ok _] even though the arguments have different lengths. *) @@ -6788,21 +6783,6 @@ val fold_left2 : 'c list -> ('a, 'trace) result -(** [fold_right2 ~when_different_lengths f xs ys init] is - [f x0 y0 (f x1 y1 (…))]. - - This function is not tail-recursive. - - Note that unlike the left-to-right double-list traversors, [fold_right2] - only calls [f] if the lists are of the same length. *) -val fold_right2 : - when_different_lengths:'trace -> - ('a -> 'b -> 'c -> 'c) -> - 'a list -> - 'b list -> - 'c -> - ('c, 'trace) result - (** [for_all2 ~when_different_lengths f xs ys] is [f x0 y0 && f x1 y1 && …]. @@ -7416,23 +7396,6 @@ val fold_left_i_es : 'b list -> ('a, 'trace) result Lwt.t -(** This function is not tail-recursive *) -val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b - -(** This function is not tail-recursive *) -val fold_right_e : - ('a -> 'b -> ('b, 'trace) result) -> 'a list -> 'b -> ('b, 'trace) result - -(** This function is not tail-recursive *) -val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t - -(** This function is not tail-recursive *) -val fold_right_es : - ('a -> 'b -> ('b, 'trace) result Lwt.t) -> - 'a list -> - 'b -> - ('b, 'trace) result Lwt.t - (** {3 Double-traversal variants} As mentioned above, there are no [_p] and [_ep] double-traversors. Use @@ -7525,33 +7488,6 @@ val fold_left2_es : 'c list -> ('a, 'trace) result Lwt.t -(** This function is not tail-recursive *) -val fold_right2_e : - when_different_lengths:'trace -> - ('a -> 'b -> 'c -> ('c, 'trace) result) -> - 'a list -> - 'b list -> - 'c -> - ('c, 'trace) result - -(** This function is not tail-recursive *) -val fold_right2_s : - when_different_lengths:'trace -> - ('a -> 'b -> 'c -> 'c Lwt.t) -> - 'a list -> - 'b list -> - 'c -> - ('c, 'trace) result Lwt.t - -(** This function is not tail-recursive *) -val fold_right2_es : - when_different_lengths:'trace -> - ('a -> 'b -> 'c -> ('c, 'trace) result Lwt.t) -> - 'a list -> - 'b list -> - 'c -> - ('c, 'trace) result Lwt.t - (** {3 Scanning variants} *) val for_all : ('a -> bool) -> 'a list -> bool diff --git a/src/lib_protocol_environment/sigs/v9/list.mli b/src/lib_protocol_environment/sigs/v9/list.mli index 63298a2f4ba1..44c21e554e43 100644 --- a/src/lib_protocol_environment/sigs/v9/list.mli +++ b/src/lib_protocol_environment/sigs/v9/list.mli @@ -72,11 +72,6 @@ {3 Special considerations} - Because they traverse the list from right-to-left, the {!fold_right2} - function and all its variants fail with [when_different_lengths] before any - of the processing starts. Whilst this is still within the fail-early - behaviour, it may be surprising enough that it requires mentioning here. - Because they may return early, {!for_all2} and {!exists2} and all their variants may return [Ok _] even though the arguments have different lengths. *) @@ -356,21 +351,6 @@ val fold_left2 : 'c list -> ('a, 'trace) result -(** [fold_right2 ~when_different_lengths f xs ys init] is - [f x0 y0 (f x1 y1 (…))]. - - This function is not tail-recursive. - - Note that unlike the left-to-right double-list traversors, [fold_right2] - only calls [f] if the lists are of the same length. *) -val fold_right2 : - when_different_lengths:'trace -> - ('a -> 'b -> 'c -> 'c) -> - 'a list -> - 'b list -> - 'c -> - ('c, 'trace) result - (** [for_all2 ~when_different_lengths f xs ys] is [f x0 y0 && f x1 y1 && …]. @@ -984,23 +964,6 @@ val fold_left_i_es : 'b list -> ('a, 'trace) result Lwt.t -(** This function is not tail-recursive *) -val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b - -(** This function is not tail-recursive *) -val fold_right_e : - ('a -> 'b -> ('b, 'trace) result) -> 'a list -> 'b -> ('b, 'trace) result - -(** This function is not tail-recursive *) -val fold_right_s : ('a -> 'b -> 'b Lwt.t) -> 'a list -> 'b -> 'b Lwt.t - -(** This function is not tail-recursive *) -val fold_right_es : - ('a -> 'b -> ('b, 'trace) result Lwt.t) -> - 'a list -> - 'b -> - ('b, 'trace) result Lwt.t - (** {3 Double-traversal variants} As mentioned above, there are no [_p] and [_ep] double-traversors. Use @@ -1093,33 +1056,6 @@ val fold_left2_es : 'c list -> ('a, 'trace) result Lwt.t -(** This function is not tail-recursive *) -val fold_right2_e : - when_different_lengths:'trace -> - ('a -> 'b -> 'c -> ('c, 'trace) result) -> - 'a list -> - 'b list -> - 'c -> - ('c, 'trace) result - -(** This function is not tail-recursive *) -val fold_right2_s : - when_different_lengths:'trace -> - ('a -> 'b -> 'c -> 'c Lwt.t) -> - 'a list -> - 'b list -> - 'c -> - ('c, 'trace) result Lwt.t - -(** This function is not tail-recursive *) -val fold_right2_es : - when_different_lengths:'trace -> - ('a -> 'b -> 'c -> ('c, 'trace) result Lwt.t) -> - 'a list -> - 'b list -> - 'c -> - ('c, 'trace) result Lwt.t - (** {3 Scanning variants} *) val for_all : ('a -> bool) -> 'a list -> bool -- GitLab