From 015e1971839c7c77e3102413bd781c91308c881c Mon Sep 17 00:00:00 2001 From: galfour Date: Thu, 19 Sep 2019 01:34:37 +0200 Subject: [PATCH] back on track --- src/bin/cli.ml | 2 +- src/main/compile/of_mini_c.ml | 30 +++- src/main/compile/of_simplified.ml | 14 +- src/main/compile/of_source.ml | 7 +- src/main/compile/of_typed.ml | 138 +++--------------- src/main/run/of_michelson.ml | 14 +- src/main/run/of_mini_c.ml | 52 +++---- src/main/run/of_simplified.ml | 9 +- src/main/run/of_source.ml | 2 +- src/main/run/of_typed.ml | 10 +- src/passes/6-transpiler/transpiler.ml | 14 +- src/passes/8-compiler/compiler_program.ml | 4 +- src/stages/ast_typed/combinators.ml | 5 + src/stages/ast_typed/misc.ml | 27 ++++ src/stages/ast_typed/types.ml | 20 --- src/stages/mini_c/PP.ml | 4 +- src/stages/mini_c/combinators.ml | 36 +++-- src/stages/mini_c/mini_c.ml | 1 + src/stages/mini_c/misc.ml | 93 ++++++++++++ src/stages/mini_c/types.ml | 3 +- src/test/compiler_tests.ml | 12 +- vendors/ligo-utils/tezos-utils/x_michelson.ml | 4 +- 22 files changed, 276 insertions(+), 225 deletions(-) create mode 100644 src/stages/mini_c/misc.ml diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 29fa6247c..8d051dd83 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -51,7 +51,7 @@ let compile_file = let%bind contract = trace (simple_info "compiling contract to michelson") @@ Ligo.Compile.Of_source.compile_file_contract_entry source entry_point (Syntax_name syntax) in - Format.printf "%a\n" Tezos_utils.Michelson.pp contract ; + Format.printf "%a\n" Tezos_utils.Michelson.pp contract.body ; ok () in let term = diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index ffd31b259..b8d685975 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -5,11 +5,35 @@ open Tezos_utils let compile_value : value -> type_value -> Michelson.t result = Compiler.Program.translate_value -let compile_expression : expression -> Michelson.t result = fun e -> +let compile_expression : expression -> _ result = fun e -> Compiler.Program.translate_expression e Compiler.Environment.empty -let compile_function : anon_function -> type_value -> type_value -> Compiler.Program.compiled_program result = fun f in_ty out_ty -> - Compiler.Program.translate_entry f (in_ty , out_ty) +let compile_expression_as_function : expression -> _ result = fun e -> + let (input , output) = t_unit , e.type_value in + let%bind body = get_function e in + let%bind body = compile_value body (t_function input output) in + let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in + let open! Compiler.Program in + ok { input ; output ; body } + +let compile_function = fun e -> + let%bind (input , output) = get_t_function e.type_value in + let%bind body = get_function e in + let%bind body = compile_value body (t_function input output) in + let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in + let open! Compiler.Program in + ok { input ; output ; body } + +(* let compile_function : anon_function -> (type_value * type_value) -> Compiler.Program.compiled_program result = fun f io -> + * Compiler.Program.translate_entry f io *) + +let compile_expression_as_function_entry = fun program name -> + let%bind aggregated = aggregate_entry program name true in + compile_function aggregated + +let compile_function_entry = fun program name -> + let%bind aggregated = aggregate_entry program name false in + compile_function aggregated let uncompile_value : Proto_alpha_utils.Memory_proto_alpha.X.ex_typed_value -> value result = fun x -> Compiler.Uncompiler.translate_value x diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index f6c4500ac..1e2a11ca9 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -2,13 +2,13 @@ open Ast_simplified open Trace open Tezos_utils -let compile_function_entry (program : program) entry_point : Compiler.Program.compiled_program result = - let%bind typed_program = Typer.type_program program in - Of_typed.compile_function_entry typed_program entry_point +let compile_function_entry (program : program) entry_point : _ result = + let%bind prog_typed = Typer.type_program program in + Of_typed.compile_function_entry prog_typed entry_point -let compile_expression_entry (program : program) entry_point : Compiler.Program.compiled_program result = +let compile_expression_as_function_entry (program : program) entry_point : _ result = let%bind typed_program = Typer.type_program program in - Of_typed.compile_expression_entry typed_program entry_point + Of_typed.compile_expression_as_function_entry typed_program entry_point let compile_expression ?(env = Ast_typed.Environment.full_empty) ae : Michelson.t result = let%bind typed = Typer.type_expression env ae in @@ -16,7 +16,7 @@ let compile_expression ?(env = Ast_typed.Environment.full_empty) ae : Michelson. let uncompile_typed_program_entry_expression_result program entry ex_ty_value = let%bind output_type = - let%bind (entry_expression , _ ) = Of_typed.get_entry program entry in + let%bind entry_expression = Ast_typed.get_entry program entry in ok entry_expression.type_annotation in let%bind typed = Of_typed.uncompile_value ex_ty_value output_type in @@ -24,7 +24,7 @@ let uncompile_typed_program_entry_expression_result program entry ex_ty_value = let uncompile_typed_program_entry_function_result program entry ex_ty_value = let%bind output_type = - let%bind (entry_expression , _ ) = Of_typed.get_entry program entry in + let%bind entry_expression = Ast_typed.get_entry program entry in let%bind (_ , output_type) = Ast_typed.get_t_function entry_expression.type_annotation in ok output_type in diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index 15134ee93..fd0b93dc7 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -7,16 +7,15 @@ let parse_file_program source_filename syntax = let%bind simplified = parsify syntax source_filename in ok simplified -let compile_file_entry : string -> string -> s_syntax -> Compiler.Program.compiled_program result = +let compile_file_entry : string -> string -> s_syntax -> _ result = fun source_filename entry_point syntax -> let%bind simplified = parse_file_program source_filename syntax in Of_simplified.compile_function_entry simplified entry_point -let compile_file_contract_entry : string -> string -> s_syntax -> Michelson.t result = +let compile_file_contract_entry : string -> string -> s_syntax -> _ result = fun source_filename entry_point syntax -> let%bind simplified = parse_file_program source_filename syntax in - let%bind f = Of_simplified.compile_function_entry simplified entry_point in - ok f.body + Of_simplified.compile_function_entry simplified entry_point let compile_file_contract_parameter : string -> string -> string -> s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index 962543444..a8855e904 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -2,37 +2,21 @@ open Trace open Ast_typed open Tezos_utils -module Errors = struct - - let missing_entry_point name = - let title () = "missing entry point" in - let content () = "no entry point with the given name" in - let data = [ - ("name" , fun () -> name) ; - ] in - error ~data title content - - let not_functional_main location = - let title () = "not functional main" in - let content () = "main should be a function" in - let data = [ - ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; - ] in - error ~data title content - -end - -(* - This converts `expr` in `fun () -> expr`. -*) -let functionalize (body : annotated_expression) : annotated_expression = - let expression = E_lambda { binder = "_" ; body } in - let type_annotation = t_function (t_unit ()) body.type_annotation () in - { body with expression ; type_annotation } let compile_expression : annotated_expression -> Michelson.t result = fun e -> let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in - Of_mini_c.compile_expression mini_c_expression + let%bind expr = Of_mini_c.compile_expression mini_c_expression in + ok expr + +let compile_expression_as_function : annotated_expression -> _ result = fun e -> + let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in + let%bind expr = Of_mini_c.compile_expression_as_function mini_c_expression in + ok expr + +let compile_function : annotated_expression -> _ result = fun e -> + let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in + let%bind expr = Of_mini_c.compile_function mini_c_expression in + ok expr (* val compile_value : annotated_expression -> Michelson.t result @@ -40,102 +24,22 @@ let compile_expression : annotated_expression -> Michelson.t result = fun e -> `transpile_expression_as_value : annotated_expression -> Mini_c.value result` *) -let compile_function expr = - let%bind l = get_lambda expr.expression in - let%bind io = get_t_function expr.type_annotation in - let%bind mini_c = Transpiler.transpile_lambda Mini_c.Environment.empty l io in - let%bind (f , (in_ty , out_ty)) = - match (mini_c.content , mini_c.type_value) with - | E_literal (D_function f) , T_function ty -> ok (f , ty) - | _ -> fail @@ Errors.not_functional_main expr.location - in - Of_mini_c.compile_function f in_ty out_ty - - -let get_entry (lst : program) (name : string) : (annotated_expression * int) result = - let%bind entry_expression = - trace_option (Errors.missing_entry_point name) @@ - let aux x = - let (Declaration_constant (an , _)) = Location.unwrap x in - if (an.name = name) - then Some an.annotated_expression - else None - in - List.find_map aux lst - in - let entry_index = - let aux x = - let (Declaration_constant (an , _)) = Location.unwrap x in - an.name = name - in - List.find_index aux lst - in - ok (entry_expression , entry_index) - -(* - Assume the following code: - ``` - const x = 42 - const y = 120 - const z = 423 - const f = () -> x + y - ``` - It is transformed in: - ``` - const f = () -> - let x = 42 in - let y = 120 in - let z = 423 in - x + y - ``` - - The entry-point can be an expression, which is then functionalized if - `to_functionalize` is set to true. -*) -let get_aggregated_entry (lst : program) (name : string) (to_functionalize : bool) : annotated_expression result = - let%bind (entry_expression , entry_index) = get_entry lst name in - let pre_declarations = - let sub_program = List.until entry_index lst in - let aux x = Location.unwrap x in - List.map aux sub_program - in - let wrapper = - let aux prec cur = - let (Declaration_constant (an , (pre_env , _))) = cur in - e_a_let_in an.name an.annotated_expression prec pre_env - in - fun expr -> List.fold_right' aux expr pre_declarations - in - match (entry_expression.expression , to_functionalize) with - | (E_lambda l , false) -> ( - let l' = { l with body = wrapper l.body } in - let e' = { entry_expression with expression = E_lambda l' } in - ok e' - ) - | (_ , true) -> ( - ok @@ functionalize @@ wrapper entry_expression - ) - | _ -> fail @@ Errors.not_functional_main entry_expression.location - let compile_function_entry : program -> string -> _ = fun p entry -> - let%bind expr = get_aggregated_entry p entry false in - compile_function expr + let%bind prog_mini_c = Transpiler.transpile_program p in + Of_mini_c.compile_function_entry prog_mini_c entry -let compile_expression_entry : program -> string -> _ = fun p entry -> - let%bind expr = get_aggregated_entry p entry true in - compile_function expr - -let compile_expression_as_function : annotated_expression -> Compiler.Program.compiled_program result = fun e -> - let expr = functionalize e in - compile_function expr +let compile_expression_as_function_entry : program -> string -> _ = fun p entry -> + let%bind prog_mini_c = Transpiler.transpile_program p in + Of_mini_c.compile_expression_as_function_entry prog_mini_c entry let uncompile_value : _ -> _ -> annotated_expression result = fun x ty -> let%bind mini_c = Of_mini_c.uncompile_value x in - Transpiler.untranspile mini_c ty + let%bind typed = Transpiler.untranspile mini_c ty in + ok typed let uncompile_entry_function_result = fun program entry ex_ty_value -> let%bind output_type = - let%bind (entry_expression , _ ) = get_entry program entry in + let%bind entry_expression = get_entry program entry in let%bind (_ , output_type) = get_t_function entry_expression.type_annotation in ok output_type in @@ -143,7 +47,7 @@ let uncompile_entry_function_result = fun program entry ex_ty_value -> let uncompile_entry_expression_result = fun program entry ex_ty_value -> let%bind output_type = - let%bind (entry_expression , _ ) = get_entry program entry in + let%bind entry_expression = get_entry program entry in ok entry_expression.type_annotation in uncompile_value ex_ty_value output_type diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index f34cb2333..4eb9d9c9a 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -13,7 +13,17 @@ let run ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_t let%bind input = Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ Memory_proto_alpha.parse_michelson_data input_michelson input_ty in - let body = Michelson.strip_annots body in + let body = Michelson.(strip_nops @@ strip_annots body) in + + let%bind input_ty_mich = + Trace.trace_tzresult_lwt (simple_error "error unparsing input ty") @@ + Memory_proto_alpha.unparse_michelson_ty input_ty in + let%bind output_ty_mich = + Trace.trace_tzresult_lwt (simple_error "error unparsing output ty") @@ + Memory_proto_alpha.unparse_michelson_ty output_ty in + Format.printf "code: %a\n" Michelson.pp program.body ; + Format.printf "input: %a\n" Michelson.pp input_ty_mich ; + Format.printf "output: %a\n" Michelson.pp output_ty_mich ; let%bind descr = Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ Memory_proto_alpha.parse_michelson body @@ -23,3 +33,5 @@ let run ?options (program:compiled_program) (input_michelson:Michelson.t) : ex_t 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 evaluate ?options program = run ?options program Michelson.d_unit diff --git a/src/main/run/of_mini_c.ml b/src/main/run/of_mini_c.ml index 8e22c8a54..0fecd02bb 100644 --- a/src/main/run/of_mini_c.ml +++ b/src/main/run/of_mini_c.ml @@ -2,7 +2,7 @@ open Proto_alpha_utils open Memory_proto_alpha.X open Trace open Mini_c -open Compiler.Program +open! Compiler.Program module Errors = struct @@ -19,27 +19,29 @@ type options = { michelson_options : Of_michelson.options ; } -let run_entry ?(debug_michelson = false) ?options (entry : anon_function) ty (input:value) : value result = - let%bind compiled = - trace Errors.entry_error @@ - 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_ (fst ty) ; - Format.printf "Compiled Input: %a\n" Michelson.pp input_michelson ; - ) ; - let%bind ex_ty_value = Of_michelson.run ?options compiled input_michelson in - if debug_michelson then ( - let (Ex_typed_value (ty , v)) = ex_ty_value in - ignore @@ - let%bind michelson_value = - trace_tzresult_lwt (simple_error "debugging run_mini_c") @@ - Proto_alpha_utils.Memory_proto_alpha.unparse_michelson_data ty v in - Format.printf "Compiled Output: %a\n" Michelson.pp michelson_value ; - ok () - ) ; - let%bind (result : value) = Compile.Of_mini_c.uncompile_value ex_ty_value in - ok result +let evaluate ?options expression = + let%bind code = Compile.Of_mini_c.compile_expression_as_function expression in + let%bind ex_ty_value = Of_michelson.evaluate ?options code in + Compile.Of_mini_c.uncompile_value ex_ty_value + +let evaluate_entry ?options program entry = + let%bind code = Compile.Of_mini_c.compile_expression_as_function_entry program entry in + let%bind ex_ty_value = Of_michelson.evaluate ?options code in + Compile.Of_mini_c.uncompile_value ex_ty_value + +let run_function ?options expression input ty = + let%bind code = Compile.Of_mini_c.compile_function expression in + let%bind input = Compile.Of_mini_c.compile_value input ty in + let%bind ex_ty_value = Of_michelson.run ?options code input in + Compile.Of_mini_c.uncompile_value ex_ty_value + +let run_function_entry ?options program entry input = + let%bind code = Compile.Of_mini_c.compile_function_entry program entry in + let%bind input_michelson = + let%bind code = Compile.Of_mini_c.compile_expression_as_function input in + let%bind (Ex_typed_value (ty , value)) = Of_michelson.evaluate ?options code in + Trace.trace_tzresult_lwt (simple_error "error unparsing input") @@ + Memory_proto_alpha.unparse_michelson_data ty value + in + let%bind ex_ty_value = Of_michelson.run ?options code input_michelson in + Compile.Of_mini_c.uncompile_value ex_ty_value diff --git a/src/main/run/of_simplified.ml b/src/main/run/of_simplified.ml index 8937fd83f..4332ca9e5 100644 --- a/src/main/run/of_simplified.ml +++ b/src/main/run/of_simplified.ml @@ -18,15 +18,10 @@ let run_typed_program let%bind ex_ty_value = Of_michelson.run ?options code input in Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value - let evaluate_typed_program_entry ?options (program : Ast_typed.program) (entry : string) : Ast_simplified.expression result = - let%bind code = Compile.Of_typed.compile_expression_entry program entry in - let%bind input = - let fake_input = Ast_typed.(e_a_unit Environment.full_empty) in - - in - let%bind ex_ty_value = Of_michelson.run ?options code input in + let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry in + let%bind ex_ty_value = Of_michelson.evaluate ?options code in Compile.Of_simplified.uncompile_typed_program_entry_expression_result program entry ex_ty_value diff --git a/src/main/run/of_source.ml b/src/main/run/of_source.ml index 55a455f9e..5bc8b421c 100644 --- a/src/main/run/of_source.ml +++ b/src/main/run/of_source.ml @@ -76,7 +76,7 @@ let run_function ?amount source_filename entry_point input syntax = let evaluate ?amount source_filename entry_point syntax = let%bind program = Compile.Of_source.type_file syntax source_filename in - let%bind code = Compile.Of_typed.compile_expression_entry program entry_point in + let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry_point in let%bind input = let fake_input = Ast_simplified.e_unit () in Compile.Of_simplified.compile_expression fake_input diff --git a/src/main/run/of_typed.ml b/src/main/run/of_typed.ml index a7bbcb88c..a645250cc 100644 --- a/src/main/run/of_typed.ml +++ b/src/main/run/of_typed.ml @@ -21,14 +21,10 @@ let run_entry let evaluate ?options (e : annotated_expression) : annotated_expression result = let%bind code = Compile.Of_typed.compile_expression_as_function e in - let fake_input = e_a_unit Environment.full_empty in - let%bind input = Compile.Of_typed.compile_expression fake_input in - let%bind ex_ty_value = Of_michelson.run ?options code input in + let%bind ex_ty_value = Of_michelson.evaluate ?options code in Compile.Of_typed.uncompile_value ex_ty_value e.type_annotation let evaluate_entry ?options program entry = - let%bind code = Compile.Of_typed.compile_expression_entry program entry in - let fake_input = e_a_unit Environment.full_empty in - let%bind input = Compile.Of_typed.compile_expression fake_input in - let%bind ex_ty_value = Of_michelson.run ?options code input in + let%bind code = Compile.Of_typed.compile_expression_as_function_entry program entry in + let%bind ex_ty_value = Of_michelson.evaluate ?options code in Compile.Of_typed.uncompile_entry_expression_result program entry ex_ty_value diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index ef8d562c4..df99e3b4b 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -313,7 +313,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re let%bind f' = match f.expression with | E_lambda l -> ( let%bind body' = transpile_annotated_expression l.body in - let%bind (input , _) = get_t_function f.type_annotation in + let%bind (input , _) = AST.get_t_function f.type_annotation in let%bind input' = transpile_type input in ok ((l.binder , input') , body') ) @@ -326,7 +326,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re match f.expression with | E_lambda l -> ( let%bind body' = transpile_annotated_expression l.body in - let%bind (input , _) = get_t_function f.type_annotation in + let%bind (input , _) = AST.get_t_function f.type_annotation in let%bind input' = transpile_type input in ok ((l.binder , input') , body') ) @@ -357,7 +357,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re let%bind env = trace_strong (corner_case ~loc:__LOC__ "environment") @@ transpile_environment ae.environment in - let%bind io = get_t_function ae.type_annotation in + let%bind io = AST.get_t_function ae.type_annotation in transpile_lambda env l io | E_list lst -> ( let%bind t = @@ -513,8 +513,8 @@ and transpile_lambda_deep : Mini_c.Environment.t -> AST.lambda -> _ -> Mini_c.ex let%bind (f_expr' , input_tv , output_tv) = let%bind raw_input = transpile_type input_type in let%bind output = transpile_type output_type in - let%bind result = transpile_annotated_expression body in - let expr' = E_closure { binder ; result } in + let%bind body = transpile_annotated_expression body in + let expr' = E_closure { binder ; body } 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) @@ -529,7 +529,7 @@ and transpile_lambda env l (input_type , output_type) = let%bind input = transpile_type input_type in let%bind output = transpile_type output_type in let tv = Combinators.t_function input output in - let content = D_function { binder ; result = result'} in + let content = D_function { binder ; body = result'} in ok @@ Combinators.Expression.make_tpl (E_literal content , tv) ) | _ -> ( @@ -545,7 +545,7 @@ let transpile_declaration env (d:AST.declaration) : toplevel_statement result = let env' = Environment.add (name, tv) env in ok @@ ((name, expression), environment_wrap env env') -let transpile_program (lst:AST.program) : program result = +let transpile_program (lst : AST.program) : program result = let aux (prev:(toplevel_statement list * Environment.t) result) cur = let%bind (tl, env) = prev in let%bind ((_, env') as cur') = transpile_declaration env cur in diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index a06fc2a6e..1e7ff7d51 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -361,10 +361,10 @@ and translate_expression (expr:expression) (env:environment) : michelson result ] ) -and translate_function_body ({result ; binder} : anon_function) lst input : michelson result = +and translate_function_body ({body ; 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 expr_code = translate_expression body env in let%bind unpack_closure_code = Compiler_environment.unpack_closure pre_env in let code = seq [ i_comment "unpack closure env" ; diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index 6b2358c28..f0ae6f648 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -60,6 +60,11 @@ let get_lambda e : _ result = match e with | E_lambda l -> ok l | _ -> simple_fail "not a lambda" +let get_lambda_with_type e = + match (e.expression , e.type_annotation.type_value') with + | E_lambda l , T_function io -> ok (l , io) + | _ -> simple_fail "not a lambda with functional type" + let get_t_bool (t:type_value) : unit result = match t.type_value' with | T_constant ("bool", []) -> ok () | _ -> simple_fail "not a bool" diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index a71ff3fae..c13200c9a 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -125,6 +125,23 @@ module Errors = struct ("missing_key" , fun () -> Format.asprintf "%s" k) ] in error ~data title message () + + let missing_entry_point name = + let title () = "missing entry point" in + let content () = "no entry point with the given name" in + let data = [ + ("name" , fun () -> name) ; + ] in + error ~data title content + + let not_functional_main location = + let title () = "not functional main" in + let content () = "main should be a function" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; + ] in + error ~data title content + end module Free_variables = struct @@ -473,3 +490,13 @@ let merge_annotation (a:type_value option) (b:type_value option) err : type_valu match a.simplified, b.simplified with | _, None -> ok a | _, Some _ -> ok b + +let get_entry (lst : program) (name : string) : annotated_expression result = + trace_option (Errors.missing_entry_point name) @@ + let aux x = + let (Declaration_constant (an , _)) = Location.unwrap x in + if (an.name = name) + then Some an.annotated_expression + else None + in + List.find_map aux lst diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index 6fe7f921e..f7ef1595f 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -148,23 +148,3 @@ and 'a matching = | Match_variant of (((constructor_name * name) * 'a) list * type_value) and matching_expr = ae matching - -open Trace - -let get_entry (p:program) (entry : string) : annotated_expression result = - let aux (d:declaration) = - match d with - | Declaration_constant ({name ; annotated_expression} , _) when entry = name -> Some annotated_expression - | Declaration_constant _ -> None - in - let%bind result = - trace_option (simple_error "no entry point with given name") @@ - List.find_map aux (List.map Location.unwrap p) in - ok result - -let get_functional_entry (p:program) (entry : string) : (lambda * type_value) result = - let%bind entry = get_entry p entry in - match entry.expression with - | E_lambda l -> ok (l , entry.type_annotation) - | _ -> simple_fail "given entry point is not functional" - diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index 13fb005fc..f2527d27b 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -100,10 +100,10 @@ and expression_with_type : _ -> expression -> _ = fun ppf e -> expression' e.content type_ e.type_value -and function_ ppf ({binder ; result}:anon_function) = +and function_ ppf ({binder ; body}:anon_function) = fprintf ppf "fun %s -> (%a)" binder - expression result + expression body and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e diff --git a/src/stages/mini_c/combinators.ml b/src/stages/mini_c/combinators.ml index 9e8467207..e9090a9d8 100644 --- a/src/stages/mini_c/combinators.ml +++ b/src/stages/mini_c/combinators.ml @@ -7,18 +7,15 @@ module Expression = struct let get_content : t -> t' = fun e -> e.content let get_type : t -> type_value = fun e -> e.type_value - let is_toplevel : t -> bool = fun e -> e.is_toplevel - let make = fun ?(itl = false) e' t -> { + let make = fun e' t -> { content = e' ; type_value = t ; - is_toplevel = itl ; } - let make_tpl = fun ?(itl = false) (e' , t) -> { + let make_tpl = fun (e' , t) -> { content = e' ; type_value = t ; - is_toplevel = itl ; } let pair : t -> t -> t' = fun a b -> E_constant ("PAIR" , [ a ; b ]) @@ -70,6 +67,20 @@ let get_set (v:value) = match v with | D_set lst -> ok lst | _ -> simple_fail "not a set" +let get_function_with_ty (e : expression) = + match (e.content , e.type_value) with + | E_literal (D_function f) , T_function ty -> ok (f , ty) + | _ -> simple_fail "not a function with functional type" + +let get_function (e : expression) = + match (e.content) with + | E_literal (D_function f) -> ok (D_function f) + | _ -> simple_fail "not a function" + +let get_t_function tv = match tv with + | T_function ty -> ok ty + | _ -> simple_fail "not a function" + let get_t_option (v:type_value) = match v with | T_option t -> ok t | _ -> simple_fail "not an option" @@ -146,10 +157,10 @@ 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 result : anon_function = +let quote binder body : anon_function = { binder ; - result ; + body ; } @@ -157,7 +168,7 @@ let e_int expr : expression = Expression.make_tpl (expr, t_int) let e_unit : expression = Expression.make_tpl (E_literal D_unit, t_unit) let e_skip : expression = Expression.make_tpl (E_skip, t_unit) let e_var_int name : expression = e_int (E_variable name) -let e_let_int v tv expr body : expression = Expression.(make_tpl ( +let e_let_in v tv expr body : expression = Expression.(make_tpl ( E_let_in ((v , tv) , expr , body) , get_type body )) @@ -166,11 +177,12 @@ let ez_e_sequence a b : expression = Expression.(make_tpl (E_sequence (make_tpl let d_unit : value = D_unit -let basic_quote expr : anon_function result = - ok @@ quote "input" expr +let basic_quote expr in_ty out_ty : expression result = + let expr' = E_literal (D_function (quote "input" expr)) in + ok @@ Expression.make_tpl (expr' , t_function in_ty out_ty) -let basic_int_quote expr : anon_function result = - basic_quote expr +let basic_int_quote expr : expression result = + basic_quote expr t_int t_int let environment_wrap pre_environment post_environment = { pre_environment ; post_environment } diff --git a/src/stages/mini_c/mini_c.ml b/src/stages/mini_c/mini_c.ml index 5f4e9f5a2..891f746d7 100644 --- a/src/stages/mini_c/mini_c.ml +++ b/src/stages/mini_c/mini_c.ml @@ -8,3 +8,4 @@ module Combinators = struct end include Combinators module Environment = Environment +include Misc diff --git a/src/stages/mini_c/misc.ml b/src/stages/mini_c/misc.ml new file mode 100644 index 000000000..7fa6a9779 --- /dev/null +++ b/src/stages/mini_c/misc.ml @@ -0,0 +1,93 @@ +open Types +open Combinators +open Trace + +module Errors = struct + + let missing_entry_point name = + let title () = "missing entry point" in + let content () = "no entry point with the given name" in + let data = [ + ("name" , fun () -> name) ; + ] in + error ~data title content + + let not_functional_main name = + let title () = "not functional main" in + let content () = "main should be a function" in + let data = [ + ("name" , fun () -> Format.asprintf "%s" name) ; + ] in + error ~data title content + +end + +(* + Converts `expr` in `fun () -> expr`. +*) +let functionalize (body : expression) : expression = + let content = E_literal (D_function { binder = "_" ; body }) in + let type_value = t_function t_unit body.type_value in + { content ; type_value } + +let get_entry (lst : program) (name : string) : (expression * int) result = + let%bind entry_expression = + trace_option (Errors.missing_entry_point name) @@ + let aux x = + let (((decl_name , decl_expr) , _)) = x in + if (decl_name = name) + then Some decl_expr + else None + in + List.find_map aux lst + in + let entry_index = + let aux x = + let (((decl_name , _) , _)) = x in + decl_name = name + in + List.find_index aux lst + in + ok (entry_expression , entry_index) + + +(* + Assume the following code: + ``` + const x = 42 + const y = 120 + const z = 423 + const f = () -> x + y + ``` + It is transformed in: + ``` + const f = () -> + let x = 42 in + let y = 120 in + let z = 423 in + x + y + ``` + + The entry-point can be an expression, which is then functionalized if + `to_functionalize` is set to true. +*) +let aggregate_entry (lst : program) (name : string) (to_functionalize : bool) : expression result = + let%bind (entry_expression , entry_index) = get_entry lst name in + let pre_declarations = List.until entry_index lst in + let wrapper = + let aux prec cur = + let (((name , expr) , _)) = cur in + e_let_in name expr.type_value expr prec + in + fun expr -> List.fold_right' aux expr pre_declarations + in + match (entry_expression.content , to_functionalize) with + | (E_literal (D_function l) , false) -> ( + let l' = { l with body = wrapper l.body } in + let e' = { entry_expression with content = E_literal (D_function l') } in + ok e' + ) + | (_ , true) -> ( + ok @@ functionalize @@ wrapper entry_expression + ) + | _ -> fail @@ Errors.not_functional_main name diff --git a/src/stages/mini_c/types.ml b/src/stages/mini_c/types.ml index fd0ddd021..d3b6bcf36 100644 --- a/src/stages/mini_c/types.ml +++ b/src/stages/mini_c/types.ml @@ -78,7 +78,6 @@ and expression' = and expression = { content : expression' ; type_value : type_value ; - is_toplevel : bool ; } and assignment = var_name * expression @@ -87,7 +86,7 @@ and toplevel_statement = assignment * environment_wrap and anon_function = { binder : string ; - result : expression ; + body : expression ; } and program = toplevel_statement list diff --git a/src/test/compiler_tests.ml b/src/test/compiler_tests.ml index b77c595f5..dd18c53f2 100644 --- a/src/test/compiler_tests.ml +++ b/src/test/compiler_tests.ml @@ -3,9 +3,9 @@ open Mini_c open Combinators open Test_helpers -let run_entry_int (e:anon_function) (n:int) : int result = +let run_entry_int e (n:int) : int result = let param : value = D_int n in - let%bind result = Run.Of_mini_c.run_entry e (t_int , t_int) param in + let%bind result = Run.Of_mini_c.run_function e param t_int in match result with | D_int n -> ok n | _ -> simple_fail "result is not an int" @@ -18,10 +18,10 @@ let identity () : unit result = let multiple_vars () : unit result = let expr = - e_let_int "a" t_int (e_var_int "input") @@ - e_let_int "b" t_int (e_var_int "input") @@ - e_let_int "c" t_int (e_var_int "a") @@ - e_let_int "output" t_int (e_var_int "c") @@ + e_let_in "a" t_int (e_var_int "input") @@ + e_let_in "b" t_int (e_var_int "input") @@ + e_let_in "c" t_int (e_var_int "a") @@ + e_let_in "output" t_int (e_var_int "c") @@ e_var_int "output" in let%bind f = basic_int_quote expr in let%bind result = run_entry_int f 42 in diff --git a/vendors/ligo-utils/tezos-utils/x_michelson.ml b/vendors/ligo-utils/tezos-utils/x_michelson.ml index 6bb8e6203..88684549e 100644 --- a/vendors/ligo-utils/tezos-utils/x_michelson.ml +++ b/vendors/ligo-utils/tezos-utils/x_michelson.ml @@ -15,7 +15,6 @@ let annotate annot = function let seq s : michelson = Seq (0, s) -let i_comment s : michelson = seq [ prim ~annot:["\"" ^ s ^ "\""] I_UNIT ; prim I_DROP ] let contract parameter storage code = seq [ @@ -45,6 +44,9 @@ let i_piar = seq [ i_swap ; i_pair ] let i_push ty code = prim ~children:[ty;code] I_PUSH let i_push_unit = i_push t_unit d_unit let i_push_string str = i_push t_string (string str) + +let i_comment s : michelson = seq [ i_push_string s ; prim I_DROP ] + let i_none ty = prim ~children:[ty] I_NONE let i_nil ty = prim ~children:[ty] I_NIL let i_empty_set ty = prim ~children:[ty] I_EMPTY_SET