diff --git a/src/bin/cli.ml b/src/bin/cli.ml index e0f49bf1b..e3f2ff2ec 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -163,10 +163,10 @@ let dry_run = let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in let%bind (typed_program,state,env) = Compile.source_to_typed (Syntax_name syntax) source_file in let%bind compiled_param = Compile.source_contract_input_to_michelson_value_as_function ~env ~state (storage,input) v_syntax in - let%bind michelson = Compile.typed_to_michelson_program typed_program entry_point in + let%bind michelson = Compile.typed_to_michelson_contract_as_exp typed_program entry_point in let%bind args_michelson = Run.evaluate_michelson compiled_param in let%bind options = Run.make_dry_run_options {amount ; sender ; source } in - let%bind michelson_output = Run.run ~options michelson args_michelson in + let%bind michelson_output = Run.run_contract ~options michelson.expr michelson.expr_ty args_michelson true in let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_program entry_point michelson_output in ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output in diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 23a4d4993..239a960d7 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -1,8 +1,9 @@ -open Trace open Mini_c open Tezos_utils +open Proto_alpha_utils +open Trace -let compile_expression_as_function : expression -> _ result = fun e -> +let compile_expression_as_function : expression -> Compiler.compiled_program result = fun e -> let (input , output) = t_unit , e.type_value in let%bind body = Compiler.Program.translate_expression e Compiler.Environment.empty in let body = Self_michelson.optimize body in @@ -11,7 +12,7 @@ let compile_expression_as_function : expression -> _ result = fun e -> let open! Compiler.Program in ok { input ; output ; body } -let compile_function = fun e -> +let compile_function : expression -> Compiler.compiled_program result = fun e -> let%bind (input , output) = get_t_function e.type_value in let%bind body = get_function e in let%bind body = Compiler.Program.translate_function_body body [] input in @@ -30,15 +31,30 @@ let compile_function_entry = fun program name -> let aggregated = Self_mini_c.all_expression aggregated in compile_function aggregated -let compile_contract_entry = fun program name -> +(* new *) + +let compile_contract : expression -> Compiler.compiled_expression result = fun e -> + let%bind (input , _) = get_t_function e.type_value in + let%bind body = get_function e in + let%bind body = Compiler.Program.translate_function_body body [] input in + let expr = Self_michelson.optimize body in + let%bind expr_ty = Compiler.Type.Ty.type_ e.type_value in + let open! Compiler.Program in + ok { expr_ty ; expr } + +let compile_contract_as_exp = fun program name -> let%bind aggregated = aggregate_entry program name false in let aggregated = Self_mini_c.all_expression aggregated in - let%bind compiled = compile_function aggregated in - let%bind (param_ty , storage_ty) = - let%bind fun_ty = get_t_function aggregated.type_value in - Mini_c.get_t_pair (fst fun_ty) - in - let%bind param_michelson = Compiler.Type.type_ param_ty in - let%bind storage_michelson = Compiler.Type.type_ storage_ty in - let contract = Michelson.contract param_michelson storage_michelson compiled.body in - ok contract + compile_contract aggregated + +let build_contract : Compiler.compiled_expression -> Michelson.michelson result = + fun compiled -> + let%bind ((Ex_ty _param_ty),(Ex_ty _storage_ty)) = Self_michelson.fetch_lambda_parameters compiled.expr_ty in + (*TODO : bind pair trace_tzresult_lwt ? *) + let%bind (param_michelson : Tezos_raw_protocol_005_PsBabyM1.Alpha_context.Script.node) = + Trace.trace_tzresult_lwt (simple_error "TODO") @@ + Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _param_ty in + let%bind (storage_michelson : Tezos_raw_protocol_005_PsBabyM1.Alpha_context.Script.node) = + Trace.trace_tzresult_lwt (simple_error "TODO") @@ + Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _storage_ty in + ok @@ Michelson.contract param_michelson storage_michelson compiled.expr diff --git a/src/main/compile/wrapper.ml b/src/main/compile/wrapper.ml index f3577b4e4..a38af4b46 100644 --- a/src/main/compile/wrapper.ml +++ b/src/main/compile/wrapper.ml @@ -31,15 +31,6 @@ let simplified_to_compiled_program let%bind (typed,_) = Of_simplified.compile_expression ~env ~state exp in typed_expression_to_michelson_value_as_function typed -let typed_to_michelson_contract - (typed: Ast_typed.program) (entry_point:string) : Michelson.michelson result = - let%bind mini_c = Of_typed.compile typed in - Of_mini_c.compile_contract_entry mini_c entry_point - -let source_to_michelson_contract syntax source_file entry_point = - let%bind (typed,_,_) = source_to_typed syntax source_file in - typed_to_michelson_contract typed entry_point - let source_expression_to_michelson_value_as_function ~env ~state parameter syntax = let%bind typed = source_to_typed_expression ~env ~state parameter syntax in let%bind mini_c = Of_typed.compile_expression typed in @@ -49,3 +40,15 @@ let source_contract_input_to_michelson_value_as_function ~env ~state (storage,pa let%bind simplified = Of_source.compile_contract_input storage parameter syntax in let%bind typed,_ = Of_simplified.compile_expression ~env ~state simplified in typed_expression_to_michelson_value_as_function typed + +(* new *) +let typed_to_michelson_contract_as_exp + (typed: Ast_typed.program) (entry_point:string) : Compiler.compiled_expression result = + let%bind mini_c = Of_typed.compile typed in + Of_mini_c.compile_contract_as_exp mini_c entry_point + +(* produce a michelson contract e.g. the following sequence K_param ; K_storage ; K_code *) +let source_to_michelson_contract syntax source_file entry_point = + let%bind (typed,_,_) = source_to_typed syntax source_file in + let%bind michelson = typed_to_michelson_contract_as_exp typed entry_point in + Of_mini_c.build_contract michelson diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index 2d4e5a66b..14618d8ba 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -123,3 +123,86 @@ let pack_payload (payload:Michelson.t) ty = Trace.trace_tzresult_lwt (simple_error "error packing message") @@ Memory_proto_alpha.pack ty payload in ok @@ data + + +(* +type ex_option = +Ex_option : 'a option -> ex_option + +let f : ex_option -> _ = fun exo -> + let (Ex_option x) = exo in + match x with + | None -> 0 + | Some x' -> 1 (*x' varialbe de tpy existentiel*) + (* Some x' : j'essaie defenir x', et je le sors pas de la function, donc c bon*) +*) + +(* +type ex = Ex : 'a -> ex +let f = fun x -> let (Ex x') = x in x' (* la ca sort *) +*) + + (* | Pair_t : + ('a ty * field_annot option * var_annot option) * + ('b ty * field_annot option * var_annot option) * + type_annot option * + bool -> ('a, 'b) pair ty *) +let fetch_contract_args (contract_ty:ex_ty) = + match contract_ty with + | Ex_ty (Contract_t (in_ty,_)) -> ok (Ex_ty in_ty, Ex_ty in_ty) + | Ex_ty (Lambda_t (in_ty, out_ty, _)) -> ok (Ex_ty in_ty, Ex_ty out_ty) + | _ -> + simple_fail "mock" + +(* type run_res = Failwith of failwith_res | Success of ex_typed_value +let run_bis ?options (exp:Michelson.t) (input_michelson:Michelson.t) (is_contract:bool) : run_res result = *) +let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Michelson.t) (is_contract:bool) : ex_typed_value result = + let open! Tezos_raw_protocol_005_PsBabyM1 in + let%bind (Ex_ty input_ty, Ex_ty output_ty) = fetch_contract_args exp_type in + let%bind input = + Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ + Memory_proto_alpha.parse_michelson_data input_michelson input_ty + in + let (top_level, ty_stack_before, ty_stack_after) = + (if is_contract then + Script_ir_translator.Toplevel { storage_type = output_ty ; param_type = input_ty ; + root_name = None ; legacy_create_contract_literal = false } + else Script_ir_translator.Lambda) , + Script_typed_ir.Item_t (input_ty, Empty_t, None), + Script_typed_ir.Item_t (output_ty, Empty_t, None) in + let exp = Michelson.strip_annots exp in + let%bind descr = + Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ + Memory_proto_alpha.parse_michelson ~top_level exp ty_stack_before ty_stack_after in + let open! Memory_proto_alpha.Protocol.Script_interpreter in + let%bind (Item(output, Empty)) = + Trace.trace_tzresult_lwt (simple_error "error of execution") @@ + Memory_proto_alpha.interpret ?options descr + (Item(input, Empty)) + in + ok (Ex_typed_value (output_ty, output)) + + (* +let run_exp ?options (exp:Michelson.t) (*add the type*) : ex_typed_value result = + let%bind exp_type = + Trace.trace_tzresult_lwt (simple_error "error getting expression type") @@ + Memory_proto_alpha.parse_michelson_ty exp in + let open! Tezos_raw_protocol_005_PsBabyM1 in + let (Ex_ty exp_type') = exp_type in + let%bind ((top_level : tc_context), ty_stack_before, ty_stack_after) = + ok @@ ( + Script_ir_translator.Lambda, + Script_typed_ir.Empty_t, + Script_typed_ir.Item_t (exp_type', Empty_t, None) ) + in + let exp = Michelson.strip_annots exp in + let%bind descr = + Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ + Memory_proto_alpha.parse_michelson ~top_level exp ty_stack_before ty_stack_after in + let open! Memory_proto_alpha.Protocol.Script_interpreter in + let%bind (Item(output, Empty)) = + Trace.trace_tzresult_lwt (simple_error "error of execution") @@ + Memory_proto_alpha.interpret ?options descr Empty in + (* TODO stack type : unit::empty *) + ok (Ex_typed_value (exp_type', output)) + *) \ No newline at end of file diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 6ceca0380..55c5a88f1 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -456,6 +456,11 @@ type compiled_program = { body : michelson ; } +type compiled_expression = { + expr_ty : ex_ty ; + expr : michelson ; +} + let get_main : program -> string -> (anon_function * _) result = fun p entry -> let is_main ((( name , expr), _):toplevel_statement) = match Combinators.Expression.(get_content expr , get_type expr)with diff --git a/src/passes/8-compiler/compiler_program.mli b/src/passes/8-compiler/compiler_program.mli index ffd3c0666..700c17e46 100644 --- a/src/passes/8-compiler/compiler_program.mli +++ b/src/passes/8-compiler/compiler_program.mli @@ -15,6 +15,11 @@ type compiled_program = { body : michelson ; } +type compiled_expression = { + expr_ty : ex_ty ; + expr : michelson ; +} + val get_operator : constant -> type_value -> expression list -> predicate result val translate_expression : expression -> environment -> michelson result val translate_function_body : anon_function -> environment_element list -> type_value -> michelson result