From de96a0468170220ced2ddf58453a807102284029 Mon Sep 17 00:00:00 2001 From: galfour Date: Tue, 20 Aug 2019 22:51:16 +0200 Subject: [PATCH 1/8] simplifying compiler --- src/compiler/compiler_environment.ml | 153 +------------- src/compiler/compiler_program.ml | 295 +++++++++------------------ src/main/run_mini_c.ml | 8 +- src/main/run_source.ml | 20 +- src/main/run_typed.ml | 12 +- src/mini_c/PP.ml | 10 +- src/mini_c/combinators.ml | 16 +- src/mini_c/types.ml | 9 +- src/test/compiler_tests.ml | 2 +- src/transpiler/transpiler.ml | 32 +-- 10 files changed, 146 insertions(+), 411 deletions(-) diff --git a/src/compiler/compiler_environment.ml b/src/compiler/compiler_environment.ml index d5734c4e9..386412f3f 100644 --- a/src/compiler/compiler_environment.ml +++ b/src/compiler/compiler_environment.ml @@ -1,14 +1,12 @@ -open Proto_alpha_utils open Trace open Mini_c open Environment open Michelson -open Memory_proto_alpha.Script_ir_translator module Stack = Meta_michelson.Stack let get : environment -> string -> michelson result = fun e s -> - let%bind (type_value , position) = + let%bind (_ , position) = let error = let title () = "Environment.get" in let content () = Format.asprintf "%s in %a" @@ -26,22 +24,10 @@ let get : environment -> string -> michelson result = fun e s -> in let code = aux position in - let%bind () = - let error () = ok @@ simple_error "error producing Env.get" in - let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in - let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in - let output_stack_ty = Stack.(ty @: input_stack_ty) 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 set : environment -> string -> michelson result = fun e s -> - let%bind (type_value , position) = + let%bind (_ , position) = generic_try (simple_error "Environment.get") @@ (fun () -> Environment.get_i s e) in let rec aux = fun n -> @@ -54,37 +40,11 @@ let set : environment -> string -> michelson result = fun e s -> in let code = aux position in - let%bind () = - let error () = ok @@ simple_error "error producing Env.set" in - let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in - let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in - let input_stack_ty = Stack.(ty @: env_stack_ty) in - let output_stack_ty = env_stack_ty 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 add : environment -> (string * type_value) -> michelson result = fun e (_s , type_value) -> +let add : environment -> (string * type_value) -> michelson result = fun _ (_s , _) -> let code = seq [] in - let%bind () = - let error () = ok @@ simple_error "error producing Env.get" in - let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in - let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in - let input_stack_ty = Stack.(ty @: env_stack_ty) in - let output_stack_ty = Stack.(ty @: env_stack_ty) 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 select ?(rev = false) ?(keep = true) : environment -> string list -> michelson result = fun e lst -> @@ -111,32 +71,6 @@ let select ?(rev = false) ?(keep = true) : environment -> string list -> michels in List.fold_right' aux (seq []) e_lst in - let%bind () = - let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in - let e' = - Environment.of_list - @@ List.map fst - @@ List.filter snd - @@ e_lst - in - let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e' in - let error () = - let title () = "error producing Env.select" in - let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n" - PP.environment e - PP.environment e' - PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst - Michelson.pp code - (L.get ()) - 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 select_env : environment -> environment -> michelson result = fun source filter -> @@ -158,23 +92,6 @@ let pack : environment -> michelson result = fun e -> Assert.assert_true (List.length e <> 0) in 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 -> @@ -192,26 +109,6 @@ let unpack : environment -> michelson result = fun e -> ] 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 - 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 @@ -239,53 +136,11 @@ let pack_select : environment -> string list -> michelson result = fun e lst -> in List.fold_right' aux (true , seq []) e_lst in - let%bind () = - let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in - let e' = - Environment.of_list - @@ List.map fst - @@ List.filter snd - @@ e_lst - in - let%bind (Ex_ty output_ty) = Compiler_type.Ty.environment_representation e' in - let output_stack_ty = Stack.(output_ty @: input_stack_ty) in - let error () = - let title () = "error producing Env.pack_select" in - let content () = Format.asprintf "\nInput : %a\nOutput : %a\nList : {%a}\nCode : %a\nLog : %s\n" - PP.environment e - PP.environment e' - PP_helpers.(list_sep (pair PP.environment_element bool) (const " || ")) e_lst - Michelson.pp code - (L.get ()) - 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 add_packed_anon : environment -> type_value -> michelson result = fun e type_value -> +let add_packed_anon : environment -> type_value -> michelson result = fun _ _ -> let code = seq [i_pair] in - let%bind () = - 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 - let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in - let input_stack_ty = Stack.(ty @: input_ty @: nil) in - let output_stack_ty = Stack.(output_ty @: nil) 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 pop : environment -> environment result = fun e -> diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index aa737a071..a1d03a1c2 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -9,8 +9,6 @@ open Memory_proto_alpha.Script_ir_translator open Operators.Compiler -open Proto_alpha_utils - let get_predicate : string -> type_value -> expression list -> predicate result = fun s ty lst -> match Map.String.find_opt s Operators.Compiler.predicates with | Some x -> ok x @@ -68,7 +66,7 @@ let get_predicate : string -> type_value -> expression list -> predicate result | x -> simple_fail ("predicate \"" ^ x ^ "\" doesn't exist") ) -let rec translate_value (v:value) : michelson result = match v with +let rec translate_value (v:value) ty : michelson result = match v with | D_bool b -> ok @@ prim (if b then D_True else D_False) | D_int n -> ok @@ int (Z.of_int n) | D_nat n -> ok @@ int (Z.of_int n) @@ -78,135 +76,78 @@ let rec translate_value (v:value) : michelson result = match v with | D_bytes s -> ok @@ bytes (Tezos_stdlib.MBytes.of_bytes s) | D_unit -> ok @@ prim D_Unit | D_pair (a, b) -> ( - let%bind a = translate_value a in - let%bind b = translate_value b in + let%bind (a_ty , b_ty) = get_t_pair ty in + let%bind a = translate_value a a_ty in + let%bind b = translate_value b b_ty in ok @@ prim ~children:[a;b] D_Pair ) - | D_left a -> translate_value a >>? fun a -> ok @@ prim ~children:[a] D_Left - | D_right b -> translate_value b >>? fun b -> ok @@ prim ~children:[b] D_Right - | D_function anon -> translate_function anon + | D_left a -> ( + let%bind (a_ty , _) = get_t_or ty in + let%bind a' = translate_value a a_ty in + ok @@ prim ~children:[a'] D_Left + ) + | D_right b -> ( + let%bind (_ , b_ty) = get_t_or ty in + let%bind b' = translate_value b b_ty in + ok @@ prim ~children:[b'] D_Right + ) + | D_function { binder ; result } -> ( + match ty with + | T_function (in_ty , _) -> ( + let env = Mini_c.Environment.of_list [ (binder , in_ty) ] in + let%bind body = translate_expression result env in + ok body + ) + | T_deep_closure _ -> simple_fail "no support for closures yet" + | _ -> simple_fail "expected function type" + ) | D_none -> ok @@ prim D_None | D_some s -> - let%bind s' = translate_value s in + let%bind s' = translate_value s ty in ok @@ prim ~children:[s'] D_Some - | D_map lst -> - let%bind lst' = bind_map_list (bind_map_pair translate_value) lst in + | D_map lst -> ( + let%bind (k_ty , v_ty) = get_t_map ty in + let%bind lst' = + let aux (k , v) = bind_pair (translate_value k k_ty , translate_value v v_ty) in + bind_map_list aux lst in let sorted = List.sort (fun (x , _) (y , _) -> compare x y) lst' in let aux (a, b) = prim ~children:[a;b] D_Elt in ok @@ seq @@ List.map aux sorted - | D_list lst -> - let%bind lst' = bind_map_list translate_value lst in + ) + | D_list lst -> ( + let%bind e_ty = get_t_list ty in + let%bind lst' = bind_map_list (fun x -> translate_value x e_ty) lst in ok @@ seq lst' - | D_set lst -> - let%bind lst' = bind_map_list translate_value lst in + ) + | D_set lst -> ( + let%bind e_ty = get_t_set ty in + let%bind lst' = bind_map_list (fun x -> translate_value x e_ty) lst in let sorted = List.sort compare lst' in ok @@ seq sorted + ) | D_operation _ -> simple_fail "can't compile an operation" -and translate_function (content:anon_function) : michelson result = - let%bind body = translate_quote_body content in - ok @@ seq [ body ] - -and translate_expression ?push_var_name (expr:expression) (env:environment) : (michelson * environment) result = +and translate_expression (expr:expression) (env:environment) : michelson result = let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in let error_message () = Format.asprintf "\n- expr: %a\n- type: %a\n" PP.expression expr PP.type_ ty in - (* let i_skip = i_push_unit in *) - - let return ?prepend_env ?end_env ?(unit_opt = false) code = - let code = - if unit_opt && push_var_name <> None - then seq [code ; i_push_unit] - else code - in - let%bind env' = - match (prepend_env , end_env , push_var_name) with - | (Some _ , Some _ , _) -> - simple_fail ("two args to return at " ^ __LOC__) - | None , None , None -> - ok @@ Environment.add ("_tmp_expression" , ty) env - | None , None , Some push_var_name -> - ok @@ Environment.add (push_var_name , ty) env - | Some prepend_env , None , None -> - ok @@ Environment.add ("_tmp_expression" , ty) prepend_env - | Some prepend_env , None , Some push_var_name -> - ok @@ Environment.add (push_var_name , ty) prepend_env - | None , Some end_env , None -> - ok end_env - | None , Some end_env , Some push_var_name -> ( - if unit_opt - then ok @@ Environment.add (push_var_name , ty) end_env - else ok end_env - ) - in - let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in - let%bind output_type = Compiler_type.type_ ty in - let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment env' in - let error_message () = - let%bind schema_michelsons = Compiler_type.environment env in - ok @@ Format.asprintf - "expression : %a\ncode : %a\npreenv : %a\npostenv : %a\nschema type : %a\noutput type : %a" - PP.expression expr - Michelson.pp code - PP.environment env - PP.environment env' - PP_helpers.(list_sep Michelson.pp (const ".")) schema_michelsons - Michelson.pp output_type - in - let%bind _ = - Trace.trace_tzresult_lwt_r - (fun () -> - let%bind error_message = error_message () in - ok @@ (fun () -> error (thunk "error parsing expression code") - (fun () -> error_message) - ())) @@ - Memory_proto_alpha.parse_michelson code - input_stack_ty output_stack_ty - in - ok (code , env') - in + let return code = ok code in trace (error (thunk "compiling expression") error_message) @@ match expr' with - | E_skip -> return ~end_env:env ~unit_opt:true @@ seq [] - | E_environment_capture c -> - let%bind code = Compiler_environment.pack_select env c in - return @@ code - | E_environment_load (expr , load_env) -> ( - let%bind (expr' , _) = translate_expression ~push_var_name:"env_to_load" expr env in - let%bind clear = Compiler_environment.select env [] in - let%bind unpack = Compiler_environment.unpack load_env in - return ~end_env:load_env @@ seq [ - expr' ; - dip clear ; - unpack ; - ] - ) - | E_environment_select sub_env -> - let%bind code = Compiler_environment.select_env env sub_env in - return ~end_env:sub_env @@ seq [ - code ; - ] - | E_environment_return expr -> ( - let%bind (expr' , env) = translate_expression ~push_var_name:"return_clause" expr env in - let%bind (code , cleared_env) = Compiler_environment.clear env in - return ~end_env:cleared_env @@ seq [ - expr' ; - code ; - ] - ) + | E_skip -> return @@ i_push_unit | E_literal v -> - let%bind v = translate_value v in + let%bind v = translate_value v ty in let%bind t = Compiler_type.type_ ty in return @@ i_push t v | E_application(f, arg) -> ( match Combinators.Expression.get_type f with | T_function _ -> ( trace (simple_error "Compiling quote application") @@ - let%bind (f , env') = translate_expression ~push_var_name:"application_f" f env in - let%bind (arg , _) = translate_expression ~push_var_name:"application_arg" arg env' in + let%bind f = translate_expression f env in + let%bind arg = translate_expression arg env in return @@ seq [ i_comment "quote application" ; i_comment "get f" ; @@ -218,23 +159,9 @@ and translate_expression ?push_var_name (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 ~push_var_name:"closure_arg" arg env in - let%bind (f' , env'') = translate_expression ~push_var_name:"closure_f" f env' in - let%bind f_ty = Compiler_type.type_ f.type_value in + let%bind arg' = translate_expression arg env in + let%bind f' = translate_expression f env 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 "\nEnv. %a\nEnv'. %a\nEnv''. %a\nclosure. %a ; %a ; %a\narg. %a\n" - PP.environment env - 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" ; @@ -253,9 +180,9 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m let%bind code = Compiler_environment.get env x in return code | E_sequence (a , b) -> ( - let%bind (a' , env_a) = translate_expression a env in - let%bind (b' , env_b) = translate_expression b env_a in - return ~end_env:env_b @@ seq [ + let%bind a' = translate_expression a env in + let%bind b' = translate_expression b env in + return @@ seq [ a' ; b' ; ] @@ -264,12 +191,12 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m let module L = Logger.Stateful() in let%bind lst' = let aux env expr = - let%bind (code , env') = translate_expression ~push_var_name:"constant_argx" expr env in + let%bind code = translate_expression expr env in L.log @@ Format.asprintf "\n%a -> %a in %a\n" PP.expression expr Michelson.pp code PP.environment env ; - ok (env' , code) + ok (env , code) in bind_fold_map_right_list aux env lst in let%bind predicate = get_predicate str ty lst in @@ -312,24 +239,22 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m let%bind o' = Compiler_type.type_ o in return @@ i_none o' | E_if_bool (c, a, b) -> ( - let%bind (c' , env') = translate_expression ~push_var_name:"bool_condition" c env in - let%bind popped = Compiler_environment.pop env' in - let%bind (a' , env_a') = translate_expression ~push_var_name:"if_true" a popped in - let%bind (b' , _env_b') = translate_expression ~push_var_name:"if_false" b popped in + let%bind c' = translate_expression c env in + let%bind a' = translate_expression a env in + let%bind b' = translate_expression b env in let%bind code = ok (seq [ c' ; i_if a' b' ; ]) in - return ~end_env:env_a' code + return code ) | E_if_none (c, n, (ntv , s)) -> ( - let%bind (c' , env') = translate_expression ~push_var_name:"if_none_condition" c env in - let%bind popped = Compiler_environment.pop env' in - let%bind (n' , _) = translate_expression ~push_var_name:"if_none" n popped in - let s_env = Environment.add ntv popped in - let%bind (s' , s_env') = translate_expression ~push_var_name:"if_some" s s_env in - let%bind popped' = Compiler_environment.pop s_env' in - let%bind restrict_s = Compiler_environment.select_env popped' popped in + let%bind c' = translate_expression c env in + let%bind n' = translate_expression n env in + let s_env = Environment.add ntv env in + let%bind s' = translate_expression s s_env in + let%bind popped' = Compiler_environment.pop s_env in + let%bind restrict_s = Compiler_environment.select_env popped' env in let%bind code = ok (seq [ c' ; i_if_none n' (seq [ @@ -341,11 +266,11 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m return code ) | E_if_left (c, (l_ntv , l), (r_ntv , r)) -> ( - let%bind (c' , _env') = translate_expression ~push_var_name:"if_left_cond" c env in + let%bind c' = translate_expression c env in let l_env = Environment.add l_ntv env in - let%bind (l' , _l_env') = translate_expression ~push_var_name:"if_left" l l_env in + let%bind l' = translate_expression l l_env in let r_env = Environment.add r_ntv env in - let%bind (r' , _r_env') = translate_expression ~push_var_name:"if_right" r r_env in + let%bind r' = translate_expression r r_env in let%bind restrict_l = Compiler_environment.select_env l_env env in let%bind restrict_r = Compiler_environment.select_env r_env env in let%bind code = ok (seq [ @@ -364,13 +289,13 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m return code ) | E_let_in (v , expr , body) -> ( - let%bind (expr' , expr_env) = translate_expression ~push_var_name:"let_expr" expr env in + let%bind expr' = translate_expression expr env in let%bind env' = - let%bind popped = Compiler_environment.pop expr_env in + let%bind popped = Compiler_environment.pop env in ok @@ Environment.add v popped in - let%bind (body' , body_env) = translate_expression ~push_var_name:"let_body" body env' in + let%bind body' = translate_expression body env' in let%bind restrict = - let%bind popped = Compiler_environment.pop body_env in + let%bind popped = Compiler_environment.pop env in Compiler_environment.select_env popped env in let%bind code = ok (seq [ expr' ; @@ -381,29 +306,29 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m return code ) | E_iterator (name , (v , body) , expr) -> ( - let%bind (expr' , expr_env) = translate_expression ~push_var_name:"iter_expr" expr env in - let%bind popped = Compiler_environment.pop expr_env in + let%bind expr' = translate_expression expr env in + let%bind popped = Compiler_environment.pop env in let%bind env' = ok @@ Environment.add v popped in - let%bind (body' , body_env) = translate_expression ~push_var_name:"iter_body" body env' in + let%bind body' = translate_expression body env' in match name with | "ITER" -> ( let%bind restrict = - Compiler_environment.select_env body_env popped in + Compiler_environment.select_env env popped in let%bind code = ok (seq [ expr' ; i_iter (seq [body' ; restrict]) ; ]) in - return ~end_env:popped code + return code ) | "MAP" -> ( let%bind restrict = - let%bind popped' = Compiler_environment.pop body_env in + let%bind popped' = Compiler_environment.pop env in Compiler_environment.select_env popped' popped in let%bind code = ok (seq [ expr' ; i_map (seq [body' ; dip restrict]) ; ]) in - return ~prepend_env:popped code + return code ) | s -> ( let error = error (thunk "bad iterator") (thunk s) in @@ -411,8 +336,8 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m ) ) | E_assignment (name , lrs , expr) -> ( - let%bind (expr' , env') = translate_expression ~push_var_name:"assignment_expr" expr env in - let%bind get_code = Compiler_environment.get env' name in + let%bind expr' = translate_expression expr env in + let%bind get_code = Compiler_environment.get env name in let modify_code = let aux acc step = match step with | `Left -> seq [dip i_unpair ; acc ; i_pair] @@ -433,7 +358,7 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m in error title content in trace error @@ - return ~end_env:env ~unit_opt:true @@ seq [ + return @@ seq [ i_comment "assign: start # env" ; expr' ; i_comment "assign: compute rhs # rhs : env" ; @@ -448,11 +373,11 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m ] ) | E_while (expr , block) -> ( - let%bind (expr' , env') = translate_expression ~push_var_name:"while_expr" expr env in - let%bind popped = Compiler_environment.pop env' in - let%bind (block' , env'') = translate_expression block popped in - let%bind restrict_block = Compiler_environment.select_env env'' popped in - return ~end_env:env ~unit_opt:true @@ seq [ + let%bind expr' = translate_expression expr env in + let%bind popped = Compiler_environment.pop env in + let%bind block' = translate_expression block popped in + let%bind restrict_block = Compiler_environment.select_env env popped in + return @@ seq [ expr' ; prim ~children:[seq [ block' ; @@ -461,39 +386,14 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m ] ) -and translate_quote_body ({result ; binder ; input} as f:anon_function) : michelson result = +and translate_quote_body ({result ; binder} : anon_function) input : michelson result = let env = Environment.(add (binder , input) empty) in - let%bind (expr , env') = translate_expression result env in + let%bind expr = translate_expression result env in let code = seq [ i_comment "function result" ; expr ; ] in - let%bind _assert_type = - let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ f.input in - let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ f.output in - let input_stack_ty = Stack.(input_ty @: nil) in - let output_stack_ty = Stack.(output_ty @: nil) in - let error_message () = - Format.asprintf - "\nCode : %a\nMichelson code : %a\ninput : %a\noutput : %a\nstart env : %a\nend env : %a\n" - PP.expression result - Michelson.pp code - PP.type_ f.input - PP.type_ f.output - PP.environment env - PP.environment env' - in - let%bind _ = - Trace.trace_tzresult_lwt ( - error (thunk "error parsing quote code") error_message - ) @@ - Proto_alpha_utils.Memory_proto_alpha.parse_michelson code - input_stack_ty output_stack_ty - in - ok () - in - ok code type compiled_program = { @@ -502,12 +402,12 @@ type compiled_program = { body : michelson ; } -let get_main : program -> string -> anon_function result = fun p entry -> +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 - | (E_literal (D_function content) , T_function _) + | (E_literal (D_function content) , T_function ty) when name = entry -> - Some content + Some (content , ty) | _ -> None in let%bind main = @@ -517,18 +417,17 @@ let get_main : program -> string -> anon_function result = fun p entry -> ok main let translate_program (p:program) (entry:string) : compiled_program result = - let%bind main = get_main p entry in - let {input;output} : anon_function = main in - let%bind body = translate_quote_body main in + let%bind (main , (input , output)) = get_main p entry in + let%bind body = translate_quote_body main input in let%bind input = Compiler_type.Ty.type_ input in let%bind output = Compiler_type.Ty.type_ output in ok ({input;output;body}:compiled_program) -let translate_entry (p:anon_function) : compiled_program result = - let {input;output} : anon_function = p in +let translate_entry (p:anon_function) ty : compiled_program result = + let (input , output) = ty in let%bind body = trace (simple_error "compile entry body") @@ - translate_quote_body p in + translate_quote_body p input in let%bind input = Compiler_type.Ty.type_ input in let%bind output = Compiler_type.Ty.type_ output in ok ({input;output;body}:compiled_program) @@ -547,11 +446,11 @@ them. please report this to the developers." in end open Errors -let translate_contract : anon_function -> michelson result = fun f -> +let translate_contract : anon_function -> _ -> michelson result = fun f ty -> let%bind compiled_program = trace_strong (corner_case ~loc:__LOC__ "compiling") @@ - translate_entry f in - let%bind (param_ty , storage_ty) = Combinators.get_t_pair f.input in + translate_entry f ty in + let%bind (param_ty , storage_ty) = Combinators.get_t_pair (fst 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_program.body in diff --git a/src/main/run_mini_c.ml b/src/main/run_mini_c.ml index 5c8f12e5d..725ad67f6 100644 --- a/src/main/run_mini_c.ml +++ b/src/main/run_mini_c.ml @@ -22,7 +22,7 @@ let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in ok (Ex_typed_value (output_ty, output)) -let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:value) : value result = +let run_entry ?(debug_michelson = false) ?options (entry:anon_function) ty (input:value) : value result = let%bind compiled = let error = let title () = "compile entry" in @@ -31,13 +31,13 @@ let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:v in error title content in trace error @@ - translate_entry entry in - let%bind input_michelson = translate_value input in + translate_entry entry ty in + let%bind input_michelson = translate_value input (fst ty) in if debug_michelson then ( Format.printf "Program: %a\n" Michelson.pp compiled.body ; Format.printf "Expression: %a\n" PP.expression entry.result ; Format.printf "Input: %a\n" PP.value input ; - Format.printf "Input Type: %a\n" PP.type_ entry.input ; + Format.printf "Input Type: %a\n" PP.type_ (fst ty) ; Format.printf "Compiled Input: %a\n" Michelson.pp input_michelson ; ) ; let%bind ex_ty_value = run_aux ?options compiled input_michelson in diff --git a/src/main/run_source.ml b/src/main/run_source.ml index a0a18be96..1a5eaa431 100644 --- a/src/main/run_source.ml +++ b/src/main/run_source.ml @@ -47,8 +47,8 @@ include struct end let transpile_value - (e:Ast_typed.annotated_expression) : Mini_c.value result = - let%bind f = + (e:Ast_typed.annotated_expression) : (Mini_c.value * _) result = + let%bind (f , ty) = let open Transpiler in let (f , _) = functionalize e in let%bind main = translate_main f e.location in @@ -56,8 +56,8 @@ let transpile_value in let input = Mini_c.Combinators.d_unit in - let%bind r = Run_mini_c.run_entry f input in - ok r + let%bind r = Run_mini_c.run_entry f ty input in + ok (r , snd ty) let parsify_pascaligo = fun source -> let%bind raw = @@ -148,12 +148,12 @@ let compile_contract_file : string -> string -> s_syntax -> string result = fun let%bind typed = trace (simple_error "typing") @@ Typer.type_program simplified in - let%bind mini_c = + let%bind (mini_c , mini_c_ty) = trace (simple_error "transpiling") @@ Transpiler.translate_entry typed entry_point in let%bind michelson = trace (simple_error "compiling") @@ - Compiler.translate_contract mini_c in + Compiler.translate_contract mini_c mini_c_ty in let str = Format.asprintf "%a" Michelson.pp_stripped michelson in ok str @@ -184,12 +184,12 @@ let compile_contract_parameter : string -> string -> string -> s_syntax -> strin let%bind () = trace (simple_error "expression type doesn't match type parameter") @@ Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in - let%bind mini_c = + let%bind (mini_c , mini_c_ty) = trace (simple_error "transpiling expression") @@ transpile_value typed in let%bind michelson = trace (simple_error "compiling expression") @@ - Compiler.translate_value mini_c in + Compiler.translate_value mini_c mini_c_ty in let str = Format.asprintf "%a" Michelson.pp_stripped michelson in ok str @@ -223,12 +223,12 @@ let compile_contract_storage : string -> string -> string -> s_syntax -> string let%bind () = trace (simple_error "expression type doesn't match type storage") @@ Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in - let%bind mini_c = + let%bind (mini_c , mini_c_ty) = trace (simple_error "transpiling expression") @@ transpile_value typed in let%bind michelson = trace (simple_error "compiling expression") @@ - Compiler.translate_value mini_c in + Compiler.translate_value mini_c mini_c_ty in let str = Format.asprintf "%a" Michelson.pp_stripped michelson in ok str diff --git a/src/main/run_typed.ml b/src/main/run_typed.ml index 788a10406..fc136c63c 100644 --- a/src/main/run_typed.ml +++ b/src/main/run_typed.ml @@ -2,7 +2,7 @@ open Trace let transpile_value (e:Ast_typed.annotated_expression) : Mini_c.value result = - let%bind f = + let%bind (f , ty) = let open Transpiler in let (f , _) = functionalize e in let%bind main = translate_main f e.location in @@ -10,7 +10,7 @@ let transpile_value in let input = Mini_c.Combinators.d_unit in - let%bind r = Run_mini_c.run_entry f input in + let%bind r = Run_mini_c.run_entry f ty input in ok r let evaluate_typed @@ -18,12 +18,12 @@ let evaluate_typed ?options (entry:string) (program:Ast_typed.program) : Ast_typed.annotated_expression result = trace (simple_error "easy evaluate typed") @@ let%bind result = - let%bind mini_c_main = + let%bind (mini_c_main , ty) = Transpiler.translate_entry program entry in (if debug_mini_c then Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) ) ; - Run_mini_c.run_entry ?options ~debug_michelson mini_c_main (Mini_c.Combinators.d_unit) + Run_mini_c.run_entry ?options ~debug_michelson mini_c_main ty (Mini_c.Combinators.d_unit) in let%bind typed_result = let%bind typed_main = Ast_typed.get_entry program entry in @@ -42,7 +42,7 @@ let run_typed Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input)) in - let%bind mini_c_main = + let%bind (mini_c_main , ty) = trace (simple_error "transpile mini_c entry") @@ Transpiler.translate_entry program entry in (if debug_mini_c then @@ -59,7 +59,7 @@ let run_typed in error title content in trace error @@ - Run_mini_c.run_entry ~debug_michelson ?options mini_c_main mini_c_value in + Run_mini_c.run_entry ~debug_michelson ?options mini_c_main ty mini_c_value in let%bind typed_result = let%bind main_result_type = let%bind typed_main = Ast_typed.get_functional_entry program entry in diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index 3d0e3f065..44d8f2719 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -66,10 +66,6 @@ and value_assoc ppf : (value * value) -> unit = fun (a, b) -> fprintf ppf "%a -> %a" value a value b and expression' ppf (e:expression') = match e with - | E_environment_capture s -> fprintf ppf "capture(%a)" (list_sep string (const " ; ")) s - | E_environment_load (expr , env) -> fprintf ppf "load %a in %a" expression expr environment env - | E_environment_select env -> fprintf ppf "select %a" environment env - | E_environment_return expr -> fprintf ppf "return (%a)" expression expr | E_skip -> fprintf ppf "skip" | E_variable v -> fprintf ppf "V(%s)" v | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b @@ -101,11 +97,9 @@ and expression_with_type : _ -> expression -> _ = fun ppf e -> expression' e.content type_ e.type_value -and function_ ppf ({binder ; input ; output ; result}:anon_function) = - fprintf ppf "fun (%s:%a) : %a (%a)" +and function_ ppf ({binder ; result}:anon_function) = + fprintf ppf "fun %s -> (%a)" binder - type_ input - type_ output expression result and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e diff --git a/src/mini_c/combinators.ml b/src/mini_c/combinators.ml index 3aa4d5726..f7342987e 100644 --- a/src/mini_c/combinators.ml +++ b/src/mini_c/combinators.ml @@ -82,6 +82,10 @@ let get_t_pair (t:type_value) = match t with | T_pair (a, b) -> ok (a, b) | _ -> simple_fail "not a type pair" +let get_t_or (t:type_value) = match t with + | T_or (a, b) -> ok (a, b) + | _ -> simple_fail "not a type or" + let get_t_map (t:type_value) = match t with | T_map kv -> ok kv | _ -> simple_fail "not a type map" @@ -142,9 +146,9 @@ let t_deep_closure x y z : type_value = T_deep_closure ( x , y , z ) let t_pair x y : type_value = T_pair ( x , y ) let t_union x y : type_value = T_or ( x , y ) -let quote binder input output result : anon_function = +let quote binder result : anon_function = { - binder ; input ; output ; + binder ; result ; } @@ -160,15 +164,15 @@ let e_let_int v tv expr body : expression = Expression.(make_tpl ( let ez_e_sequence a b : expression = Expression.(make_tpl (E_sequence (make_tpl (a , t_unit) , b) , get_type b)) -let ez_e_return e : expression = Expression.(make_tpl ((E_environment_return e) , get_type e)) +let ez_e_return e : expression = e let d_unit : value = D_unit -let basic_quote i o expr : anon_function result = - ok @@ quote "input" i o (ez_e_return expr) +let basic_quote expr : anon_function result = + ok @@ quote "input" (ez_e_return expr) let basic_int_quote expr : anon_function result = - basic_quote t_int t_int expr + basic_quote expr let environment_wrap pre_environment post_environment = { pre_environment ; post_environment } diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index 3e9a69819..412a2625c 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -11,7 +11,7 @@ type type_base = type type_value = | T_pair of (type_value * type_value) | T_or of type_value * type_value - | T_function of type_value * type_value + | T_function of (type_value * type_value) | T_deep_closure of environment * type_value * type_value | T_base of type_base | T_map of (type_value * type_value) @@ -57,10 +57,6 @@ and selector = var_name list and expression' = | E_literal of value - | E_environment_capture of selector - | E_environment_select of environment - | E_environment_load of (expression * environment) - | E_environment_return of expression | E_skip | E_constant of string * expression list | E_application of expression * expression @@ -75,7 +71,6 @@ and expression' = | E_if_left of expression * ((var_name * type_value) * expression) * ((var_name * type_value) * expression) | E_let_in of ((var_name * type_value) * expression * expression) | E_sequence of (expression * expression) - (* | E_sequence_drop of (expression * expression) *) | E_assignment of (string * [`Left | `Right] list * expression) | E_while of expression * expression @@ -91,8 +86,6 @@ and toplevel_statement = assignment * environment_wrap and anon_function = { binder : string ; - input : type_value ; - output : type_value ; result : expression ; } diff --git a/src/test/compiler_tests.ml b/src/test/compiler_tests.ml index af26e74d4..0407c281f 100644 --- a/src/test/compiler_tests.ml +++ b/src/test/compiler_tests.ml @@ -5,7 +5,7 @@ open Test_helpers let run_entry_int (e:anon_function) (n:int) : int result = let param : value = D_int n in - let%bind result = Main.Run_mini_c.run_entry e param in + let%bind result = Main.Run_mini_c.run_entry e (t_int , t_int) param in match result with | D_int n -> ok n | _ -> simple_fail "result is not an int" diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 3aed3edb5..facd0c717 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -547,29 +547,19 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun env l -> let { binder ; input_type ; output_type ; result } : AST.lambda = l in (* Deep capture. Capture the relevant part of the environment. *) - let%bind (fv , c_env , c_tv) = + let%bind c_env = let free_variables = Ast_typed.Free_variables.lambda [] l in let sub_env = Mini_c.Environment.select free_variables env in - let tv = Environment.closure_representation sub_env in - ok (free_variables , sub_env , tv) in + ok sub_env in let%bind (f_expr , input_tv , output_tv) = let%bind raw_input = translate_type input_type in - let init_env = Environment.(add (binder , raw_input) c_env) in - let input = Environment.closure_representation init_env in let%bind output = translate_type output_type in let%bind result = translate_annotated_expression result in - let result = - let load_expr = Expression.make_tpl (E_variable binder , input) in - ez_e_return @@ ez_e_sequence (E_environment_load (load_expr , init_env)) result in - let tv = Mini_c.t_function input output in - let f_literal = D_function { binder ; input ; output ; result } in - let expr = Expression.make_tpl (E_literal f_literal , tv) in - ok (expr , raw_input , output) in - let%bind c_expr = - ok @@ Expression.make_tpl (E_environment_capture fv , c_tv) in - let expr = Expression.pair f_expr c_expr in + let f_literal = D_function { binder ; result } in + let expr' = E_literal f_literal in + ok (expr' , raw_input , output) in let tv = Mini_c.t_deep_closure c_env input_tv output_tv in - ok @@ Expression.make_tpl (expr , tv) + ok @@ Expression.make_tpl (f_expr , tv) and translate_lambda env l = let { binder ; input_type ; output_type ; result } : AST.lambda = l in @@ -583,7 +573,7 @@ and translate_lambda env l = let%bind input = translate_type input_type in let%bind output = translate_type output_type in let tv = Combinators.t_function input output in - let content = D_function {binder;input;output;result=result'} in + let content = D_function {binder;result=result'} in ok @@ Combinators.Expression.make_tpl (E_literal content , tv) ) | _ -> ( @@ -608,10 +598,10 @@ let translate_program (lst:AST.program) : program result = let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in ok statements -let translate_main (l:AST.lambda) loc : anon_function result = +let translate_main (l:AST.lambda) loc : (anon_function * _) result = let%bind expr = translate_lambda Environment.empty l in - match Combinators.Expression.get_content expr with - | E_literal (D_function f) -> ok f + match expr.content , expr.type_value with + | E_literal (D_function f) , T_function ty -> ok (f , ty) | _ -> fail @@ not_functional_main loc (* From an expression [expr], build the expression [fun () -> expr] *) @@ -625,7 +615,7 @@ let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value = result = e ; }, Combinators.(t_function (t_unit ()) t ()) -let translate_entry (lst:AST.program) (name:string) : anon_function result = +let translate_entry (lst:AST.program) (name:string) : (anon_function * _) result = let rec aux acc (lst:AST.program) = let%bind acc = acc in match lst with From d53f0058c63d6c9d2d7699de1ac3e19e6c47c379 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Tue, 20 Aug 2019 16:19:00 -0700 Subject: [PATCH 2/8] Various compiler fixes --- src/compiler/compiler_program.ml | 94 ++++++++++---------------------- 1 file changed, 29 insertions(+), 65 deletions(-) diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index a1d03a1c2..c85879c13 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -91,13 +91,9 @@ let rec translate_value (v:value) ty : michelson result = match v with let%bind b' = translate_value b b_ty in ok @@ prim ~children:[b'] D_Right ) - | D_function { binder ; result } -> ( + | D_function func -> ( match ty with - | T_function (in_ty , _) -> ( - let env = Mini_c.Environment.of_list [ (binder , in_ty) ] in - let%bind body = translate_expression result env in - ok body - ) + | T_function (in_ty , _) -> translate_quote_body func in_ty | T_deep_closure _ -> simple_fail "no support for closures yet" | _ -> simple_fail "expected function type" ) @@ -153,27 +149,13 @@ and translate_expression (expr:expression) (env:environment) : michelson result i_comment "get f" ; f ; i_comment "get arg" ; - arg ; + dip arg ; + i_swap ; prim I_EXEC ; ] ) - | T_deep_closure (small_env, input_ty , _) -> ( - trace (simple_error "Compiling deep closure application") @@ - let%bind arg' = translate_expression arg env in - let%bind f' = translate_expression f env in - let%bind append_closure = Compiler_environment.add_packed_anon small_env input_ty in - return @@ seq [ - i_comment "closure application" ; - i_comment "arg" ; - arg' ; - i_comment "f'" ; - f' ; i_unpair ; - i_comment "append" ; - dip @@ seq [i_swap ; append_closure] ; - i_comment "exec" ; - i_swap ; i_exec ; - ] - ) + (* TODO *) + (* | T_deep_closure (small_env, input_ty , _) -> () *) | _ -> simple_fail "E_applicationing something not appliable" ) | E_variable x -> @@ -184,23 +166,22 @@ and translate_expression (expr:expression) (env:environment) : michelson result let%bind b' = translate_expression b env in return @@ seq [ a' ; + i_drop ; b' ; ] ) | E_constant(str, lst) -> let module L = Logger.Stateful() in - let%bind lst' = - let aux env expr = - let%bind code = translate_expression expr env in + let%bind pre_code = + let aux code expr = + let%bind expr_code = translate_expression expr env in L.log @@ Format.asprintf "\n%a -> %a in %a\n" PP.expression expr - Michelson.pp code + Michelson.pp expr_code PP.environment env ; - ok (env , code) - in - bind_fold_map_right_list aux env lst in + ok (seq [ expr_code ; dip code ]) in + bind_fold_right_list aux (seq []) lst in let%bind predicate = get_predicate str ty lst in - let pre_code = seq @@ List.rev lst' in let%bind code = match (predicate, List.length lst) with | Constant c, 0 -> ok @@ seq [ pre_code ; @@ -253,13 +234,11 @@ and translate_expression (expr:expression) (env:environment) : michelson result let%bind n' = translate_expression n env in let s_env = Environment.add ntv env in let%bind s' = translate_expression s s_env in - let%bind popped' = Compiler_environment.pop s_env in - let%bind restrict_s = Compiler_environment.select_env popped' env in let%bind code = ok (seq [ c' ; i_if_none n' (seq [ s' ; - dip restrict_s ; + dip i_drop ; ]) ; ]) in @@ -271,18 +250,16 @@ and translate_expression (expr:expression) (env:environment) : michelson result let%bind l' = translate_expression l l_env in let r_env = Environment.add r_ntv env in let%bind r' = translate_expression r r_env in - let%bind restrict_l = Compiler_environment.select_env l_env env in - let%bind restrict_r = Compiler_environment.select_env r_env env in let%bind code = ok (seq [ c' ; i_if_left (seq [ l' ; i_comment "restrict left" ; - dip restrict_l ; + dip i_drop ; ]) (seq [ r' ; i_comment "restrict right" ; - dip restrict_r ; + dip i_drop ; ]) ; ]) in @@ -290,43 +267,31 @@ and translate_expression (expr:expression) (env:environment) : michelson result ) | E_let_in (v , expr , body) -> ( let%bind expr' = translate_expression expr env in - let%bind env' = - let%bind popped = Compiler_environment.pop env in - ok @@ Environment.add v popped in - let%bind body' = translate_expression body env' in - let%bind restrict = - let%bind popped = Compiler_environment.pop env in - Compiler_environment.select_env popped env in + let%bind body' = translate_expression body (Environment.add v env) in let%bind code = ok (seq [ expr' ; body' ; i_comment "restrict let" ; - dip restrict ; + dip i_drop ; ]) in return code ) | E_iterator (name , (v , body) , expr) -> ( let%bind expr' = translate_expression expr env in - let%bind popped = Compiler_environment.pop env in - let%bind env' = ok @@ Environment.add v popped in - let%bind body' = translate_expression body env' in + let%bind body' = translate_expression body (Environment.add v env) in match name with | "ITER" -> ( - let%bind restrict = - Compiler_environment.select_env env popped in let%bind code = ok (seq [ expr' ; - i_iter (seq [body' ; restrict]) ; + i_iter (seq [body' ; dip i_drop]) ; + i_push_unit ; ]) in return code ) | "MAP" -> ( - let%bind restrict = - let%bind popped' = Compiler_environment.pop env in - Compiler_environment.select_env popped' popped in let%bind code = ok (seq [ expr' ; - i_map (seq [body' ; dip restrict]) ; + i_map (seq [body' ; dip i_drop]) ; ]) in return code ) @@ -362,27 +327,25 @@ and translate_expression (expr:expression) (env:environment) : michelson result i_comment "assign: start # env" ; expr' ; i_comment "assign: compute rhs # rhs : env" ; - get_code ; - i_comment "assign: get name # name : rhs : env" ; - i_swap ; - i_comment "assign: swap # rhs : name : env" ; + dip get_code ; + i_comment "assign: get name # rhs : name : env" ; modify_code ; i_comment "assign: modify code # name+rhs : env" ; set_code ; i_comment "assign: set new # new_env" ; + i_push_unit ; ] ) | E_while (expr , block) -> ( let%bind expr' = translate_expression expr env in - let%bind popped = Compiler_environment.pop env in - let%bind block' = translate_expression block popped in - let%bind restrict_block = Compiler_environment.select_env env popped in + let%bind block' = translate_expression block env in return @@ seq [ expr' ; prim ~children:[seq [ block' ; - restrict_block ; + i_drop ; expr']] I_LOOP ; + i_push_unit ; ] ) @@ -392,6 +355,7 @@ and translate_quote_body ({result ; binder} : anon_function) input : michelson r let code = seq [ i_comment "function result" ; expr ; + dip i_drop ; ] in ok code From 31591f1669099804b2446702ab1003e00e23f0a0 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Tue, 20 Aug 2019 16:19:11 -0700 Subject: [PATCH 3/8] Comment out tests needing closure (TODO) --- src/test/integration_tests.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 0a978b6e5..baeb0fa03 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -641,12 +641,12 @@ let main = test_suite "Integration (End to End)" [ test "arithmetic" arithmetic ; test "bitiwse_arithmetic" bitwise_arithmetic ; test "string_arithmetic" string_arithmetic ; - test "set_arithmetic" set_arithmetic ; + (* test "set_arithmetic" set_arithmetic ; *) test "unit" unit_expression ; test "string" string_expression ; test "option" option ; - test "map" map ; - test "list" list ; + (* test "map" map ; *) + (* test "list" list ; *) test "loop" loop ; test "matching" matching ; test "declarations" declarations ; @@ -657,9 +657,9 @@ let main = test_suite "Integration (End to End)" [ test "super counter contract" super_counter_contract ; test "super counter contract" super_counter_contract_mligo ; test "dispatch counter contract" dispatch_counter_contract ; - test "closure" closure ; - test "shared function" shared_function ; - test "higher order" higher_order ; + (* test "closure" closure ; *) + (* test "shared function" shared_function ; *) + (* test "higher order" higher_order ; *) test "basic (mligo)" basic_mligo ; test "counter contract (mligo)" counter_mligo ; test "let-in (mligo)" let_in_mligo ; From bd987613d5a42e37c40ff56b128e5f7e489efca3 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Tue, 20 Aug 2019 16:19:31 -0700 Subject: [PATCH 4/8] This stuff is now unused --- src/compiler/compiler_environment.ml | 106 --------------------------- src/mini_c/environment.ml | 6 -- 2 files changed, 112 deletions(-) diff --git a/src/compiler/compiler_environment.ml b/src/compiler/compiler_environment.ml index 386412f3f..c53dea188 100644 --- a/src/compiler/compiler_environment.ml +++ b/src/compiler/compiler_environment.ml @@ -41,109 +41,3 @@ let set : environment -> string -> michelson result = fun e s -> let code = aux position in ok code - -let add : environment -> (string * type_value) -> michelson result = fun _ (_s , _) -> - let code = seq [] in - - ok code - -let select ?(rev = false) ?(keep = true) : environment -> string list -> michelson result = fun e lst -> - let module L = Logger.Stateful() in - let e_lst = - let e_lst = Environment.to_list e in - let aux selector (s , _) = - L.log @@ Format.asprintf "Selector : %a\n" PP_helpers.(list_sep string (const " , ")) selector ; - match List.mem s selector with - | true -> List.remove_element s selector , keep - | false -> selector , not keep in - let e_lst' = - if rev = keep - then List.fold_map aux lst e_lst - else List.fold_map_right aux lst e_lst - in - let e_lst'' = List.combine e_lst e_lst' in - e_lst'' in - let code = - let aux = fun code (_ , b) -> - match b with - | false -> seq [dip code ; i_drop] - | true -> dip code - in - List.fold_right' aux (seq []) e_lst in - - ok code - -let select_env : environment -> environment -> michelson result = fun source filter -> - let lst = Environment.get_names filter in - select source lst - -let clear : environment -> (michelson * environment) result = fun e -> - let lst = Environment.get_names e in - let%bind first_name = - trace_option (simple_error "try to clear empty env") @@ - List.nth_opt lst 0 in - let%bind code = select ~rev:true e [ first_name ] in - let e' = Environment.select ~rev:true [ first_name ] e in - ok (code , e') - -let pack : environment -> michelson result = fun e -> - let%bind () = - trace_strong (simple_error "pack empty env") @@ - Assert.assert_true (List.length e <> 0) in - let code = seq @@ List.map (Function.constant i_pair) @@ List.tl e 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 - - 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 - - ok code - - -let pack_select : environment -> string list -> michelson result = fun e lst -> - let module L = Logger.Stateful() in - let e_lst = - let e_lst = Environment.to_list e in - let aux selector (s , _) = - L.log @@ Format.asprintf "Selector : %a\n" PP_helpers.(list_sep string (const " , ")) selector ; - match List.mem s selector with - | true -> List.remove_element s selector , true - | false -> selector , false in - let e_lst' = List.fold_map_right aux lst e_lst in - let e_lst'' = List.combine e_lst e_lst' in - e_lst'' in - let (_ , code) = - let aux = fun (first , code) (_ , b) -> - match b with - | false -> (first , seq [dip code ; i_swap]) - | true -> (false , - match first with - | true -> i_dup - | false -> seq [dip code ; i_dup ; dip i_pair ; i_swap] - ) - in - List.fold_right' aux (true , seq []) e_lst in - - ok code - -let add_packed_anon : environment -> type_value -> michelson result = fun _ _ -> - let code = seq [i_pair] in - - ok code - -let pop : environment -> environment result = fun e -> - match e with - | [] -> simple_fail "pop empty env" - | _ :: tl -> ok tl diff --git a/src/mini_c/environment.ml b/src/mini_c/environment.ml index 1d7463c48..8b4bb2924 100644 --- a/src/mini_c/environment.ml +++ b/src/mini_c/environment.ml @@ -54,12 +54,6 @@ module Environment (* : ENVIRONMENT *) = struct let fold : _ -> 'a -> t -> 'a = List.fold_left let filter : _ -> t -> t = List.filter - - let closure_representation : t -> type_value = fun t -> - match t with - | [] -> T_base Base_unit - | [ a ] -> snd a - | hd :: tl -> List.fold_left (fun acc cur -> T_pair (acc , snd cur)) (snd hd) tl end include Environment From af588933f4fc8621727ba67c1fcb059e95466b7a Mon Sep 17 00:00:00 2001 From: galfour Date: Wed, 21 Aug 2019 10:28:27 +0200 Subject: [PATCH 5/8] add closures --- src/compiler/compiler_environment.ml | 44 ++++++++++++++++++ src/compiler/compiler_program.ml | 57 +++++++++++++++++------- src/compiler/compiler_type.ml | 31 ++++++++----- src/contracts/closure-1.ligo | 4 ++ src/contracts/closure-2.ligo | 5 +++ src/contracts/closure.ligo | 5 --- src/mini_c/PP.ml | 1 + src/mini_c/types.ml | 1 + src/test/integration_tests.ml | 20 ++++++--- src/test/test_helpers.ml | 4 +- src/transpiler/transpiler.ml | 7 ++- vendors/ligo-utils/simple-utils/trace.ml | 9 +++- 12 files changed, 141 insertions(+), 47 deletions(-) create mode 100644 src/contracts/closure-1.ligo create mode 100644 src/contracts/closure-2.ligo diff --git a/src/compiler/compiler_environment.ml b/src/compiler/compiler_environment.ml index c53dea188..f0fed96c4 100644 --- a/src/compiler/compiler_environment.ml +++ b/src/compiler/compiler_environment.ml @@ -41,3 +41,47 @@ let set : environment -> string -> michelson result = fun e s -> let code = aux position in ok code + +let pack_closure : environment -> selector -> michelson result = fun e lst -> + let%bind () = Assert.assert_true (e <> []) in + + (* Tag environment with selected elements. Only the first occurence + of each name from the selector in the environment is kept. *) + let e_lst = + let e_lst = Environment.to_list e in + let aux selector (s , _) = + match List.mem s selector with + | true -> List.remove_element s selector , true + | false -> selector , false in + let e_lst' = List.fold_map_right aux lst e_lst in + let e_lst'' = List.combine e_lst e_lst' in + e_lst'' + in + + let (_ , code) = + let aux = fun (first , code) (_ , b) -> + match b with + | false -> (first , seq [dip code ; i_swap]) + | true -> (false , + match first with + | true -> i_dup + | false -> seq [dip code ; i_dup ; dip i_pair ; i_swap] + ) + in + List.fold_right' aux (true , seq []) e_lst in + + ok code + +let unpack_closure : environment -> michelson result = fun e -> + let lst = + match e with + | [] -> [] + | _ :: tl -> [ + i_unpair ; + dip @@ seq @@ List.map (Function.constant i_unpair) tl ; + ] + in + + let code = seq lst in + + ok code diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index c85879c13..8a2ae0d2f 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -93,8 +93,7 @@ let rec translate_value (v:value) ty : michelson result = match v with ) | D_function func -> ( match ty with - | T_function (in_ty , _) -> translate_quote_body func in_ty - | T_deep_closure _ -> simple_fail "no support for closures yet" + | T_function (in_ty , _) -> translate_function_body func [] in_ty | _ -> simple_fail "expected function type" ) | D_none -> ok @@ prim D_None @@ -138,24 +137,42 @@ and translate_expression (expr:expression) (env:environment) : michelson result let%bind v = translate_value v ty in let%bind t = Compiler_type.type_ ty in return @@ i_push t v - | E_application(f, arg) -> ( + | E_closure anon -> ( + match ty with + | T_deep_closure (small_env , input_ty , output_ty) -> ( + let selector = List.map fst small_env in + let%bind closure_pack_code = Compiler_environment.pack_closure env selector in + let%bind lambda_ty = Compiler_type.lambda_closure (small_env , input_ty , output_ty) in + let%bind lambda_body_code = translate_function_body anon small_env input_ty in + return @@ seq [ + closure_pack_code ; + i_push lambda_ty lambda_body_code ; + i_pair ; + ] + ) + | _ -> simple_fail "expected closure type" + ) + | E_application (f , arg) -> ( match Combinators.Expression.get_type f with | T_function _ -> ( trace (simple_error "Compiling quote application") @@ let%bind f = translate_expression f env in let%bind arg = translate_expression arg env in return @@ seq [ - i_comment "quote application" ; - i_comment "get f" ; - f ; - i_comment "get arg" ; - dip arg ; - i_swap ; + arg ; + dip f ; + prim I_EXEC ; + ] + ) + | T_deep_closure (_ , _ , _) -> ( + let%bind f_code = translate_expression f env in + let%bind arg_code = translate_expression arg env in + return @@ seq [ + arg_code ; + dip (seq [ f_code ; i_unpair ; i_swap ]) ; i_pair ; prim I_EXEC ; ] ) - (* TODO *) - (* | T_deep_closure (small_env, input_ty , _) -> () *) | _ -> simple_fail "E_applicationing something not appliable" ) | E_variable x -> @@ -349,13 +366,19 @@ and translate_expression (expr:expression) (env:environment) : michelson result ] ) -and translate_quote_body ({result ; binder} : anon_function) input : michelson result = - let env = Environment.(add (binder , input) empty) in - let%bind expr = translate_expression result env in +and translate_function_body ({result ; binder} : anon_function) lst input : michelson result = + let pre_env = Environment.of_list lst in + let env = Environment.(add (binder , input) pre_env) in + let%bind expr_code = translate_expression result env in + let%bind unpack_closure_code = Compiler_environment.unpack_closure pre_env in let code = seq [ + i_comment "unpack closure env" ; + unpack_closure_code ; i_comment "function result" ; - expr ; + expr_code ; + i_comment "remove env" ; dip i_drop ; + seq (List.map (Function.constant (dip i_drop)) lst) ; ] in ok code @@ -382,7 +405,7 @@ let get_main : program -> string -> (anon_function * _) result = fun p entry -> let translate_program (p:program) (entry:string) : compiled_program result = let%bind (main , (input , output)) = get_main p entry in - let%bind body = translate_quote_body main input in + let%bind body = translate_function_body main [] input in let%bind input = Compiler_type.Ty.type_ input in let%bind output = Compiler_type.Ty.type_ output in ok ({input;output;body}:compiled_program) @@ -391,7 +414,7 @@ let translate_entry (p:anon_function) ty : compiled_program result = let (input , output) = ty in let%bind body = trace (simple_error "compile entry body") @@ - translate_quote_body p input in + translate_function_body p [] input in let%bind input = Compiler_type.Ty.type_ input in let%bind output = Compiler_type.Ty.type_ output in ok ({input;output;body}:compiled_program) diff --git a/src/compiler/compiler_type.ml b/src/compiler/compiler_type.ml index 5977db461..96950c88f 100644 --- a/src/compiler/compiler_type.ml +++ b/src/compiler/compiler_type.ml @@ -97,13 +97,17 @@ module Ty = struct let%bind (Ex_ty t') = type_ t in ok @@ Ex_ty Contract_types.(contract t') - and environment_representation = function - | [] -> ok @@ Ex_ty Contract_types.unit - | [a] -> type_ @@ snd a - | a::b -> - let%bind (Ex_ty a) = type_ @@ snd a in - let%bind (Ex_ty b) = environment_representation b in - ok @@ Ex_ty (Contract_types.pair a b) + and environment_representation = fun e -> + match List.rev_uncons_opt e with + | None -> ok @@ Ex_ty Contract_types.unit + | Some (hds , tl) -> ( + let%bind tl_ty = type_ @@ snd tl in + let aux (Ex_ty prec_ty) cur = + let%bind (Ex_ty cur_ty) = type_ @@ snd cur in + ok @@ Ex_ty Contract_types.(pair prec_ty cur_ty) + in + bind_fold_right_list aux tl_ty hds + ) and environment : environment -> Meta_michelson.Stack.ex_stack_ty result = fun env -> let open Meta_michelson in @@ -164,11 +168,10 @@ let rec type_ : type_value -> O.michelson result = let%bind arg = type_ arg in let%bind ret = type_ ret in ok @@ O.prim ~children:[arg;ret] T_lambda - | T_deep_closure (c, arg, ret) -> + | T_deep_closure (c , arg , ret) -> let%bind capture = environment_closure c in - let%bind arg = type_ arg in - let%bind ret = type_ ret in - ok @@ O.t_pair (O.t_lambda (O.t_pair arg capture) ret) capture + let%bind lambda = lambda_closure (c , arg , ret) in + ok @@ O.t_pair lambda capture and environment_element (name, tyv) = let%bind michelson_type = type_ tyv in @@ -178,6 +181,12 @@ and environment = fun env -> bind_map_list type_ @@ List.map snd env +and lambda_closure = fun (c , arg , ret) -> + let%bind capture = environment_closure c in + let%bind arg = type_ arg in + let%bind ret = type_ ret in + ok @@ O.t_lambda (O.t_pair arg capture) ret + and environment_closure = function | [] -> simple_fail "Type of empty env" diff --git a/src/contracts/closure-1.ligo b/src/contracts/closure-1.ligo new file mode 100644 index 000000000..f54cfac37 --- /dev/null +++ b/src/contracts/closure-1.ligo @@ -0,0 +1,4 @@ +function foo (const i : int) : int is + function bar (const j : int) : int is + block { skip } with i + j ; + block { skip } with bar (i) diff --git a/src/contracts/closure-2.ligo b/src/contracts/closure-2.ligo new file mode 100644 index 000000000..5d5b0e721 --- /dev/null +++ b/src/contracts/closure-2.ligo @@ -0,0 +1,5 @@ +function foobar(const i : int) : int is + const j : int = 3 ; + function toto(const k : int) : int is + block { skip } with i + j + k ; + block { skip } with toto(42) diff --git a/src/contracts/closure.ligo b/src/contracts/closure.ligo index d43d5400f..e295ec609 100644 --- a/src/contracts/closure.ligo +++ b/src/contracts/closure.ligo @@ -1,8 +1,3 @@ -function foo (const i : int) : int is - function bar (const j : int) : int is - block { skip } with i + j ; - block { skip } with bar (i) - function toto (const i : int) : int is function tata (const j : int) : int is block { skip } with i + j ; diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index 44d8f2719..7377c4c85 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -67,6 +67,7 @@ and value_assoc ppf : (value * value) -> unit = fun (a, b) -> and expression' ppf (e:expression') = match e with | E_skip -> fprintf ppf "skip" + | E_closure x -> function_ ppf x | E_variable v -> fprintf ppf "V(%s)" v | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b | E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index 412a2625c..fb15ed94b 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -57,6 +57,7 @@ and selector = var_name list and expression' = | E_literal of value + | E_closure of anon_function | E_skip | E_constant of string * expression list | E_application of expression * expression diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index baeb0fa03..275479e63 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -67,9 +67,15 @@ let variant_matching () : unit result = let closure () : unit result = let%bind program = type_file "./contracts/closure.ligo" in + let%bind program_1 = type_file "./contracts/closure-1.ligo" in + let%bind program_2 = type_file "./contracts/closure-2.ligo" in + let%bind _ = + let make_expect = fun n -> (45 + n) in + expect_eq_n_int program_2 "foobar" make_expect + in let%bind () = let make_expect = fun n -> (2 * n) in - expect_eq_n_int program "foo" make_expect + expect_eq_n_int program_1 "foo" make_expect in let%bind _ = let make_expect = fun n -> (4 * n) in @@ -628,6 +634,9 @@ let main = test_suite "Integration (End to End)" [ test "assign" assign ; test "declaration local" declaration_local ; test "complex function" complex_function ; + test "closure" closure ; + test "shared function" shared_function ; + test "higher order" higher_order ; test "variant" variant ; test "variant matching" variant_matching ; test "tuple" tuple ; @@ -641,12 +650,12 @@ let main = test_suite "Integration (End to End)" [ test "arithmetic" arithmetic ; test "bitiwse_arithmetic" bitwise_arithmetic ; test "string_arithmetic" string_arithmetic ; - (* test "set_arithmetic" set_arithmetic ; *) + test "set_arithmetic" set_arithmetic ; test "unit" unit_expression ; test "string" string_expression ; test "option" option ; - (* test "map" map ; *) - (* test "list" list ; *) + test "map" map ; + test "list" list ; test "loop" loop ; test "matching" matching ; test "declarations" declarations ; @@ -657,9 +666,6 @@ let main = test_suite "Integration (End to End)" [ test "super counter contract" super_counter_contract ; test "super counter contract" super_counter_contract_mligo ; test "dispatch counter contract" dispatch_counter_contract ; - (* test "closure" closure ; *) - (* test "shared function" shared_function ; *) - (* test "higher order" higher_order ; *) test "basic (mligo)" basic_mligo ; test "counter contract (mligo)" counter_mligo ; test "let-in (mligo)" let_in_mligo ; diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 071f8b271..3eee3f701 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -132,7 +132,7 @@ let expect_eq_n_aux ?options lst program entry_point make_input make_expected = let result = expect_eq ?options program entry_point input expected in result in - let%bind _ = bind_map_list aux lst in + let%bind _ = bind_map_list_seq aux lst in ok () let expect_eq_n ?options = expect_eq_n_aux ?options [0 ; 1 ; 2 ; 42 ; 163 ; -1] @@ -151,7 +151,7 @@ let expect_eq_b program entry_point make_expected = let expected = make_expected b in expect_eq program entry_point input expected in - let%bind _ = bind_map_list aux [false ; true] in + let%bind _ = bind_map_list_seq aux [false ; true] in ok () let expect_eq_n_int a b c = diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index facd0c717..e86254f6b 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -551,15 +551,14 @@ and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.express let free_variables = Ast_typed.Free_variables.lambda [] l in let sub_env = Mini_c.Environment.select free_variables env in ok sub_env in - let%bind (f_expr , input_tv , output_tv) = + let%bind (f_expr' , input_tv , output_tv) = let%bind raw_input = translate_type input_type in let%bind output = translate_type output_type in let%bind result = translate_annotated_expression result in - let f_literal = D_function { binder ; result } in - let expr' = E_literal f_literal in + let expr' = E_closure { binder ; result } in ok (expr' , raw_input , output) in let tv = Mini_c.t_deep_closure c_env input_tv output_tv in - ok @@ Expression.make_tpl (f_expr , tv) + ok @@ Expression.make_tpl (f_expr' , tv) and translate_lambda env l = let { binder ; input_type ; output_type ; result } : AST.lambda = l in diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index d183f38d4..52637021e 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -543,7 +543,7 @@ let rec bind_list = function hd >>? fun hd -> bind_list tl >>? fun tl -> ok @@ hd :: tl - ) + ) let bind_ne_list = fun (hd , tl) -> hd >>? fun hd -> @@ -568,6 +568,13 @@ let bind_fold_smap f init (smap : _ X_map.String.t) = let bind_map_smap f smap = bind_smap (X_map.String.map f smap) let bind_map_list f lst = bind_list (List.map f lst) +let rec bind_map_list_seq f lst = match lst with + | [] -> ok [] + | hd :: tl -> ( + let%bind hd' = f hd in + let%bind tl' = bind_map_list_seq f tl in + ok (hd' :: tl') + ) let bind_map_ne_list : _ -> 'a X_list.Ne.t -> 'b X_list.Ne.t result = fun f lst -> bind_ne_list (X_list.Ne.map f lst) let bind_iter_list : (_ -> unit result) -> _ list -> unit result = fun f lst -> bind_map_list f lst >>? fun _ -> ok () From 31a2a968109145190862f018bab5ae374ff6ba0b Mon Sep 17 00:00:00 2001 From: galfour Date: Wed, 21 Aug 2019 11:41:57 +0200 Subject: [PATCH 6/8] fixed last bug --- src/compiler/compiler_program.ml | 2 +- src/contracts/set_arithmetic-1.ligo | 9 +++++++++ src/contracts/set_arithmetic.ligo | 10 ---------- src/test/integration_tests.ml | 9 +++++---- 4 files changed, 15 insertions(+), 15 deletions(-) create mode 100644 src/contracts/set_arithmetic-1.ligo diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index 8a2ae0d2f..67b9ac634 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -300,7 +300,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result | "ITER" -> ( let%bind code = ok (seq [ expr' ; - i_iter (seq [body' ; dip i_drop]) ; + i_iter (seq [body' ; i_drop ; i_drop]) ; i_push_unit ; ]) in return code diff --git a/src/contracts/set_arithmetic-1.ligo b/src/contracts/set_arithmetic-1.ligo new file mode 100644 index 000000000..2397f72b5 --- /dev/null +++ b/src/contracts/set_arithmetic-1.ligo @@ -0,0 +1,9 @@ +function iter_op (const s : set(int)) : int is + var r : int := 0 ; + function aggregate (const i : int) : unit is + begin + r := r + i ; + end with unit + begin + set_iter(s , aggregate) ; + end with r diff --git a/src/contracts/set_arithmetic.ligo b/src/contracts/set_arithmetic.ligo index 814120c0c..f85e42394 100644 --- a/src/contracts/set_arithmetic.ligo +++ b/src/contracts/set_arithmetic.ligo @@ -1,13 +1,3 @@ -function iter_op (const s : set(int)) : int is - var r : int := 0 ; - function aggregate (const i : int) : unit is - begin - r := r + i ; - end with unit - begin - set_iter(s , aggregate) ; - end with r - const s_e : set(string) = (set_empty : set(string)) const s_fb : set(string) = set [ diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 275479e63..5a4cf635e 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -167,6 +167,11 @@ let string_arithmetic () : unit result = let set_arithmetic () : unit result = let%bind program = type_file "./contracts/set_arithmetic.ligo" in + let%bind program_1 = type_file "./contracts/set_arithmetic-1.ligo" in + let%bind () = + expect_eq program_1 "iter_op" + (e_set [e_int 2 ; e_int 4 ; e_int 7]) + (e_int 13) in let%bind () = expect_eq program "add_op" (e_set [e_string "foo" ; e_string "bar"]) @@ -191,10 +196,6 @@ let set_arithmetic () : unit result = expect_eq program "mem_op" (e_set [e_string "foo" ; e_string "bar"]) (e_bool false) in - let%bind () = - expect_eq program "iter_op" - (e_set [e_int 2 ; e_int 4 ; e_int 7]) - (e_int 13) in ok () let unit_expression () : unit result = From 7afa8a9cdb2760f552b398adf40441825510e40d Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Wed, 21 Aug 2019 07:34:34 -0700 Subject: [PATCH 7/8] Test closures more --- src/contracts/closure-3.ligo | 6 ++++++ src/test/integration_tests.ml | 5 +++++ 2 files changed, 11 insertions(+) create mode 100644 src/contracts/closure-3.ligo diff --git a/src/contracts/closure-3.ligo b/src/contracts/closure-3.ligo new file mode 100644 index 000000000..71fb67269 --- /dev/null +++ b/src/contracts/closure-3.ligo @@ -0,0 +1,6 @@ +function foobar(const i : int) : int is + const j : int = 3 ; + const k : int = 4 ; + function toto(const l : int) : int is + block { skip } with i + j + k + l; + block { skip } with toto(42) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 5a4cf635e..df6f11f5d 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -69,6 +69,11 @@ let closure () : unit result = let%bind program = type_file "./contracts/closure.ligo" in let%bind program_1 = type_file "./contracts/closure-1.ligo" in let%bind program_2 = type_file "./contracts/closure-2.ligo" in + let%bind program_3 = type_file "./contracts/closure-3.ligo" in + let%bind _ = + let make_expect = fun n -> (49 + n) in + expect_eq_n_int program_3 "foobar" make_expect + in let%bind _ = let make_expect = fun n -> (45 + n) in expect_eq_n_int program_2 "foobar" make_expect From faf3bbc06106de98189f1c1673bd57e78351dc7e Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Wed, 21 Aug 2019 07:34:39 -0700 Subject: [PATCH 8/8] Fix unpack_closure --- src/compiler/compiler_environment.ml | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/src/compiler/compiler_environment.ml b/src/compiler/compiler_environment.ml index f0fed96c4..7ab0ea76b 100644 --- a/src/compiler/compiler_environment.ml +++ b/src/compiler/compiler_environment.ml @@ -73,15 +73,5 @@ let pack_closure : environment -> selector -> michelson result = fun e lst -> ok code let unpack_closure : environment -> michelson result = fun e -> - let lst = - match e with - | [] -> [] - | _ :: tl -> [ - i_unpair ; - dip @@ seq @@ List.map (Function.constant i_unpair) tl ; - ] - in - - let code = seq lst in - - ok code + let aux = fun code _ -> seq [ i_unpair ; dip code ] in + ok (List.fold_right' aux (seq []) e)