diff --git a/src/ligo/TODO.txt b/src/ligo/TODO.txt index ef5f79d1e..210cb0637 100644 --- a/src/ligo/TODO.txt +++ b/src/ligo/TODO.txt @@ -3,6 +3,8 @@ ## Back-end - Replace Mini_c environments with stacks + + Compiler_environment : bad pack make first element deepest + + Add types to pack and unpack - Think about Coq ## Amendments diff --git a/src/ligo/compiler/compiler_environment.ml b/src/ligo/compiler/compiler_environment.ml index 2f99d0a5b..c6980ee06 100644 --- a/src/ligo/compiler/compiler_environment.ml +++ b/src/ligo/compiler/compiler_environment.ml @@ -144,13 +144,64 @@ let pack : environment -> michelson result = fun e -> let%bind () = trace_strong (simple_error "pack empty env") @@ Assert.assert_true (List.length e <> 0) in - ok @@ seq @@ List.map (Function.constant i_pair) @@ List.tl e + let code = seq @@ List.map (Function.constant i_pair) @@ List.tl e in + + let%bind () = + let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in + let repr = Environment.closure_representation e in + let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ repr in + let output_stack_ty = Stack.(output_ty @: nil) in + let error () = + let title () = "error producing Env.pack" in + let content () = Format.asprintf "" + in + ok @@ (error title content) in + let%bind _ = + Trace.trace_tzresult_lwt_r error @@ + Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty in + ok () + in + + ok code let unpack : environment -> michelson result = fun e -> let%bind () = trace_strong (simple_error "unpack empty env") @@ Assert.assert_true (List.length e <> 0) in - ok @@ seq @@ List.map (Function.constant i_unpair) @@ List.tl e + + let l = List.length e - 1 in + let rec aux n = + match n with + | 0 -> seq [] + | n -> seq [ + i_unpair ; + dip (aux (n - 1)) ; + ] in + let code = aux l in + + let%bind () = + let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e in + let repr = Environment.closure_representation e in + let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ repr in + let input_stack_ty = Stack.(input_ty @: nil) in + let error () = + let title () = "error producing Env.unpack" in + let content () = Format.asprintf "\nEnvironment:%a\nType Representation:%a\nCode:%a\n" + PP.environment e + PP.type_ repr + Micheline.Michelson.pp code + in + ok @@ (error title content) in + let%bind _ = + Trace.trace_tzresult_lwt_r error @@ + Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty in + ok () + in + + ok code + let pack_select : environment -> string list -> michelson result = fun e lst -> let module L = Logger.Stateful() in @@ -206,10 +257,10 @@ let pack_select : environment -> string list -> michelson result = fun e lst -> ok code let add_packed_anon : environment -> type_value -> michelson result = fun e type_value -> - let code = i_pair in + let code = seq [i_pair] in let%bind () = - let error () = ok @@ simple_error "error producing Env.get" in + let error () = ok @@ simple_error "error producing add packed" in let%bind (Ex_ty input_ty) = Compiler_type.Ty.environment_representation e in let e' = Environment.add ("_add_packed_anon" , type_value) e in let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in diff --git a/src/ligo/compiler/compiler_program.ml b/src/ligo/compiler/compiler_program.ml index cbaf01ce0..1bd8fd6ec 100644 --- a/src/ligo/compiler/compiler_program.ml +++ b/src/ligo/compiler/compiler_program.ml @@ -130,23 +130,31 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m | T_deep_closure (small_env, input_ty , _) -> ( trace (simple_error "Compiling deep closure application") @@ let%bind (arg' , env') = translate_expression arg env in - let%bind (f' , _) = translate_expression f env' in + let%bind (f' , env'') = translate_expression f env' in + let%bind f_ty = Compiler_type.type_ f.type_value in let%bind append_closure = Compiler_environment.add_packed_anon small_env input_ty in let error = let error_title () = "michelson type-checking closure application" in let error_content () = - Format.asprintf "Env : %a\nclosure : %a\narg : %a\n" + Format.asprintf "\nEnv. %a\nEnv'. %a\nEnv''. %a\nclosure. %a ; %a ; %a\narg. %a\n" PP.environment env - PP.expression_with_type f + PP.environment env' + PP.environment env'' + PP.expression_with_type f Michelson.pp f_ty Michelson.pp f' PP.expression_with_type arg in error error_title error_content in trace error @@ return @@ seq [ + i_comment "closure application" ; + i_comment "arg" ; arg' ; + i_comment "f'" ; f' ; i_unpair ; - dip @@ append_closure ; + i_comment "append" ; + dip @@ seq [i_swap ; append_closure] ; + i_comment "exec" ; i_swap ; i_exec ; ] ) @@ -190,8 +198,7 @@ and translate_expression ?(first=false) (expr:expression) (env:environment) : (m in let error = let title () = "error compiling constant" in - let content () = L.get () - in + let content () = L.get () in error title content in trace error @@ return code