From c691068209da0d57371e6044720500f168ca60f7 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Mon, 18 Jun 2018 13:24:16 +0200 Subject: [PATCH] Michelson: change semantics of CONCAT --- src/bin_client/test/contracts/concat.tz | 11 +++++------ src/bin_client/test/contracts/concat_hello.tz | 5 ++++- src/bin_client/test/contracts/concat_list.tz | 2 +- src/bin_client/test/contracts/exec_concat.tz | 4 +++- src/bin_client/test/contracts/list_iter2.tz | 4 +--- src/bin_client/test/test_contracts.sh | 4 ++-- .../lib_protocol/src/michelson_v1_gas.ml | 9 +++++++-- .../lib_protocol/src/michelson_v1_gas.mli | 2 +- .../lib_protocol/src/script_interpreter.ml | 6 ++++-- .../lib_protocol/src/script_ir_translator.ml | 15 +++++++-------- .../lib_protocol/src/script_typed_ir.ml | 2 +- 11 files changed, 36 insertions(+), 28 deletions(-) diff --git a/src/bin_client/test/contracts/concat.tz b/src/bin_client/test/contracts/concat.tz index 34aafed9a..26814afca 100644 --- a/src/bin_client/test/contracts/concat.tz +++ b/src/bin_client/test/contracts/concat.tz @@ -1,8 +1,7 @@ parameter string; storage string; -code {DUP; # We're going to need both the storage and parameter - CAR; # Get the parameter - DIP{CDR}; # Get the storage value - SWAP; # Get the order we want (this is optional) - CONCAT; # Concatenate the strings - NIL operation; PAIR} # Match the calling convention +code { DUP; + DIP { CDR ; NIL string ; SWAP ; CONS } ; + CAR ; CONS ; + CONCAT; + NIL operation; PAIR} diff --git a/src/bin_client/test/contracts/concat_hello.tz b/src/bin_client/test/contracts/concat_hello.tz index e290b90fb..338c856c5 100644 --- a/src/bin_client/test/contracts/concat_hello.tz +++ b/src/bin_client/test/contracts/concat_hello.tz @@ -1,4 +1,7 @@ parameter (list string); storage (list string); code{ CAR; - MAP { PUSH @hello string "Hello "; CONCAT }; NIL operation; PAIR}; + MAP { NIL string ; SWAP ; CONS ; + PUSH @hello string "Hello "; CONS ; + CONCAT }; + NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/concat_list.tz b/src/bin_client/test/contracts/concat_list.tz index f805d1b16..b570027ff 100644 --- a/src/bin_client/test/contracts/concat_list.tz +++ b/src/bin_client/test/contracts/concat_list.tz @@ -1,5 +1,5 @@ parameter (list string); storage string; code {CAR; PUSH string ""; SWAP; - ITER {SWAP; CONCAT}; + ITER {SWAP; DIP{NIL string; SWAP; CONS}; CONS; CONCAT}; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/exec_concat.tz b/src/bin_client/test/contracts/exec_concat.tz index 6828a52fc..0265f1557 100644 --- a/src/bin_client/test/contracts/exec_concat.tz +++ b/src/bin_client/test/contracts/exec_concat.tz @@ -1,5 +1,7 @@ parameter string; storage string; code {CAR; - LAMBDA string string {PUSH string "_abc"; SWAP; CONCAT}; + LAMBDA string string + {PUSH string "_abc"; NIL string ; + SWAP ; CONS ; SWAP ; CONS ; CONCAT}; SWAP; EXEC; NIL operation; PAIR}; diff --git a/src/bin_client/test/contracts/list_iter2.tz b/src/bin_client/test/contracts/list_iter2.tz index caf3e5771..d7bfb7d13 100644 --- a/src/bin_client/test/contracts/list_iter2.tz +++ b/src/bin_client/test/contracts/list_iter2.tz @@ -1,5 +1,3 @@ parameter (list string); storage string; -code { CAR; PUSH string ""; SWAP; - ITER { CONCAT }; - NIL operation; PAIR} +code { UNPAIR ; SWAP ; CONS ; CONCAT; NIL operation; PAIR} diff --git a/src/bin_client/test/test_contracts.sh b/src/bin_client/test/test_contracts.sh index 2f70690ef..6596da926 100755 --- a/src/bin_client/test/test_contracts.sh +++ b/src/bin_client/test/test_contracts.sh @@ -114,8 +114,8 @@ assert_storage $contract_dir/list_map_block.tz '{0}' '{ 1 ; 2 ; 3 ; 0 }' '{ 1 ; assert_storage $contract_dir/list_iter.tz 0 '{ 10 ; 2 ; 1 }' 20 assert_storage $contract_dir/list_iter.tz 0 '{ 3 ; 6 ; 9 }' 162 -assert_storage $contract_dir/list_iter2.tz '"?"' '{ "a" ; "b" ; "c" }' '"cba"' -assert_storage $contract_dir/list_iter2.tz '"?"' '{}' '""' +assert_storage $contract_dir/list_iter2.tz '"abc"' '{ "d" ; "e" ; "f" }' '"abcdef"' +assert_storage $contract_dir/list_iter2.tz '"abc"' '{}' '"abc"' # Identity on sets diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml index c7454495c..caee17d83 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.ml @@ -53,8 +53,13 @@ module Cost_of = struct let zint z = alloc_bits_cost (Z.numbits z) - let concat s1 s2 = - string (String.length s1 + String.length s2) + let concat cost length ss = + let rec cum acc = function + | [] -> acc + | s :: ss -> cum (cost (length s) +@ acc) ss in + cum free ss + + let concat_string ss = concat string String.length ss (* Cost per cycle of a loop, fold, etc *) let loop_cycle = step_cost 2 diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli index 06eb3c491..1ba1bd217 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_gas.mli @@ -38,7 +38,7 @@ module Cost_of : sig val cons : Gas.cost val variant_no_data : Gas.cost val branch : Gas.cost - val concat : string -> string -> Gas.cost + val concat_string : string list -> Gas.cost val map_mem : 'a -> ('b, 'c) Script_typed_ir.map -> Gas.cost val map_to_list : diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index b36de4035..bb758aecf 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -415,8 +415,10 @@ let rec interp consume_gas_binop descr (Script_timestamp.diff, t1, t2) Interp_costs.diff_timestamps rest ctxt (* string operations *) - | Concat, Item (x, Item (y, rest)) -> - consume_gas_binop descr ((^), x, y) Interp_costs.concat rest ctxt + | Concat, Item (ss, rest) -> + Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss)) >>=? fun ctxt -> + let s = String.concat "" ss in + logged_return (Item (s, rest), ctxt) (* currency operations *) | Add_tez, Item (x, Item (y, rest)) -> Lwt.return (Gas.consume ctxt Interp_costs.int64_op) >>=? fun ctxt -> diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml index 7580adddc..553db4628 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -2111,9 +2111,8 @@ and parse_instr (Item_t (Int_t tname, rest, annot)) (* string operations *) | Prim (loc, I_CONCAT, [], annot), - Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) -> - parse_var_annot loc annot >>=? fun annot -> - Lwt.return @@ merge_type_annot tn1 tn2 >>=? fun tname -> + Item_t (List_t (String_t tname, _), rest, list_annot) -> + parse_var_annot ~default:list_annot loc annot >>=? fun annot -> typed ctxt loc Concat (Item_t (String_t tname, rest, annot)) (* currency operations *) @@ -2611,10 +2610,10 @@ and parse_instr get_toplevel_type tc_context (* Primitive parsing errors *) | Prim (loc, (I_DROP | I_DUP | I_SWAP | I_SOME | I_UNIT - | I_PAIR | I_CAR | I_CDR | I_CONS + | I_PAIR | I_CAR | I_CDR | I_CONS | I_CONCAT | I_MEM | I_UPDATE | I_MAP | I_GET | I_EXEC | I_FAILWITH | I_SIZE - | I_CONCAT | I_ADD | I_SUB + | I_ADD | I_SUB | I_MUL | I_EDIV | I_OR | I_AND | I_XOR | I_NOT | I_ABS | I_NEG | I_LSL | I_LSR @@ -2643,12 +2642,12 @@ and parse_instr (* Stack errors *) | Prim (loc, (I_ADD | I_SUB | I_MUL | I_EDIV | I_AND | I_OR | I_XOR | I_LSL | I_LSR - | I_CONCAT | I_COMPARE as name), [], _), + | I_COMPARE as name), [], _), Item_t (ta, Item_t (tb, _, _), _) -> Lwt.return @@ serialize_ty_for_error ctxt ta >>=? fun (ta, ctxt) -> Lwt.return @@ serialize_ty_for_error ctxt tb >>=? fun (tb, _ctxt) -> fail (Undefined_binop (loc, name, ta, tb)) - | Prim (loc, (I_NEG | I_ABS | I_NOT + | Prim (loc, (I_NEG | I_ABS | I_NOT | I_CONCAT | I_EQ | I_NEQ | I_LT | I_GT | I_LE | I_GE as name), [], _), Item_t (t, _, _) -> @@ -2683,7 +2682,7 @@ and parse_instr | I_GET | I_MEM | I_EXEC | I_CHECK_SIGNATURE | I_ADD | I_SUB | I_MUL | I_EDIV | I_AND | I_OR | I_XOR - | I_LSL | I_LSR | I_CONCAT as name), _, _), + | I_LSL | I_LSR as name), _, _), stack -> serialize_stack_for_error ctxt stack >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 2, stack)) diff --git a/src/proto_alpha/lib_protocol/src/script_typed_ir.ml b/src/proto_alpha/lib_protocol/src/script_typed_ir.ml index 761307cde..ef824c5b4 100644 --- a/src/proto_alpha/lib_protocol/src/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/src/script_typed_ir.ml @@ -203,7 +203,7 @@ and ('bef, 'aft) instr = ('key * ('value option * (('key, 'value) big_map * 'rest)), ('key, 'value) big_map * 'rest) instr (* string operations *) | Concat : - (string * (string * 'rest), string * 'rest) instr + (string list * 'rest, string * 'rest) instr (* timestamp operations *) | Add_seconds_to_timestamp : (z num * (Script_timestamp.t * 'rest),