diff --git a/.gitlab/ci/test/unit.yml b/.gitlab/ci/test/unit.yml index 112d90221ceede1b4c57e438418dca75136c5c65..3c243879edfb66932aea049ad1777c65a40f8af3 100644 --- a/.gitlab/ci/test/unit.yml +++ b/.gitlab/ci/test/unit.yml @@ -156,6 +156,7 @@ unit:alpha: proto_alpha__lib_protocol__3: > @src/proto_alpha/lib_protocol/test/pbt/runtest @src/proto_alpha/lib_protocol/test/unit/runtest + @src/proto_alpha/lib_protocol/runtezt proto_alpha: > @src/proto_alpha/lib_benchmark/runtest @src/proto_alpha/lib_client/runtest diff --git a/devtools/get_contracts/get_contracts_alpha.ml b/devtools/get_contracts/get_contracts_alpha.ml index 96322276d1a93efc9c538377acbd1dbd3995e47b..b7019e80238b6abb8303c945670a964d32061296 100644 --- a/devtools/get_contracts/get_contracts_alpha.ml +++ b/devtools/get_contracts/get_contracts_alpha.ml @@ -169,7 +169,9 @@ module Proto = struct ('a, _) Script_typed_ir.ty * ('a -> ex_lambda list) list -> ex_ty_lambdas - let lam_node (Ex_lambda (_, Lam (_, node))) = node + let lam_node node = + match node with + | Ex_lambda (_, Lam (_, node)) | Ex_lambda (_, LamRec (_, node)) -> node let rec find_lambda_tys : type a c. (a, c) Script_typed_ir.ty -> (a -> ex_lambda list) list = diff --git a/docs/alpha/michelson.rst b/docs/alpha/michelson.rst index 6b5d875efdf524725e333d6aaad21882a460bb6e..9d37863c945bd29eaa72ce1a2c5bf6f77d10f31a 100644 --- a/docs/alpha/michelson.rst +++ b/docs/alpha/michelson.rst @@ -707,6 +707,18 @@ Stack operations > LAMBDA _ _ code / S => code : S +- ``LAMBDA_REC 'a 'b code``: Push a lambda with itself on top of the + code, recursively, with the given parameter type `'a` and return + a value of type `'b` onto the stack (if it terminates before gas + exhaustion). + +:: + + :: 'A -> (lambda 'a 'b) : 'A + iff code::'a: (lambda 'a 'b):[] -> 'b:[] + + > LAMBDA_REC 'a 'b code / S => {LAMBDA_REC 'a 'b code; code} : S + Generic comparison ~~~~~~~~~~~~~~~~~~ @@ -1419,7 +1431,7 @@ Operations on maps > UPDATE / x : Some y : {} : S => { Elt x y } : S > UPDATE / x : opt_y : { Elt k v ; } : S => { Elt k v ; } : S iff COMPARE / x : k : [] => 1 : [] - where UPDATE / x : opt_y : { } : S => { } : S + where UPDATE / x : opt_y : { } : S => { } : S > UPDATE / x : None : { Elt k v ; } : S => { } : S iff COMPARE / x : k : [] => 0 : [] > UPDATE / x : Some y : { Elt k v ; } : S => { Elt k y ; } : S @@ -1445,7 +1457,7 @@ value that was previously stored in the ``map`` at the same key as > GET_AND_UPDATE / x : Some y : {} : S => None : { Elt x y } : S > GET_AND_UPDATE / x : opt_y : { Elt k v ; } : S => opt_y' : { Elt k v ; } : S iff COMPARE / x : k : [] => 1 : [] - where GET_AND_UPDATE / x : opt_y : { } : S => opt_y' : { } : S + where GET_AND_UPDATE / x : opt_y : { } : S => opt_y' : { } : S > GET_AND_UPDATE / x : None : { Elt k v ; } : S => Some v : { } : S iff COMPARE / x : k : [] => 0 : [] > GET_AND_UPDATE / x : Some y : { Elt k v ; } : S => Some v : { Elt k y ; } : S @@ -2350,7 +2362,7 @@ Events See :doc:`Event ` for more information. :: - + :: 'ty : 'S -> operation : 'S @@ -2944,6 +2956,7 @@ The instructions which accept at most one variable annotation are: UPDATE GET LAMBDA + LAMBDA_REC EXEC ADD SUB @@ -3511,6 +3524,49 @@ entrypoint, of type ``unit`` will reset it to ``0``. { DROP ; DROP ; PUSH int 0 } ; NIL operation ; PAIR } } + +Example contract with recursive lambda +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The following contract computes the factorial of the given parameter +using a recursive function and then saves the result in the storage. + +In Michelson regular functions start with a stack containing a single +value, the function argument. If the function is of type ``lambda int +int``, when calling the function the stack will have just an +``int``. Recursive functions start with two values, the argument and +the function itself. Therefore, if the recursive function is of type +``lambda int int`` then, when it is being called, the stack will have +an ``int`` at the top and a ``lambda int int`` at the bottom. + +In this recursive factorial we can see the first branch of the ``IF``, +this is the base case. The second one performs the recursive call. To +do that, we need to access the function. This is what the ``DUP 3`` +instruction does. Then we decrement the argument and finally make the +recursive call with ``EXEC``. + +:: + + { parameter int; + storage int; + code { CAR ; + LAMBDA_REC int int + { DUP; + EQ; + IF { PUSH int 1 } + { DUP; + DUP 3; + PUSH int 1; + DUP 4; + SUB; + EXEC; + MUL}; + DIP { DROP 2 }}; + SWAP; + EXEC; + NIL operation; + PAIR}} + Multisig contract ~~~~~~~~~~~~~~~~~ @@ -3639,6 +3695,7 @@ Full grammar | Right | Some | None + | Lambda_rec | { ; ... } | { Elt ; ... } | instruction @@ -3701,6 +3758,7 @@ Full grammar | LOOP { ... } | LOOP_LEFT { ... } | LAMBDA { ... } + | LAMBDA_REC { ... } | EXEC | APPLY | DIP { ... } diff --git a/docs/protocols/alpha.rst b/docs/protocols/alpha.rst index c8b5a5edbd62dadf4f57946a664982b5ad040a41..d52de031988698493c0bd4239e2b5440d6a21454 100644 --- a/docs/protocols/alpha.rst +++ b/docs/protocols/alpha.rst @@ -81,6 +81,8 @@ Minor Changes ------------- - Split internal transactions. (MR :gl:`!5585`) +- Add a new LAMBDA_REC instruction to create recursive lambda functions. (MR + :gl:`!5194`) - Rename error ``Previously_revealed_nonce`` in ``Already_revealed_nonce`` (MR :gl:`!5849`) diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 80323ac05ecd0eb0ad91160be91032464121bcd3..5af948d4b0fd9cdd490c35312e8c6030967a4ee9 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -745,7 +745,8 @@ module Scripts = struct | IDip _ -> pp_print_string fmt "DIP" | IExec _ -> pp_print_string fmt "EXEC" | IApply _ -> pp_print_string fmt "APPLY" - | ILambda _ -> pp_print_string fmt "LAMBDA" + | ILambda (_, Lam _, _) -> pp_print_string fmt "LAMBDA" + | ILambda (_, LamRec _, _) -> pp_print_string fmt "LAMBDA_REC" | IFailwith _ -> pp_print_string fmt "FAILWITH" | ICompare _ -> pp_print_string fmt "COMPARE" | IEq _ -> pp_print_string fmt "EQ" diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index e3a9aa8b803ed32ded95b0d0ca7e6192e18b4c0a..8dfdd9cddf77ba5c0470fa9c85f59db947e54946 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -532,6 +532,7 @@ module Script : sig | D_Some | D_True | D_Unit + | D_Lambda_rec | I_PACK | I_UNPACK | I_BLAKE2B @@ -575,6 +576,7 @@ module Script : sig | I_IF_NONE | I_INT | I_LAMBDA + | I_LAMBDA_REC | I_LE | I_LEFT | I_LEVEL diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index 44c0bf47d21b8734685b631e725f45521bd99c22..118f5df397c8b77738d798093762e6044af90818 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -48,6 +48,7 @@ type prim = | D_Some | D_True | D_Unit + | D_Lambda_rec | I_PACK | I_UNPACK | I_BLAKE2B @@ -91,6 +92,7 @@ type prim = | I_IF_NONE | I_INT | I_LAMBDA + | I_LAMBDA_REC | I_LE | I_LEFT | I_LEVEL @@ -200,7 +202,7 @@ type namespace = let namespace = function | K_code | K_view | K_parameter | K_storage -> Keyword_namespace | D_Elt | D_False | D_Left | D_None | D_Pair | D_Right | D_Some | D_True - | D_Unit -> + | D_Unit | D_Lambda_rec -> Constant_namespace | I_ABS | I_ADD | I_ADDRESS | I_AMOUNT | I_AND | I_APPLY | I_BALANCE | I_BLAKE2B | I_CAR | I_CAST | I_CDR | I_CHAIN_ID | I_CHECK_SIGNATURE @@ -209,16 +211,16 @@ let namespace = function | I_EMPTY_BIG_MAP | I_EMPTY_MAP | I_EMPTY_SET | I_EQ | I_EXEC | I_FAILWITH | I_GE | I_GET | I_GET_AND_UPDATE | I_GT | I_HASH_KEY | I_IF | I_IF_CONS | I_IF_LEFT | I_IF_NONE | I_IMPLICIT_ACCOUNT | I_INT | I_ISNAT | I_ITER - | I_JOIN_TICKETS | I_KECCAK | I_LAMBDA | I_LE | I_LEFT | I_LEVEL | I_LOOP - | I_LOOP_LEFT | I_LSL | I_LSR | I_LT | I_MAP | I_MEM | I_MUL | I_NEG | I_NEQ - | I_NEVER | I_NIL | I_NONE | I_NOT | I_NOW | I_MIN_BLOCK_TIME | I_OR | I_PACK - | I_PAIR | I_PAIRING_CHECK | I_PUSH | I_READ_TICKET | I_RENAME | I_RIGHT - | I_SAPLING_EMPTY_STATE | I_SAPLING_VERIFY_UPDATE | I_SELF | I_SELF_ADDRESS - | I_SENDER | I_SET_DELEGATE | I_SHA256 | I_SHA512 | I_SHA3 | I_SIZE | I_SLICE - | I_SOME | I_SOURCE | I_SPLIT_TICKET | I_STEPS_TO_QUOTA | I_SUB | I_SUB_MUTEZ - | I_SWAP | I_TICKET | I_TOTAL_VOTING_POWER | I_TRANSFER_TOKENS | I_UNIT - | I_UNPACK | I_UNPAIR | I_UPDATE | I_VOTING_POWER | I_XOR | I_OPEN_CHEST - | I_EMIT -> + | I_JOIN_TICKETS | I_KECCAK | I_LAMBDA | I_LAMBDA_REC | I_LE | I_LEFT + | I_LEVEL | I_LOOP | I_LOOP_LEFT | I_LSL | I_LSR | I_LT | I_MAP | I_MEM + | I_MUL | I_NEG | I_NEQ | I_NEVER | I_NIL | I_NONE | I_NOT | I_NOW + | I_MIN_BLOCK_TIME | I_OR | I_PACK | I_PAIR | I_PAIRING_CHECK | I_PUSH + | I_READ_TICKET | I_RENAME | I_RIGHT | I_SAPLING_EMPTY_STATE + | I_SAPLING_VERIFY_UPDATE | I_SELF | I_SELF_ADDRESS | I_SENDER + | I_SET_DELEGATE | I_SHA256 | I_SHA512 | I_SHA3 | I_SIZE | I_SLICE | I_SOME + | I_SOURCE | I_SPLIT_TICKET | I_STEPS_TO_QUOTA | I_SUB | I_SUB_MUTEZ | I_SWAP + | I_TICKET | I_TOTAL_VOTING_POWER | I_TRANSFER_TOKENS | I_UNIT | I_UNPACK + | I_UNPAIR | I_UPDATE | I_VOTING_POWER | I_XOR | I_OPEN_CHEST | I_EMIT -> Instr_namespace | T_address | T_tx_rollup_l2_address | T_big_map | T_bool | T_bytes | T_chain_id | T_contract | T_int | T_key | T_key_hash | T_lambda | T_list @@ -255,6 +257,7 @@ let string_of_prim = function | D_Some -> "Some" | D_True -> "True" | D_Unit -> "Unit" + | D_Lambda_rec -> "Lambda_rec" | I_PACK -> "PACK" | I_UNPACK -> "UNPACK" | I_BLAKE2B -> "BLAKE2B" @@ -297,6 +300,7 @@ let string_of_prim = function | I_IF_NONE -> "IF_NONE" | I_INT -> "INT" | I_LAMBDA -> "LAMBDA" + | I_LAMBDA_REC -> "LAMBDA_REC" | I_LE -> "LE" | I_LEFT -> "LEFT" | I_LEVEL -> "LEVEL" @@ -409,6 +413,7 @@ let prim_of_string = function | "Some" -> ok D_Some | "True" -> ok D_True | "Unit" -> ok D_Unit + | "Lambda_rec" -> ok D_Lambda_rec | "PACK" -> ok I_PACK | "UNPACK" -> ok I_UNPACK | "BLAKE2B" -> ok I_BLAKE2B @@ -453,6 +458,7 @@ let prim_of_string = function | "INT" -> ok I_INT | "KECCAK" -> ok I_KECCAK | "LAMBDA" -> ok I_LAMBDA + | "LAMBDA_REC" -> ok I_LAMBDA_REC | "LE" -> ok I_LE | "LEFT" -> ok I_LEFT | "LEVEL" -> ok I_LEVEL @@ -761,7 +767,10 @@ let prim_encoding = ("sapling_transaction", T_sapling_transaction); (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *) (* Alpha_014 addition *) - ("EMIT", I_EMIT) + ("EMIT", I_EMIT); + (* Alpha_015 addition *) + ("Lambda_rec", D_Lambda_rec); + ("LAMBDA_REC", I_LAMBDA_REC) (* New instructions must be added here, for backward compatibility of the encoding. *) (* Keep the comment above at the end of the list *); ] diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli index 6d14592c1f7a0778f128aa89f24bea05a9bf76b7..69660958351d2f8a36f373674f81ecfff341a4d1 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli @@ -61,6 +61,7 @@ type prim = | D_Some | D_True | D_Unit + | D_Lambda_rec | I_PACK | I_UNPACK | I_BLAKE2B @@ -104,6 +105,7 @@ type prim = | I_IF_NONE | I_INT | I_LAMBDA + | I_LAMBDA_REC | I_LE | I_LEFT | I_LEVEL diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 7194b2d95f6f05cd6586814b731d0b783cc63949..535d2e5c14bcc8b186593f7480c37bba6487736f 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -486,15 +486,23 @@ and ifailwith : ifailwith_type = and iexec : type a b c d e f g. (a, b, c, d, e, f, g) iexec_type = fun instrument logger g gas cont_sty k ks accu stack -> let arg = accu and code, stack = stack in - let (Lam (code, _)) = code in - let code = - match logger with - | None -> code.kinstr - | Some logger -> - Script_interpreter_logging.log_kinstr logger code.kbef code.kinstr + let log_code b = + let body = + match logger with + | None -> b.kinstr + | Some logger -> + Script_interpreter_logging.log_kinstr logger b.kbef b.kinstr + in + let ks = instrument @@ KReturn (stack, cont_sty, KCons (k, ks)) in + (body, ks) in - let ks = instrument @@ KReturn (stack, cont_sty, KCons (k, ks)) in - (step [@ocaml.tailcall]) g gas code ks arg (EmptyCell, EmptyCell) + match code with + | Lam (body, _) -> + let body, ks = log_code body in + (step [@ocaml.tailcall]) g gas body ks arg (EmptyCell, EmptyCell) + | LamRec (body, _) -> + let body, ks = log_code body in + (step [@ocaml.tailcall]) g gas body ks arg (code, (EmptyCell, EmptyCell)) and iview : type a b c d e f i o. (a, b, c, d, e, f, i, o) iview_type = fun instrument @@ -1918,9 +1926,14 @@ let step_descr ~log_now logger (ctxt, sc) descr accu stack = >>=? fun (accu, stack, ctxt, gas) -> return (accu, stack, update_context gas ctxt) -let interp logger g (Lam (code, _)) arg = - step_descr ~log_now:true logger g code arg (EmptyCell, EmptyCell) - >|=? fun (ret, (EmptyCell, EmptyCell), ctxt) -> (ret, ctxt) +let interp logger g lam arg = + match lam with + | LamRec (code, _) -> + step_descr ~log_now:true logger g code arg (lam, (EmptyCell, EmptyCell)) + >|=? fun (ret, (EmptyCell, EmptyCell), ctxt) -> (ret, ctxt) + | Lam (code, _) -> + step_descr ~log_now:true logger g code arg (EmptyCell, EmptyCell) + >|=? fun (ret, (EmptyCell, EmptyCell), ctxt) -> (ret, ctxt) (* diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 78cfeeb39c8427e84ad9f9914224d49b5ab60a9c..b483dc0d62d6ac9f1427012a8febe9d7ccb2e218 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -428,40 +428,95 @@ let rec kundip : (* [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 ctxt = update_context gas ctxt in - unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> let loc = Micheline.dummy_location in + let ctxt = update_context gas ctxt in Script_ir_unparser.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 = - IConst - ( descr.kloc, - capture_ty, - capture, - ICons_pair (descr.kloc, 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) + unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> + let make_expr expr = + Micheline.( + Seq + ( loc, + Prim (loc, I_PUSH, [ty_expr; const_expr], []) + :: Prim (loc, I_PAIR, [], []) + :: expr )) + in + let lam' = + match lam with + | LamRec (descr, expr) -> ( + let (Item_t (full_arg_ty, Item_t (Lambda_t (_, _, _), Bot_t))) = + descr.kbef + in + let (Item_t (ret_ty, Bot_t)) = descr.kaft in + Script_ir_unparser.unparse_ty ~loc ctxt full_arg_ty + >>?= fun (arg_ty_expr, ctxt) -> + Script_ir_unparser.unparse_ty ~loc ctxt ret_ty + >>?= fun (ret_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 + (* To avoid duplicating the recursive lambda [lam], we + return a regular lambda that builds the tuple of + parameters and applies it to `lam`. Since `lam` is + recursive it will push itself on top of the stack at + execution time. *) + let full_descr = + { + kloc = descr.kloc; + kbef = arg_stack_ty; + kaft = descr.kaft; + kinstr = + IConst + ( descr.kloc, + capture_ty, + capture, + ICons_pair + ( descr.kloc, + ILambda + ( descr.kloc, + lam, + ISwap + ( descr.kloc, + IExec + ( descr.kloc, + Some descr.kaft, + IHalt descr.kloc ) ) ) ) ); + } + in + let full_expr = + make_expr + Micheline. + [ + Prim + (loc, I_LAMBDA_REC, [arg_ty_expr; ret_ty_expr; expr], []); + Prim (loc, I_SWAP, [], []); + Prim (loc, I_EXEC, [], []); + ] + in + return (Lam (full_descr, full_expr), ctxt)) + | Lam (descr, expr) -> ( + let (Item_t (full_arg_ty, Bot_t)) = descr.kbef in + 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 = + IConst + ( descr.kloc, + capture_ty, + capture, + ICons_pair (descr.kloc, descr.kinstr) ); + } + in + let full_expr = make_expr [expr] in + return (Lam (full_descr, full_expr), ctxt)) + in + lam' >>=? fun (lam', ctxt) -> + let gas, ctxt = local_gas_counter_and_outdated_context ctxt in + return (lam', ctxt, gas) let make_transaction_to_tx_rollup (type t) ctxt ~destination ~amount ~(parameters_ty : ((t ticket, tx_rollup_l2_address) pair, _) ty) ~parameters diff --git a/src/proto_alpha/lib_protocol/script_interpreter_logging.ml b/src/proto_alpha/lib_protocol/script_interpreter_logging.ml index bef1c73c7baa2f5f6b7df88bb8cf0bf80d485a7d..31f10c4f49d10461aae734c5c3f736e9f25da071 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_logging.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_logging.ml @@ -927,8 +927,7 @@ let kinstr_split : continuation = k; reconstruct = (fun k -> IApply (loc, ty, k)); } - | ILambda (loc, l, k), s -> - let (Lam (desc, _)) = l in + | ILambda (loc, (Lam (desc, _) as l), k), s -> let (Item_t (a, Bot_t)) = desc.kbef in let (Item_t (b, Bot_t)) = desc.kaft in lambda_t dummy a b >|? fun lam -> @@ -939,6 +938,17 @@ let kinstr_split : continuation = k; reconstruct = (fun k -> ILambda (loc, l, k)); } + | ILambda (loc, (LamRec (desc, _) as l), k), s -> + let (Item_t (a, Item_t (Lambda_t _, Bot_t))) = desc.kbef in + let (Item_t (b, Bot_t)) = desc.kaft in + lambda_t dummy a b >|? fun lam -> + let s = Item_t (lam, s) in + Ex_split_kinstr + { + cont_init_stack = s; + continuation = k; + reconstruct = (fun k -> ILambda (loc, l, k)); + } | IFailwith (location, arg_ty), _ -> ok @@ Ex_split_failwith diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 12e5a70662d304dc5c05addfc8c97cbb97ab358a..efbfb5dc17dc1407fe21113bd1850645ff03654e 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2064,7 +2064,7 @@ let rec parse_data : (* Lambdas *) | Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr) -> traced - @@ parse_returning + @@ parse_kdescr Tc_context.data ~elab_conf ~stack_depth:(stack_depth + 1) @@ -2072,6 +2072,20 @@ let rec parse_data : ta tr script_instr + >|=? fun (kdescr, ctxt) -> (Lam (kdescr, script_instr), ctxt) + | ( Lambda_t (ta, tr, _ty_name), + Prim (loc, D_Lambda_rec, [(Seq (_loc, _) as script_instr)], []) ) -> + traced + @@ ( lambda_t loc ta tr >>?= fun lambda_rec_ty -> + parse_lam_rec + Tc_context.(add_lambda data) + ~elab_conf + ~stack_depth:(stack_depth + 1) + ctxt + ta + tr + lambda_rec_ty + script_instr ) | Lambda_t _, expr -> traced_fail (Invalid_kind (location expr, [Seq_kind], kind expr)) (* Options *) @@ -2379,7 +2393,7 @@ and parse_views : in Script_map.map_es_in_context aux ctxt views -and parse_returning : +and parse_kdescr : type arg argc ret retc. elab_conf:elab_conf -> stack_depth:int -> @@ -2388,7 +2402,7 @@ and parse_returning : (arg, argc) ty -> (ret, retc) ty -> Script.node -> - ((arg, ret) lambda * context) tzresult Lwt.t = + ((arg, end_of_stack, ret, end_of_stack) kdescr * context) tzresult Lwt.t = fun ~elab_conf ~stack_depth tc_context ctxt arg ret script_instr -> parse_instr ~elab_conf @@ -2409,14 +2423,57 @@ and parse_returning : @@ ty_eq ~error_details ty ret >>? fun (eq, ctxt) -> eq >|? fun Eq -> - ((Lam (close_descr descr, script_instr) : (arg, ret) lambda), ctxt)) + ( (close_descr descr : (arg, end_of_stack, ret, end_of_stack) kdescr), + ctxt )) + | Typed {loc; aft = stack_ty; _}, ctxt -> + let ret = serialize_ty_for_error ret in + let stack_ty = serialize_stack_for_error ctxt stack_ty in + fail @@ Bad_return (loc, stack_ty, ret) + | Failed {descr}, ctxt -> + return + ( (close_descr (descr (Item_t (ret, Bot_t))) + : (arg, end_of_stack, ret, end_of_stack) kdescr), + ctxt ) + +and parse_lam_rec : + type arg argc ret retc. + elab_conf:elab_conf -> + stack_depth:int -> + tc_context -> + context -> + (arg, argc) ty -> + (ret, retc) ty -> + ((arg, ret) lambda, _) ty -> + Script.node -> + ((arg, ret) lambda * context) tzresult Lwt.t = + fun ~elab_conf ~stack_depth tc_context ctxt arg ret lambda_rec_ty script_instr -> + parse_instr + ~elab_conf + tc_context + ctxt + ~stack_depth:(stack_depth + 1) + script_instr + (Item_t (arg, Item_t (lambda_rec_ty, Bot_t))) + >>=? function + | Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr), ctxt -> + Lwt.return + (let error_details = Informative loc in + Gas_monad.run ctxt + @@ Gas_monad.record_trace_eval ~error_details (fun loc -> + let ret = serialize_ty_for_error ret in + let stack_ty = serialize_stack_for_error ctxt stack_ty in + Bad_return (loc, stack_ty, ret)) + @@ ty_eq ~error_details ty ret + >>? fun (eq, ctxt) -> + eq >|? fun Eq -> + ((LamRec (close_descr descr, script_instr) : (arg, ret) lambda), ctxt)) | Typed {loc; aft = stack_ty; _}, ctxt -> let ret = serialize_ty_for_error ret in let stack_ty = serialize_stack_for_error ctxt stack_ty in fail @@ Bad_return (loc, stack_ty, ret) | Failed {descr}, ctxt -> return - ( (Lam (close_descr (descr (Item_t (ret, Bot_t))), script_instr) + ( (LamRec (close_descr (descr (Item_t (ret, Bot_t))), script_instr) : (arg, ret) lambda), ctxt ) @@ -3298,7 +3355,7 @@ and parse_instr : >>?= fun (Ex_ty ret, ctxt) -> check_kind [Seq_kind] code >>?= fun () -> check_var_annot loc annot >>?= fun () -> - parse_returning + parse_kdescr (Tc_context.add_lambda tc_context) ~elab_conf ~stack_depth:(stack_depth + 1) @@ -3306,11 +3363,33 @@ and parse_instr : arg ret code - >>=? fun (lambda, ctxt) -> - let instr = {apply = (fun k -> ILambda (loc, lambda, k))} in + >>=? fun (kdescr, ctxt) -> + let instr = {apply = (fun k -> ILambda (loc, Lam (kdescr, code), k))} in lambda_t loc arg ret >>?= fun ty -> let stack = Item_t (ty, stack) in typed ctxt loc instr stack + | ( Prim (loc, I_LAMBDA_REC, [arg_ty_expr; ret_ty_expr; lambda_expr], annot), + stack ) -> + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy arg_ty_expr + >>?= fun (Ex_ty arg, ctxt) -> + parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ret_ty_expr + >>?= fun (Ex_ty ret, ctxt) -> + check_kind [Seq_kind] lambda_expr >>?= fun () -> + check_var_annot loc annot >>?= fun () -> + lambda_t loc arg ret >>?= fun lambda_rec_ty -> + parse_lam_rec + Tc_context.(add_lambda tc_context) + ~elab_conf + ~stack_depth:(stack_depth + 1) + ctxt + arg + ret + lambda_rec_ty + lambda_expr + >>=? fun (code, ctxt) -> + let instr = {apply = (fun k -> ILambda (loc, code, k))} in + let stack = Item_t (lambda_rec_ty, stack) in + typed ctxt loc instr stack | ( Prim (loc, I_EXEC, [], annot), Item_t (arg, Item_t (Lambda_t (param, ret, _), rest)) ) -> check_item_ty ctxt arg param loc I_EXEC 1 2 >>?= fun (Eq, ctxt) -> @@ -3813,7 +3892,7 @@ and parse_instr : | ( Prim (loc, (I_CREATE_CONTRACT as prim), [(Seq _ as code)], annot), Item_t (Option_t (Key_hash_t, _, _), Item_t (Mutez_t, Item_t (ginit, rest))) ) - -> + -> ( Tc_context.check_not_in_view ~legacy loc tc_context prim >>?= fun () -> check_two_var_annot loc annot >>?= fun () -> (* We typecheck the script to make sure we will originate only well-typed @@ -3844,7 +3923,7 @@ and parse_instr : >>?= fun (Ty_ex_c ret_type_full) -> trace (Ill_typed_contract (canonical_code, [])) - (parse_returning + (parse_kdescr (Tc_context.toplevel ~storage_type ~param_type:arg_type ~entrypoints) ctxt ~elab_conf @@ -3852,31 +3931,29 @@ and parse_instr : arg_type_full ret_type_full code_field) - >>=? fun ( Lam - ( {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, - _ ), - ctxt ) -> - let views_result = parse_views ctxt ~elab_conf storage_type views in - trace (Ill_typed_contract (canonical_code, [])) views_result - >>=? fun (_typed_views, ctxt) -> - (let error_details = Informative loc in - Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* Eq = ty_eq ~error_details arg arg_type_full in - let* Eq = ty_eq ~error_details ret ret_type_full in - ty_eq ~error_details storage_type ginit) - >>?= fun (storage_eq, ctxt) -> - storage_eq >>?= fun Eq -> - let instr = - { - apply = - (fun k -> - ICreate_contract {loc; storage_type; code = canonical_code; k}); - } - in - let stack = Item_t (operation_t, Item_t (address_t, rest)) in - typed ctxt loc instr stack + >>=? function + | {kbef = Item_t (arg, Bot_t); kaft = Item_t (ret, Bot_t); _}, ctxt -> + let views_result = parse_views ctxt ~elab_conf storage_type views in + trace (Ill_typed_contract (canonical_code, [])) views_result + >>=? fun (_typed_views, ctxt) -> + (let error_details = Informative loc in + Gas_monad.run ctxt + @@ + let open Gas_monad.Syntax in + let* Eq = ty_eq ~error_details arg arg_type_full in + let* Eq = ty_eq ~error_details ret ret_type_full in + ty_eq ~error_details storage_type ginit) + >>?= fun (storage_eq, ctxt) -> + storage_eq >>?= fun Eq -> + let instr = + { + apply = + (fun k -> + ICreate_contract {loc; storage_type; code = canonical_code; k}); + } + in + let stack = Item_t (operation_t, Item_t (address_t, rest)) in + typed ctxt loc instr stack) | Prim (loc, I_NOW, [], annot), stack -> check_var_annot loc annot >>?= fun () -> let instr = {apply = (fun k -> INow (loc, k))} in @@ -4576,7 +4653,7 @@ let parse_code : >>?= fun (Ty_ex_c ret_type_full) -> trace (Ill_typed_contract (code, [])) - (parse_returning + (parse_kdescr Tc_context.(toplevel ~storage_type ~param_type:arg_type ~entrypoints) ~elab_conf ctxt @@ -4584,7 +4661,8 @@ let parse_code : arg_type_full ret_type_full code_field) - >>=? fun (code, ctxt) -> + >>=? fun (kdescr, ctxt) -> + let code = Lam (kdescr, code_field) in Lwt.return ( code_size ctxt code views >>? fun (code_size, ctxt) -> ok @@ -4685,7 +4763,7 @@ let typecheck_code : let type_logger = if show_types then Some type_logger else None in let elab_conf = Script_ir_translator_config.make ~legacy ?type_logger () in let result = - parse_returning + parse_kdescr (Tc_context.toplevel ~storage_type ~param_type:arg_type ~entrypoints) ctxt ~elab_conf @@ -4694,7 +4772,8 @@ let typecheck_code : ret_type_full code_field in - trace (Ill_typed_contract (code, !type_map)) result >>=? fun (Lam _, ctxt) -> + trace (Ill_typed_contract (code, !type_map)) result + >>=? fun ((_ : (_, _, _, _) kdescr), ctxt) -> let views_result = parse_views ctxt ~elab_conf storage_type views in trace (Ill_typed_contract (code, !type_map)) views_result >|=? fun (typed_views, ctxt) -> diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index d7c43f1d0668c7530a17fac1d479d5b2af5216dc..ef40e260e1d72e0d27a7d1cfb9791109641038ed 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -603,6 +603,10 @@ module Data_unparser (P : MICHELSON_PARSER) = struct >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) | Lambda_t _, Lam (_, original_code) -> unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code + | Lambda_t _, LamRec (_, original_code) -> + unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code + >|=? fun (body, ctxt) -> + (Micheline.Prim (loc, D_Lambda_rec, [body], []), ctxt) | Never_t, _ -> . | Sapling_transaction_t _, s -> Lwt.return diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 9ca624442da2081e53cbfd40ce60854d4825a2f7..94b3d4a4bdd9ec834a433e572575d368144dcc08 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1108,6 +1108,10 @@ and ('arg, 'ret) lambda = | Lam : ('arg, end_of_stack, 'ret, end_of_stack) kdescr * Script.node -> ('arg, 'ret) lambda + | LamRec : + ('arg, ('arg, 'ret) lambda * end_of_stack, 'ret, end_of_stack) kdescr + * Script.node + -> ('arg, 'ret) lambda and 'arg typed_contract = | Typed_implicit : public_key_hash -> unit typed_contract diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 2f1f2a14f10e5b8e8b5389cc36363463ff20a131..e7b46c89178396e908148c843fe1b574cfa54e90 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1109,6 +1109,10 @@ and ('arg, 'ret) lambda = | Lam : ('arg, end_of_stack, 'ret, end_of_stack) kdescr * Script.node -> ('arg, 'ret) lambda + | LamRec : + ('arg, ('arg, 'ret) lambda * end_of_stack, 'ret, end_of_stack) kdescr + * Script.node + -> ('arg, 'ret) lambda and 'arg typed_contract = | Typed_implicit : public_key_hash -> unit typed_contract 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 7f332092ac61effa093f40e7581ae7c264e3cbf8..58e525803b8a5db581c229a3f77fdf5b2a3ad79d 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -352,13 +352,20 @@ and lambda_size : type i o. count_lambda_nodes:bool -> nodes_and_size -> (i, o) lambda -> nodes_and_size = - fun ~count_lambda_nodes accu (Lam (kdescr, node)) -> - (* We assume that the nodes' size have already been counted if the - lambda is not a toplevel lambda. *) - let accu = - ret_adding (accu ++ if count_lambda_nodes then node_size node else zero) h2w + fun ~count_lambda_nodes accu lam -> + let count_lambda_body kdescr node = + (* We assume that the nodes' size have already been counted if the + lambda is not a toplevel lambda. *) + 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 in - (kdescr_size [@ocaml.tailcall]) ~count_lambda_nodes:false accu kdescr + match lam with + | Lam (kdescr, node) -> count_lambda_body kdescr node + | LamRec (kdescr, node) -> count_lambda_body kdescr node and kdescr_size : type a s r f. diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/fail_rec.tz b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/fail_rec.tz new file mode 100644 index 0000000000000000000000000000000000000000..cac8886649280e4855955662073fdba00bcd20d6 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/fail_rec.tz @@ -0,0 +1,8 @@ +{ parameter unit; + storage unit; + code { CAR; + LAMBDA_REC unit unit { }; + SWAP; + EXEC; + NIL operation; + PAIR}} diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/omega.tz b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/omega.tz new file mode 100644 index 0000000000000000000000000000000000000000..52adfdf1facc7adeefbe797815339d2d5f43be28 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/omega.tz @@ -0,0 +1,9 @@ +{ parameter unit; + storage unit; + code { CAR; + LAMBDA_REC unit unit + { EXEC }; + SWAP; + EXEC; + NIL operation; + PAIR}} diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact.tz b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact.tz new file mode 100644 index 0000000000000000000000000000000000000000..b3dd6402f440533399f767ae46efebb81ba2bbfa --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact.tz @@ -0,0 +1,19 @@ +{ parameter int; + storage int; + code { CAR ; + LAMBDA_REC int int + { DUP; + EQ; + IF { PUSH int 1 } + { DUP; + DUP 3; + PUSH int 1; + DUP 4; + SUB; + EXEC; + MUL}; + DIP { DROP 2 }}; + SWAP; + EXEC; + NIL operation; + PAIR}} diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact_apply.tz b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact_apply.tz new file mode 100644 index 0000000000000000000000000000000000000000..85515df4cde8756e002fd9370278ce62dc1c4b5e --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact_apply.tz @@ -0,0 +1,24 @@ + {parameter int; + storage int; + code { CAR ; + LAMBDA_REC (pair unit int) int + { UNPAIR; + DUP 2; + EQ; + IF { PUSH int 1 } + { DUP 2; + DUP 4; + DUP 3; + APPLY; + PUSH int 1; + DUP 3; + SUB; + EXEC; + MUL}; + DIP { DROP 3 }}; + UNIT; + APPLY; + SWAP; + EXEC; + NIL operation; + PAIR}} diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact_apply_store.tz b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact_apply_store.tz new file mode 100644 index 0000000000000000000000000000000000000000..8d38ed03bddb76d29d0a10562516b79ea453e0cc --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact_apply_store.tz @@ -0,0 +1,27 @@ +{ storage (or int (lambda int int)); + parameter (or (unit %gen) (int %exec)); + code { UNPAIR; + IF_LEFT{ DROP 2; + LAMBDA_REC (pair unit int) int + { UNPAIR; + DUP 2; + EQ; + IF { PUSH int 1 } + { DUP 2; + DUP 4; + DUP 3; + APPLY; + PUSH int 1; + DUP 3; + SUB; + EXEC; + MUL}; + DIP { DROP 3 }}; + UNIT; + APPLY; + RIGHT int} + { DIP { ASSERT_RIGHT }; + EXEC; + LEFT (lambda int int)}; + NIL operation; + PAIR}} diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact_store.tz b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact_store.tz new file mode 100644 index 0000000000000000000000000000000000000000..c4825db7f6349ccaf10c262f414ba1637b87c17d --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/contracts/rec_fact_store.tz @@ -0,0 +1,22 @@ +{ storage (or int (lambda int int)); + parameter (or (unit %gen) (int %exec)); + code { UNPAIR; + IF_LEFT{ DROP 2; + LAMBDA_REC int int + { DUP; + EQ; + IF { PUSH int 1 } + { DUP; + DUP 3; + PUSH int 1; + DUP 4; + SUB; + EXEC; + MUL}; + DIP { DROP 2 }}; + RIGHT int} + { DIP { ASSERT_RIGHT }; + EXEC; + LEFT (lambda int int)}; + NIL operation; + PAIR}} 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 6112dbb07fff2c827a2bcc6e71e65a21b3f064c3..4a4f86d4e63189918017663f50da3410e744c6ce 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 @@ -27,9 +27,8 @@ ------- Component: Protocol (interpretation) Dependencies: src/proto_alpha/lib_protocol/script_interpreter.ml - Invocation: dune exec \ - src/proto_alpha/lib_protocol/test/integration/michelson/main.exe \ - -- test "^interpretation$" + Invocation: cd src/proto_alpha/lib_protocol/test/integration/michelson && \ + dune exec ./main.exe -- test "^interpretation$" Subject: Interpretation of Michelson scripts *) @@ -288,6 +287,84 @@ module Test_map_instr_on_options = struct assertions storage_before new_storage input end +let test_contract path storage param ~entrypoint_str ~ok ~ko = + let entrypoint = + match entrypoint_str with + | None -> Entrypoint.default + | Some str -> Entrypoint.of_string_strict_exn str + in + test_context () >>=? fun ctx -> + let read_file filename = + let ch = open_in filename in + let s = really_input_string ch (in_channel_length ch) in + close_in ch ; + s + in + let script = read_file path in + Contract_helpers.run_script + ctx + script + ~storage + ~parameter:param + ~entrypoint + () + >>= function + | Ok (res, _) -> ok res + | Error t -> ko t + +let fail_with_trace trace = + Alcotest.failf "Unexpected error: %a" Error_monad.pp_print_trace trace + +let test_contract_success path storage param expected_storage_str + ?entrypoint_str () = + let expected_storage = Expr.from_string expected_storage_str in + test_contract + path + storage + param + ~ok:(fun real -> + if real.storage = expected_storage then return_unit + else Alcotest.fail "Unexpected result") + ~ko:fail_with_trace + ~entrypoint_str + +let test_contract_fail path storage param ?entrypoint_str () = + test_contract + path + storage + param + ~ok:(fun _ -> + Alcotest.failf + "Unexpected success: interpreting %s should have failed." + path) + ~ko:(fun _ -> return_unit) + ~entrypoint_str + +let test_store_and_reload path ~init_storage ~entrypoint_str_1 ~param_1 + ~expected_storage_str_1 ~entrypoint_str_2 ~param_2 ~expected_storage_str_2 + () = + let expected_storage_1 = Expr.from_string expected_storage_str_1 in + test_contract + path + init_storage + param_1 + ~entrypoint_str:(Some entrypoint_str_1) + ~ok:(fun real -> + if real.storage = expected_storage_1 then + test_contract_success + path + expected_storage_str_1 + param_2 + expected_storage_str_2 + ~entrypoint_str:entrypoint_str_2 + () + else + Alcotest.failf + "Unexpected result. \n Expected :\n %s \n Real : \n %s \n" + (Expr.to_string expected_storage_1) + (Expr.to_string real.storage)) + ~ko:fail_with_trace + let tests = [ Tztest.tztest "test bad contract error" `Quick test_bad_contract_parameter; @@ -306,5 +383,63 @@ let tests = QCheck2.Gen.( triple (opt small_signed_int) (opt small_signed_int) small_signed_int) Test_map_instr_on_options.test_mapping; + Tztest.tztest + "test lambda_rec instruction" + `Quick + (test_contract_success "./contracts/rec_fact.tz" "0" "5" "120"); + Tztest.tztest + "test lambda_rec instruction with apply" + `Quick + (test_contract_success "./contracts/rec_fact_apply.tz" "0" "5" "120"); + Tztest.tztest + "test lambda_rec instruction with an infinite recursion" + `Quick + (test_contract_fail "./contracts/omega.tz" "Unit" "Unit"); + Tztest.tztest + "test lambda_rec instruction storage" + `Quick + (test_store_and_reload + "./contracts/rec_fact_store.tz" + ~init_storage:"Left 0" + ~entrypoint_str_1:"gen" + ~param_1:"Unit" + ~expected_storage_str_1: + {|Right + (Lambda_rec + { DUP ; + EQ ; + IF { PUSH int 1 } { DUP ; DUP 3 ; PUSH int 1 ; DUP 4 ; SUB + ; EXEC ; MUL } ; + DIP { DROP 2 } })|} + ~entrypoint_str_2:"exec" + ~param_2:"5" + ~expected_storage_str_2:"Left 120"); + Tztest.tztest + "test lambda_rec instruction storage" + `Quick + (test_store_and_reload + "./contracts/rec_fact_apply_store.tz" + ~init_storage:"Left 0" + ~entrypoint_str_1:"gen" + ~param_1:"Unit" + ~expected_storage_str_1: + {|Right + { PUSH unit Unit ; + PAIR ; + LAMBDA_REC + (pair unit int) + int + { UNPAIR ; + DUP 2 ; + EQ ; + IF { PUSH int 1 } + { DUP 2 ; DUP 4 ; DUP 3 ; APPLY ; PUSH int 1 ; DUP 3 ; + SUB ; EXEC ; MUL } ; + DIP { DROP 3 } } ; + SWAP ; + EXEC }|} + ~entrypoint_str_2:"exec" + ~param_2:"5" + ~expected_storage_str_2:"Left 120"); ] @ error_encoding_tests diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml index c2dd2c973c463417aaa8a1f64b9903f7a7726379..033e21097e5bb4f01010bd238c7b4b5e4de165a7 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -898,6 +898,33 @@ let test_parse_contract_data_for_rollup_with_invalid_type () = res (( = ) (Script_tc_errors.No_such_entrypoint entrypoint)) +let test_contract path ~ok ~ko () = + let contract = path in + let script = read_file contract in + let contract_expr = Expr.from_string script in + test_context () >>=? fun ctxt -> + Script_ir_translator.typecheck_code + ~legacy:false + ~show_types:false + ctxt + contract_expr + >>= function + | Ok _ -> ok () + | Error t -> ko t + +let test_contract_success path = + test_contract path ~ok:return ~ko:(fun t -> + Alcotest.failf "Unexpected error: %a" Environment.Error_monad.pp_trace t) + +let test_contract_failure path = + test_contract + path + ~ok:(fun () -> + Alcotest.failf + "Unexpected success: typechecking %s should have failed" + path) + ~ko:(fun _ -> return_unit) + let tests = [ Tztest.tztest "test unparse view" `Quick test_unparse_view; @@ -947,4 +974,16 @@ let tests = "test parse contract data for rollup with entrypoint" `Quick test_parse_contract_data_for_rollup_with_invalid_type; + Tztest.tztest + "test lambda_rec instruction" + `Quick + (test_contract_success "./contracts/rec_fact.tz"); + Tztest.tztest + "test lambda_rec instruction with apply" + `Quick + (test_contract_success "./contracts/rec_fact_apply.tz"); + Tztest.tztest + "test lambda_rec with type error" + `Quick + (test_contract_failure "./contracts/fail_rec.tz"); ] diff --git a/src/proto_alpha/lib_protocol/test/regression/contracts/rec_id_unit.tz b/src/proto_alpha/lib_protocol/test/regression/contracts/rec_id_unit.tz new file mode 100644 index 0000000000000000000000000000000000000000..ae143d1c2a8aa2d35463230f7d236680ac387e72 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/regression/contracts/rec_id_unit.tz @@ -0,0 +1,9 @@ +{parameter unit; + storage unit; + code { CAR ; + LAMBDA_REC unit unit + {DIP {DROP}}; + SWAP; + EXEC; + NIL operation; + PAIR}} diff --git a/src/proto_alpha/lib_protocol/test/regression/expected/test_logging.ml/rec_id_unit.out b/src/proto_alpha/lib_protocol/test/regression/expected/test_logging.ml/rec_id_unit.out new file mode 100644 index 0000000000000000000000000000000000000000..8ac716e1d0587b3814f50cd68f9db794c6c452a1 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/regression/expected/test_logging.ml/rec_id_unit.out @@ -0,0 +1,56 @@ + +trace + - CAR (interp) @ location: 7 + [ (Pair Unit Unit) ] + - CAR (entry) @ location: 7 + [ (Pair Unit Unit) ] + - log/LAMBDA_REC (exit) @ location: 7 + [ Unit ] + - LAMBDA_REC (entry) @ location: 8 + [ Unit ] + - log/SWAP (exit) @ location: 8 + [ (Lambda_rec { DIP { DROP } }) + Unit ] + - SWAP (entry) @ location: 15 + [ (Lambda_rec { DIP { DROP } }) + Unit ] + - log/EXEC (exit) @ location: 15 + [ Unit + (Lambda_rec { DIP { DROP } }) ] + - EXEC (entry) @ location: 16 + [ Unit + (Lambda_rec { DIP { DROP } }) ] + - DIP (entry) @ location: 12 + [ Unit + (Lambda_rec { DIP { DROP } }) ] + - log/DROP (exit) @ location: 12 + [ (Lambda_rec { DIP { DROP } }) ] + - DROP (entry) @ location: 14 + [ (Lambda_rec { DIP { DROP } }) ] + - log/[halt] (exit) @ location: 14 + [ ] + - [halt] (entry) @ location: 14 + [ ] + - control: KUndip + - control: KCons + - log/[halt] (exit) @ location: 12 + [ Unit ] + - [halt] (entry) @ location: 12 + [ Unit ] + - control: KReturn + - control: KCons + - log/NIL (exit) @ location: 16 + [ Unit ] + - NIL (entry) @ location: 17 + [ Unit ] + - log/PAIR (exit) @ location: 17 + [ {} + Unit ] + - PAIR (entry) @ location: 19 + [ {} + Unit ] + - log/[halt] (exit) @ location: 19 + [ (Pair {} Unit) ] + - [halt] (entry) @ location: 6 + [ (Pair {} Unit) ] + - control: KNil diff --git a/src/proto_alpha/lib_protocol/test/regression/test_logging.ml b/src/proto_alpha/lib_protocol/test/regression/test_logging.ml index b7a360e0684904d4318aee21bbe56a941fd0b23b..6ab68e63171fca74a5eddab6160729a7a6539f86 100644 --- a/src/proto_alpha/lib_protocol/test/regression/test_logging.ml +++ b/src/proto_alpha/lib_protocol/test/regression/test_logging.ml @@ -389,4 +389,5 @@ let () = ~lib:"view_toplevel_lib" ~lib_storage:"0" "view_fib"; + transaction ~parameter:"Unit" ~storage:"Unit" "rec_id_unit"; |]