diff --git a/devtools/get_contracts/contract_size.ml b/devtools/get_contracts/contract_size.ml new file mode 100644 index 0000000000000000000000000000000000000000..77516a17337821cd1425f7fa57273446426653e0 --- /dev/null +++ b/devtools/get_contracts/contract_size.ml @@ -0,0 +1,41 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* *) +(* 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 t = {expected : int; actual : int} + +let zero = {expected = 0; actual = 0} + +let add a b = {expected = a.expected + b.expected; actual = a.actual + b.actual} + +let pp fmt {expected; actual} = + Format.fprintf fmt "Expected size: %d bytes@\n" expected ; + Format.fprintf fmt "Real measured size: %d bytes@\n" actual ; + if actual > expected then + let diff = actual - expected in + let percentage = 100.0 *. float_of_int diff /. float_of_int expected in + Format.fprintf + fmt + "WARNING: Real size exceeds expectation by %.2f%%!@\n" + percentage diff --git a/devtools/get_contracts/dune b/devtools/get_contracts/dune index 3541cef7657468b17f61a71738f7952b19249bcc..68747a00bceb719cc7740263913f6559b773b014 100644 --- a/devtools/get_contracts/dune +++ b/devtools/get_contracts/dune @@ -14,7 +14,7 @@ -open Tezos_micheline -open Tezos_base.TzPervasives -open Tezos_stdlib_unix) - (modules get_contracts sigs storage_helpers)) + (modules get_contracts sigs storage_helpers contract_size)) (executable (name get_contracts_012_Psithaca) diff --git a/devtools/get_contracts/get_contracts.ml b/devtools/get_contracts/get_contracts.ml index 7f78ff04318684386e7dd5ff9b43241d389ad27a..9367aa3062230ab2b7138a33b1fad35a874bfee6 100644 --- a/devtools/get_contracts/get_contracts.ml +++ b/devtools/get_contracts/get_contracts.ml @@ -28,6 +28,8 @@ module Config = struct let collect_lambdas = true + let measure_code_size = true + let mainnet_genesis = { Genesis.time = Time.Protocol.of_notation_exn "2018-06-30T16:07:32Z"; @@ -57,6 +59,12 @@ let mkdir dirname = module Make (P : Sigs.PROTOCOL) : Sigs.MAIN = struct module ExprMap = Map.Make (P.Script.Hash) + type contract = { + script : P.Script.expr; + addresses : P.Contract.repr list; + storages : P.Script.expr ExprMap.t; + } + module File_helpers = struct let print_to_file ?err filename fmt = Format.kasprintf @@ -306,7 +314,7 @@ module Make (P : Sigs.PROTOCOL) : Sigs.MAIN = struct in match code_opt with | None -> Lwt.return (m, i) (* Should not happen *) - | Some code -> + | Some script -> let+ add_storage = if Config.(collect_lambdas || collect_storage) then let+ storage_opt = @@ -324,18 +332,18 @@ module Make (P : Sigs.PROTOCOL) : Sigs.MAIN = struct fun storages -> ExprMap.add key storage storages else Lwt.return (fun x -> x) in - let key = hash_expr code in + let key = hash_expr script in ( ExprMap.update key (fun existing -> let contracts, storages = match existing with - | Some (_code, contracts, storages) -> (contracts, storages) + | Some {addresses; storages; _} -> (addresses, storages) | None -> ([], ExprMap.empty) in - let contracts = contract :: contracts in + let addresses = contract :: contracts in let storages = add_storage storages in - Some (code, contracts, storages)) + Some {script; addresses; storages}) m, i ) end @@ -353,6 +361,48 @@ module Make (P : Sigs.PROTOCOL) : Sigs.MAIN = struct let* _ctxt, values = P.Storage.list_values ctxt_i in List.fold_left_es (fun acc v -> f v acc) init values + let output_contract_results ctxt output_dir hash ctr total_size = + let open Lwt_result_syntax in + let hash_string = P.Script.Hash.to_b58check hash in + File_helpers.print_expr_file + ~dirname:output_dir + ~ext:".tz" + ~hash_string + ctr.script ; + let filename ~ext = + Filename.concat output_dir (Format.sprintf "%s.%s" hash_string ext) + in + File_helpers.print_to_file + (filename ~ext:"address") + "%a" + (Format.pp_print_list ~pp_sep:Format.pp_print_newline P.Contract.pp) + ctr.addresses ; + let* contract_size = + if Config.measure_code_size then ( + let* script_code = + P.Translator.parse_code ctxt ~legacy:true + @@ P.Script.lazy_expr ctr.script + in + let size = + Contract_size. + { + expected = P.Translator.expected_code_size script_code; + actual = P.Translator.actual_code_size script_code; + } + in + File_helpers.print_to_file + (filename ~ext:"size") + "%a" + Contract_size.pp + size ; + return size) + else return Contract_size.zero + in + (if Config.collect_storage then + let dirname = Filename.concat output_dir (hash_string ^ ".storage") in + File_helpers.print_expr_dir ~dirname ~ext:".storage" ctr.storages) ; + return @@ Contract_size.add contract_size total_size + let main ~output_dir ctxt ~head : unit tzresult Lwt.t = let open Lwt_result_syntax in let head_hash, head_level = Tezos_store.Store.Block.descriptor head in @@ -388,7 +438,7 @@ module Make (P : Sigs.PROTOCOL) : Sigs.MAIN = struct print_endline "Getting expressions from contracts..." ; let* exprs = ExprMap.fold_es - (fun hash (script, _contracts, storages) exprs -> + (fun hash {script; storages; _} exprs -> let exprs = ExprMap.add hash (script, false, ExprMap.empty) exprs in @@ -449,28 +499,18 @@ module Make (P : Sigs.PROTOCOL) : Sigs.MAIN = struct else return (contract_map, (ExprMap.empty, ExprMap.empty, ExprMap.empty)) in print_endline "Writing contract files..." ; - ExprMap.iter - (fun hash (script, contracts, storages) -> - let hash_string = P.Script.Hash.to_b58check hash in - File_helpers.print_expr_file - ~dirname:output_dir - ~ext:".tz" - ~hash_string - script ; - let filename = - Filename.concat output_dir (hash_string ^ ".addresses") - in - File_helpers.print_to_file - filename - "%a" - (Format.pp_print_list ~pp_sep:Format.pp_print_newline P.Contract.pp) - contracts ; - if Config.collect_storage then - let dirname = Filename.concat output_dir (hash_string ^ ".storage") in - File_helpers.print_expr_dir ~dirname ~ext:".storage" storages - else ()) - contract_map ; + let* total_ir_size = + ExprMap.fold_es + (output_contract_results ctxt output_dir) + contract_map + Contract_size.zero + in print_endline "Done writing contract files." ; + if Config.measure_code_size then + Format.printf + "@[Total IR size:@;%a@]@." + Contract_size.pp + total_ir_size ; let () = if not (ExprMap.is_empty lambda_map) then ( print_endline "Writing lambda files..." ; diff --git a/devtools/get_contracts/get_contracts_012_Psithaca.ml b/devtools/get_contracts/get_contracts_012_Psithaca.ml index 4155af2943f0d74aa4d2f9064e11a0395dbb6a9a..dd9af043782b954c48bc222255f14610d1fe56d7 100644 --- a/devtools/get_contracts/get_contracts_012_Psithaca.ml +++ b/devtools/get_contracts/get_contracts_012_Psithaca.ml @@ -65,7 +65,13 @@ module Proto = struct type ex_ty = Script_ir_translator.ex_ty - type type_logger = Script_ir_translator.type_logger + type ex_code = Script_ir_translator.ex_code + + let expected_code_size Script_ir_translator.(Ex_code {code_size; _}) = + Obj.magic code_size + + let actual_code_size Script_ir_translator.(Ex_code {code; _}) = + 8 * Obj.(reachable_words @@ repr code) let parse_ty (ctxt : Raw_context.t) ~legacy ~allow_lazy_storage ~allow_operation ~allow_contract ~allow_ticket script = @@ -113,6 +119,14 @@ module Proto = struct @@ Script_ir_translator.parse_toplevel (Obj.magic ctxt) ~legacy expr in toplevel + + let parse_code ctxt ~legacy code = + let open Lwt_result_syntax in + let+ parsed_code, _ = + Lwt.map wrap_tzresult + @@ Script_ir_translator.parse_code (Obj.magic ctxt) ~legacy ~code + in + parsed_code end module Storage = struct diff --git a/devtools/get_contracts/get_contracts_013_PtJakart.ml b/devtools/get_contracts/get_contracts_013_PtJakart.ml index ef61c920eea0330c2d7ea425b84a95c70bc00bf1..24bc0f5bebb967f7397978b9a00c16683059b027 100644 --- a/devtools/get_contracts/get_contracts_013_PtJakart.ml +++ b/devtools/get_contracts/get_contracts_013_PtJakart.ml @@ -65,7 +65,14 @@ module Proto = struct type ex_ty = Script_ir_translator.ex_ty - type type_logger = Script_ir_translator.type_logger + type ex_code = Script_ir_translator.ex_code + + let expected_code_size Script_ir_translator.(Ex_code (Code {code_size; _})) + = + Obj.magic code_size + + let actual_code_size Script_ir_translator.(Ex_code (Code {code; _})) = + 8 * Obj.(reachable_words @@ repr code) let parse_ty (ctxt : Raw_context.t) ~legacy ~allow_lazy_storage ~allow_operation ~allow_contract ~allow_ticket script = @@ -113,6 +120,14 @@ module Proto = struct @@ Script_ir_translator.parse_toplevel (Obj.magic ctxt) ~legacy expr in toplevel + + let parse_code ctxt ~legacy code = + let open Lwt_result_syntax in + let+ parsed_code, _ = + Lwt.map wrap_tzresult + @@ Script_ir_translator.parse_code (Obj.magic ctxt) ~legacy ~code + in + parsed_code end module Storage = struct diff --git a/devtools/get_contracts/get_contracts_014_PtKathma.ml b/devtools/get_contracts/get_contracts_014_PtKathma.ml index 92447dd9fdc65e60a338a10a26e6928980a536f1..75ba10925c0a511a040899d598feeb22b753204f 100644 --- a/devtools/get_contracts/get_contracts_014_PtKathma.ml +++ b/devtools/get_contracts/get_contracts_014_PtKathma.ml @@ -67,7 +67,14 @@ module Proto = struct type ex_ty = Script_ir_translator.ex_ty - type type_logger = Script_ir_translator.type_logger + type ex_code = Script_ir_translator.ex_code + + let expected_code_size Script_ir_translator.(Ex_code (Code {code_size; _})) + = + Obj.magic code_size + + let actual_code_size Script_ir_translator.(Ex_code (Code {code; _})) = + 8 * Obj.(reachable_words @@ repr code) let parse_ty (ctxt : Raw_context.t) ~legacy ~allow_lazy_storage ~allow_operation ~allow_contract ~allow_ticket script = @@ -115,6 +122,14 @@ module Proto = struct @@ Script_ir_translator.parse_toplevel (Obj.magic ctxt) ~legacy expr in toplevel + + let parse_code ctxt ~legacy code = + let open Lwt_result_syntax in + let+ parsed_code, _ = + Lwt.map wrap_tzresult + @@ Script_ir_translator.parse_code (Obj.magic ctxt) ~legacy ~code + in + parsed_code end module Storage = struct diff --git a/devtools/get_contracts/get_contracts_alpha.ml b/devtools/get_contracts/get_contracts_alpha.ml index 92447dd9fdc65e60a338a10a26e6928980a536f1..75ba10925c0a511a040899d598feeb22b753204f 100644 --- a/devtools/get_contracts/get_contracts_alpha.ml +++ b/devtools/get_contracts/get_contracts_alpha.ml @@ -67,7 +67,14 @@ module Proto = struct type ex_ty = Script_ir_translator.ex_ty - type type_logger = Script_ir_translator.type_logger + type ex_code = Script_ir_translator.ex_code + + let expected_code_size Script_ir_translator.(Ex_code (Code {code_size; _})) + = + Obj.magic code_size + + let actual_code_size Script_ir_translator.(Ex_code (Code {code; _})) = + 8 * Obj.(reachable_words @@ repr code) let parse_ty (ctxt : Raw_context.t) ~legacy ~allow_lazy_storage ~allow_operation ~allow_contract ~allow_ticket script = @@ -115,6 +122,14 @@ module Proto = struct @@ Script_ir_translator.parse_toplevel (Obj.magic ctxt) ~legacy expr in toplevel + + let parse_code ctxt ~legacy code = + let open Lwt_result_syntax in + let+ parsed_code, _ = + Lwt.map wrap_tzresult + @@ Script_ir_translator.parse_code (Obj.magic ctxt) ~legacy ~code + in + parsed_code end module Storage = struct diff --git a/devtools/get_contracts/sigs.ml b/devtools/get_contracts/sigs.ml index 5d2640a51128b94465e6b17c01110450d217a8c3..9bf9b4d0a075b15b5540a5a432a566483d0396a1 100644 --- a/devtools/get_contracts/sigs.ml +++ b/devtools/get_contracts/sigs.ml @@ -58,6 +58,8 @@ module type PROTOCOL = sig val expr_encoding : expr Data_encoding.t + val lazy_expr : expr -> lazy_expr + val print_expr : Format.formatter -> expr -> unit module Hash : sig @@ -92,7 +94,11 @@ module type PROTOCOL = sig type ex_ty - type type_logger + type ex_code + + val actual_code_size : ex_code -> int + + val expected_code_size : ex_code -> int val parse_ty : context -> @@ -108,6 +114,9 @@ module type PROTOCOL = sig val parse_toplevel : context -> legacy:bool -> Script.expr -> toplevel tzresult Lwt.t + + val parse_code : + context -> legacy:bool -> Script.lazy_expr -> ex_code tzresult Lwt.t end module Storage : sig diff --git a/manifest/main.ml b/manifest/main.ml index 8966dc596dd4a3778a810bb9fe84ccc7e0d0b2da..e668f8d1e94ec4e1ff06082237b75bc1623ac776 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -4614,7 +4614,7 @@ let get_contracts_lib = octez_client_base_unix; octez_store; ] - ~modules:["get_contracts"; "sigs"; "storage_helpers"] + ~modules:["get_contracts"; "sigs"; "storage_helpers"; "contract_size"] ~static:false ~release:false ~bisect_ppx:false