From 5566095e495cd8ff07a1ec406c7e64da6cd2bdc5 Mon Sep 17 00:00:00 2001 From: galfour Date: Wed, 11 Sep 2019 13:56:39 +0200 Subject: [PATCH] more stuff --- src/main/compile/of_simplified.ml | 13 +- src/main/compile/of_source.ml | 18 + src/main/compile/of_typed.ml | 112 ++++- src/main/dune | 12 + src/main/main.ml | 2 + src/main/run/run_mini_c.ml | 9 +- src/main/run/run_typed.ml | 7 +- src/passes/4-typer/typer.ml | 15 +- src/passes/6-transpiler/helpers.ml | 49 ++ src/passes/6-transpiler/transpiler.ml | 439 ++++-------------- src/passes/6-transpiler/untranspiler.ml | 193 ++++++++ src/passes/8-compiler/compiler_program.ml | 9 +- src/passes/operators/operators.ml | 7 +- src/stages/ast_typed/PP.ml | 7 +- src/stages/ast_typed/combinators.ml | 6 +- .../ast_typed/combinators_environment.ml | 2 +- src/stages/ast_typed/misc.ml | 2 +- src/stages/ast_typed/misc_smart.ml | 8 +- src/stages/ast_typed/types.ml | 8 +- src/stages/mini_c/combinators.ml | 4 +- 20 files changed, 523 insertions(+), 399 deletions(-) create mode 100644 src/main/dune create mode 100644 src/main/main.ml create mode 100644 src/passes/6-transpiler/helpers.ml create mode 100644 src/passes/6-transpiler/untranspiler.ml diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index b8b0ff78e..27bf6ebef 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -1,6 +1,15 @@ open Ast_simplified open Trace +open Tezos_utils -let compile_entry (program : program) entry_point = +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_entry typed_program entry_point + Of_typed.compile_function_entry typed_program entry_point + +let compile_expression_entry (program : program) entry_point : Compiler.Program.compiled_program result = + let%bind typed_program = Typer.type_program program in + Of_typed.compile_expression_entry typed_program entry_point + +let compile_expression ae : Michelson.t result = + let%bind typed = Typer.type_expression Ast_typed.Environment.full_empty ae in + Of_typed.compile_expression typed diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index f286ab848..a4fd4e814 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -1 +1,19 @@ open Trace +open Helpers +open Tezos_utils + +let parse_file_program source_filename syntax = + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind simplified = parsify syntax source_filename in + ok simplified + +let compile_file_entry : string -> string -> s_syntax -> Compiler.Program.compiled_program 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_parameter : string -> string -> string -> s_syntax -> Michelson.t result = + fun source_filename _entry_point expression syntax -> + let%bind syntax = syntax_to_variant syntax (Some source_filename) in + let%bind simplified = parsify_expression syntax expression in + Of_simplified.compile_expression simplified diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index b7a60fa3c..96adc461c 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -2,10 +2,116 @@ 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.translate_annotated_expression e in + let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in Of_mini_c.compile_expression mini_c_expression -let compile_entry : program -> string -> _ = fun p entry -> - let%bind (f , (in_ty , out_ty)) = Transpiler.translate_entry p entry in +(* + val compile_value : annotated_expression -> Michelson.t result + This requires writing a function + `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 + +(* + 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 + ``` + + To do so, each declaration `const variable = expr` is translated in + a function `body -> let variable = expr in body`. Those functions are + then applied in order, which yields `let x = 42 in let y = 120 in ...`. + + The entry-point can be an expression, which is then functionalized if + `to_functionalize` is set to true. +*) +let aggregate_declarations_for_entry (lst : program) (name : string) (to_functionalize : bool) : annotated_expression result = + let rec aux acc (lst : program) = + let%bind acc = acc in + match lst with + | [] -> fail @@ Errors.missing_entry_point name + | hd :: tl -> ( + let (Declaration_constant (an , (pre_env , _))) = Location.unwrap hd in + if (an.name <> name) then ( + let next = fun expr -> + let cur = e_a_let_in an.name an.annotated_expression expr pre_env in + acc cur in + aux (ok next) tl + ) else ( + match (an.annotated_expression.expression , to_functionalize) with + | (E_lambda l , false) -> ( + let l' = { l with body = acc l.body } in + let e' = { an.annotated_expression with expression = E_lambda l' } in + ok e' + ) + | (_ , true) -> ( + ok @@ functionalize @@ acc an.annotated_expression + ) + | _ -> fail @@ Errors.not_functional_main an.annotated_expression.location + ) + ) + in + let%bind l = aux (ok (fun x -> x)) lst in + ok l + +let compile_function_entry : program -> string -> _ = fun p entry -> + let%bind expr = aggregate_declarations_for_entry p entry false in + compile_function expr + +let compile_expression_entry : program -> string -> _ = fun p entry -> + let%bind expr = aggregate_declarations_for_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 diff --git a/src/main/dune b/src/main/dune new file mode 100644 index 000000000..f4bfd2efd --- /dev/null +++ b/src/main/dune @@ -0,0 +1,12 @@ +(library + (name main) + (public_name ligo.main) + (libraries + run + compile + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils )) +) diff --git a/src/main/main.ml b/src/main/main.ml new file mode 100644 index 000000000..5795d1e56 --- /dev/null +++ b/src/main/main.ml @@ -0,0 +1,2 @@ +module Run = Run +module Compile = Compile diff --git a/src/main/run/run_mini_c.ml b/src/main/run/run_mini_c.ml index dd3dba8f1..06864c223 100644 --- a/src/main/run/run_mini_c.ml +++ b/src/main/run/run_mini_c.ml @@ -4,6 +4,13 @@ open Trace open Mini_c open Compiler.Program +module Errors = struct + + let entry_error = + simple_error "error translating entry point" + +end + type options = { entry_point : anon_function ; input_type : type_value ; @@ -14,7 +21,7 @@ type options = { let run_entry ?(debug_michelson = false) ?options (entry : anon_function) ty (input:value) : value result = let%bind compiled = - trace error @@ + trace Errors.entry_error @@ translate_entry entry ty in let%bind input_michelson = translate_value input (fst ty) in if debug_michelson then ( diff --git a/src/main/run/run_typed.ml b/src/main/run/run_typed.ml index fc136c63c..0f41fe6fa 100644 --- a/src/main/run/run_typed.ml +++ b/src/main/run/run_typed.ml @@ -1,7 +1,7 @@ open Trace +open Ast_typed -let transpile_value - (e:Ast_typed.annotated_expression) : Mini_c.value result = +let evaluate (e : annotated_expression) : annotated_expression result = let%bind (f , ty) = let open Transpiler in let (f , _) = functionalize e in @@ -32,7 +32,8 @@ let evaluate_typed let run_typed ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) - (program:Ast_typed.program) (input:Ast_typed.annotated_expression) : Ast_typed.annotated_expression result = + (program : Ast_typed.program) (input : Ast_typed.annotated_expression) : Ast_typed.annotated_expression result = + let%bind let%bind () = let open Ast_typed in let%bind (Declaration_constant (d , _)) = get_declaration_by_name program entry in diff --git a/src/passes/4-typer/typer.ml b/src/passes/4-typer/typer.ml index 9e2679a1b..edc9d05b8 100644 --- a/src/passes/4-typer/typer.ml +++ b/src/passes/4-typer/typer.ml @@ -582,9 +582,9 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a bind_map_option (evaluate_type e) output_type in let e' = Environment.add_ez_binder (fst binder) input_type e in - let%bind result = type_expression ?tv_opt:output_type e' result in - let output_type = result.type_annotation in - return (E_lambda {binder = fst binder;input_type;output_type;result}) (t_function input_type output_type ()) + let%bind body = type_expression ?tv_opt:output_type e' result in + let output_type = body.type_annotation in + return (E_lambda {binder = fst binder ; body}) (t_function input_type output_type ()) ) | E_constant (name, lst) -> let%bind lst' = bind_list @@ List.map (type_expression e) lst in @@ -796,11 +796,12 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = let%bind f' = untype_expression f in let%bind arg' = untype_expression arg in return (e_application f' arg') - | E_lambda {binder;input_type;output_type;result} -> - let%bind input_type = untype_type_value input_type in - let%bind output_type = untype_type_value output_type in - let%bind result = untype_expression result in + | E_lambda {binder ; body} -> ( + let%bind io = get_t_function e.type_annotation in + let%bind (input_type , output_type) = bind_map_pair untype_type_value io in + let%bind result = untype_expression body in return (e_lambda binder (Some input_type) (Some output_type) result) + ) | E_tuple lst -> let%bind lst' = bind_list @@ List.map untype_expression lst in diff --git a/src/passes/6-transpiler/helpers.ml b/src/passes/6-transpiler/helpers.ml new file mode 100644 index 000000000..2609123eb --- /dev/null +++ b/src/passes/6-transpiler/helpers.ml @@ -0,0 +1,49 @@ +module AST = Ast_typed +module Append_tree = Tree.Append + +open Trace +open Mini_c + +let list_of_map m = List.rev @@ Map.String.fold (fun _ v prev -> v :: prev) m [] +let kv_list_of_map m = List.rev @@ Map.String.fold (fun k v prev -> (k, v) :: prev) m [] +let map_of_kv_list lst = + let open AST.SMap in + List.fold_left (fun prev (k, v) -> add k v prev) empty lst + +let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result = + let open Append_tree in + let rec aux tv : (string * value * AST.type_value) result= + match tv with + | Leaf (k, t), v -> ok (k, v, t) + | Node {a}, D_left v -> aux (a, v) + | Node {b}, D_right v -> aux (b, v) + | _ -> fail @@ internal_assertion_failure "bad constructor path" + in + let%bind (s, v, t) = aux (tree, v) in + ok (s, v, t) + +let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value * AST.type_value) list) result = + let open Append_tree in + let rec aux tv : ((value * AST.type_value) list) result = + match tv with + | Leaf t, v -> ok @@ [v, t] + | Node {a;b}, D_pair (va, vb) -> + let%bind a' = aux (a, va) in + let%bind b' = aux (b, vb) in + ok (a' @ b') + | _ -> fail @@ internal_assertion_failure "bad tuple path" + in + aux (tree, v) + +let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result = + let open Append_tree in + let rec aux tv : ((string * (value * AST.type_value)) list) result = + match tv with + | Leaf (s, t), v -> ok @@ [s, (v, t)] + | Node {a;b}, D_pair (va, vb) -> + let%bind a' = aux (a, va) in + let%bind b' = aux (b, vb) in + ok (a' @ b') + | _ -> fail @@ internal_assertion_failure "bad record path" + in + aux (tree, v) diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 7d4db9321..ef8d562c4 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -1,4 +1,5 @@ open! Trace +open Helpers module AST = Ast_typed module Append_tree = Tree.Append @@ -6,15 +7,11 @@ open AST.Combinators open Mini_c open Combinators +let untranspile = Untranspiler.untranspile + let temp_unwrap_loc = Location.unwrap let temp_unwrap_loc_list = List.map Location.unwrap -let list_of_map m = List.rev @@ Map.String.fold (fun _ v prev -> v :: prev) m [] -let kv_list_of_map m = List.rev @@ Map.String.fold (fun k v prev -> (k, v) :: prev) m [] -let map_of_kv_list lst = - let open AST.SMap in - List.fold_left (fun prev (k, v) -> add k v prev) empty lst - module Errors = struct let corner_case ~loc message = let title () = "corner case" in @@ -49,53 +46,10 @@ them. please report this to the developers." in row_loc location ; ] 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 - - 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 wrong_mini_c_value expected_type actual = - let title () = "illed typed intermediary value" in - let content () = "type of intermediary value doesn't match what was expected" in - let data = [ - ("expected_type" , fun () -> expected_type) ; - ("actual" , fun () -> Format.asprintf "%a" Mini_c.PP.value actual ) ; - ] in - error ~data title content - - let bad_untranspile bad_type value = - let title () = "untranspiling bad value" in - let content () = Format.asprintf "can not untranspile %s" bad_type in - let data = [ - ("bad_type" , fun () -> bad_type) ; - ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ; - ] in - error ~data title content - - let unknown_untranspile unknown_type value = - let title () = "untranspiling unknown value" in - let content () = Format.asprintf "can not untranspile %s" unknown_type in - let data = [ - ("unknown_type" , fun () -> unknown_type) ; - ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ; - ] in - error ~data title content end open Errors -let rec translate_type (t:AST.type_value) : type_value result = +let rec transpile_type (t:AST.type_value) : type_value result = match t.type_value' with | T_constant ("bool", []) -> ok (T_base Base_bool) | T_constant ("int", []) -> ok (T_base Base_int) @@ -108,19 +62,19 @@ let rec translate_type (t:AST.type_value) : type_value result = | T_constant ("unit", []) -> ok (T_base Base_unit) | T_constant ("operation", []) -> ok (T_base Base_operation) | T_constant ("contract", [x]) -> - let%bind x' = translate_type x in + let%bind x' = transpile_type x in ok (T_contract x') | T_constant ("map", [key;value]) -> - let%bind kv' = bind_map_pair translate_type (key, value) in + let%bind kv' = bind_map_pair transpile_type (key, value) in ok (T_map kv') | T_constant ("list", [t]) -> - let%bind t' = translate_type t in + let%bind t' = transpile_type t in ok (T_list t') | T_constant ("set", [t]) -> - let%bind t' = translate_type t in + let%bind t' = transpile_type t in ok (T_set t') | T_constant ("option", [o]) -> - let%bind o' = translate_type o in + let%bind o' = transpile_type o in ok (T_option o') | T_constant (name , _lst) -> fail @@ unrecognized_type_constant name | T_sum m -> @@ -130,7 +84,7 @@ let rec translate_type (t:AST.type_value) : type_value result = let%bind b = b in ok (T_or (a, b)) in - Append_tree.fold_ne translate_type aux node + Append_tree.fold_ne transpile_type aux node | T_record m -> let node = Append_tree.of_list @@ list_of_map m in let aux a b : type_value result = @@ -138,7 +92,7 @@ let rec translate_type (t:AST.type_value) : type_value result = let%bind b = b in ok (T_pair (a, b)) in - Append_tree.fold_ne translate_type aux node + Append_tree.fold_ne transpile_type aux node | T_tuple lst -> let node = Append_tree.of_list lst in let aux a b : type_value result = @@ -146,10 +100,10 @@ let rec translate_type (t:AST.type_value) : type_value result = let%bind b = b in ok (T_pair (a, b)) in - Append_tree.fold_ne translate_type aux node + Append_tree.fold_ne transpile_type aux node | T_function (param, result) -> ( - let%bind param' = translate_type param in - let%bind result' = translate_type result in + let%bind param' = transpile_type param in + let%bind result' = transpile_type result in ok (T_function (param', result')) ) @@ -191,7 +145,7 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string - bind_fold_list aux (ty , []) lr_path in ok lst -let rec translate_literal : AST.literal -> value = fun l -> match l with +let rec transpile_literal : AST.literal -> value = fun l -> match l with | Literal_bool b -> D_bool b | Literal_int n -> D_int n | Literal_nat n -> D_nat n @@ -206,12 +160,12 @@ let rec translate_literal : AST.literal -> value = fun l -> match l with and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele -> match (AST.get_type' ele.type_value , ele.definition) with | (AST.T_function (f , arg) , ED_declaration (ae , ((_ :: _) as captured_variables)) ) -> - let%bind f' = translate_type f in - let%bind arg' = translate_type arg in + let%bind f' = transpile_type f in + let%bind arg' = transpile_type arg in let%bind env' = transpile_environment ae.environment in let sub_env = Mini_c.Environment.select captured_variables env' in ok @@ Combinators.t_deep_closure sub_env f' arg' - | _ -> translate_type ele.type_value + | _ -> transpile_type ele.type_value and transpile_small_environment : AST.small_environment -> Environment.t result = fun x -> let x' = AST.Environment.Small.get_environment x in @@ -231,10 +185,10 @@ and tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t r let%bind map_tv = get_t_sum t in ok @@ Append_tree.of_list @@ kv_list_of_map map_tv -and translate_annotated_expression (ae:AST.annotated_expression) : expression result = - let%bind tv = translate_type ae.type_annotation in +and transpile_annotated_expression (ae:AST.annotated_expression) : expression result = + let%bind tv = transpile_type ae.type_annotation in let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in - let f = translate_annotated_expression in + let f = transpile_annotated_expression in let info = let title () = "translating expression" in let content () = Format.asprintf "%a" Location.pp ae.location in @@ -242,14 +196,14 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re trace info @@ match ae.expression with | E_let_in {binder; rhs; result} -> - let%bind rhs' = translate_annotated_expression rhs in - let%bind result' = translate_annotated_expression result in + let%bind rhs' = transpile_annotated_expression rhs in + let%bind result' = transpile_annotated_expression result in return (E_let_in ((binder, rhs'.type_value), rhs', result')) | E_failwith ae -> ( - let%bind ae' = translate_annotated_expression ae in + let%bind ae' = transpile_annotated_expression ae in return @@ E_constant ("FAILWITH" , [ae']) ) - | E_literal l -> return @@ E_literal (translate_literal l) + | E_literal l -> return @@ E_literal (transpile_literal l) | E_variable name -> ( let%bind ele = trace_option (corner_case ~loc:__LOC__ "name not in environment") @@ @@ -258,11 +212,11 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re return ~tv @@ E_variable name ) | E_application (a, b) -> - let%bind a = translate_annotated_expression a in - let%bind b = translate_annotated_expression b in + let%bind a = transpile_annotated_expression a in + let%bind b = transpile_annotated_expression b in return @@ E_application (a, b) | E_constructor (m, param) -> ( - let%bind param' = translate_annotated_expression param in + let%bind param' = transpile_annotated_expression param in let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in let%bind node_tv = trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@ @@ -274,7 +228,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re @@ AST.assert_type_value_eq (tv, param.type_annotation) in ok (Some (param'_expr), param'_tv) ) else ( - let%bind tv = translate_type tv in + let%bind tv = transpile_type tv in ok (None, tv) ) in let node a b : (expression' option * type_value) result = @@ -302,14 +256,14 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let tv = T_pair (a_ty , b_ty) in return ~tv @@ E_constant ("PAIR", [a; b]) in - Append_tree.fold_ne (translate_annotated_expression) aux node + Append_tree.fold_ne (transpile_annotated_expression) aux node ) | E_tuple_accessor (tpl, ind) -> ( - let%bind ty' = translate_type tpl.type_annotation in + let%bind ty' = transpile_type tpl.type_annotation in let%bind ty_lst = trace_strong (corner_case ~loc:__LOC__ "not a tuple") @@ get_t_tuple tpl.type_annotation in - let%bind ty'_lst = bind_map_list translate_type ty_lst in + let%bind ty'_lst = bind_map_list transpile_type ty_lst in let%bind path = trace_strong (corner_case ~loc:__LOC__ "tuple access") @@ tuple_access_to_lr ty' ty'_lst ind in @@ -318,7 +272,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | `Left -> "CAR" | `Right -> "CDR" in Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in - let%bind tpl' = translate_annotated_expression tpl in + let%bind tpl' = transpile_annotated_expression tpl in let expr = List.fold_left aux tpl' path in ok expr ) @@ -333,14 +287,14 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re return ~tv @@ E_constant ("PAIR", [a; b]) in trace_strong (corner_case ~loc:__LOC__ "record build") @@ - Append_tree.fold_ne (translate_annotated_expression) aux node + Append_tree.fold_ne (transpile_annotated_expression) aux node ) | E_record_accessor (record, property) -> - let%bind ty' = translate_type (get_type_annotation record) in + let%bind ty' = transpile_type (get_type_annotation record) in let%bind ty_smap = trace_strong (corner_case ~loc:__LOC__ "not a record") @@ get_t_record (get_type_annotation record) in - let%bind ty'_smap = bind_map_smap translate_type ty_smap in + let%bind ty'_smap = bind_map_smap transpile_type ty_smap in let%bind path = trace_strong (corner_case ~loc:__LOC__ "record access") @@ record_access_to_lr ty' ty'_smap property in @@ -349,7 +303,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | `Left -> "CAR" | `Right -> "CDR" in Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty) in - let%bind record' = translate_annotated_expression record in + let%bind record' = transpile_annotated_expression record in let expr = List.fold_left aux record' path in ok expr | E_constant (name , lst) -> ( @@ -358,8 +312,9 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | [i ; f] -> ( let%bind f' = match f.expression with | E_lambda l -> ( - let%bind body' = translate_annotated_expression l.result in - let%bind input' = translate_type l.input_type in + let%bind body' = transpile_annotated_expression l.body in + let%bind (input , _) = get_t_function f.type_annotation in + let%bind input' = transpile_type input in ok ((l.binder , input') , body') ) | E_variable v -> ( @@ -370,8 +325,9 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | ED_declaration (f , _) -> ( match f.expression with | E_lambda l -> ( - let%bind body' = translate_annotated_expression l.result in - let%bind input' = translate_type l.input_type in + let%bind body' = transpile_annotated_expression l.body in + let%bind (input , _) = get_t_function f.type_annotation in + let%bind input' = transpile_type input in ok ((l.binder , input') , body') ) | _ -> fail @@ unsupported_iterator f.location @@ -380,7 +336,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re ) | _ -> fail @@ unsupported_iterator f.location in - let%bind i' = translate_annotated_expression i in + let%bind i' = transpile_annotated_expression i in return @@ E_iterator (name , f' , i') ) | _ -> fail @@ corner_case ~loc:__LOC__ "bad iterator arity" @@ -393,7 +349,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | ("LIST_MAP" , lst) -> map lst | ("MAP_MAP" , lst) -> map lst | _ -> ( - let%bind lst' = bind_map_list (translate_annotated_expression) lst in + let%bind lst' = bind_map_list (transpile_annotated_expression) lst in return @@ E_constant (name , lst') ) ) @@ -401,12 +357,13 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind env = trace_strong (corner_case ~loc:__LOC__ "environment") @@ transpile_environment ae.environment in - translate_lambda env l + let%bind io = get_t_function ae.type_annotation in + transpile_lambda env l io | E_list lst -> ( let%bind t = trace_strong (corner_case ~loc:__LOC__ "not a list") @@ Mini_c.Combinators.get_t_list tv in - let%bind lst' = bind_map_list (translate_annotated_expression) lst in + let%bind lst' = bind_map_list (transpile_annotated_expression) lst in let aux : expression -> expression -> expression result = fun prev cur -> return @@ E_constant ("CONS", [cur ; prev]) in let%bind (init : expression) = return @@ E_make_empty_list t in @@ -416,7 +373,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind t = trace_strong (corner_case ~loc:__LOC__ "not a set") @@ Mini_c.Combinators.get_t_set tv in - let%bind lst' = bind_map_list (translate_annotated_expression) lst in + let%bind lst' = bind_map_list (transpile_annotated_expression) lst in let aux : expression -> expression -> expression result = fun prev cur -> return @@ E_constant ("SET_ADD", [cur ; prev]) in let%bind (init : expression) = return @@ E_make_empty_set t in @@ -430,7 +387,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind prev' = prev in let%bind (k', v') = let v' = e_a_some v ae.environment in - bind_map_pair (translate_annotated_expression) (k , v') in + bind_map_pair (transpile_annotated_expression) (k , v') in return @@ E_constant ("UPDATE", [k' ; v' ; prev']) in let init = return @@ E_make_empty_map (src, dst) in @@ -441,26 +398,26 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re return @@ E_constant ("MAP_GET", [i' ; ds']) ) | E_sequence (a , b) -> ( - let%bind a' = translate_annotated_expression a in - let%bind b' = translate_annotated_expression b in + let%bind a' = transpile_annotated_expression a in + let%bind b' = transpile_annotated_expression b in return @@ E_sequence (a' , b') ) | E_loop (expr , body) -> ( - let%bind expr' = translate_annotated_expression expr in - let%bind body' = translate_annotated_expression body in + let%bind expr' = transpile_annotated_expression expr in + let%bind body' = transpile_annotated_expression body in return @@ E_while (expr' , body') ) | E_assign (typed_name , path , expr) -> ( let ty = typed_name.type_value in let aux : ((AST.type_value * [`Left | `Right] list) as 'a) -> AST.access -> 'a result = fun (prev, acc) cur -> - let%bind ty' = translate_type prev in + let%bind ty' = transpile_type prev in match cur with | Access_tuple ind -> ( let%bind ty_lst = trace_strong (corner_case ~loc:__LOC__ "not a tuple") @@ AST.Combinators.get_t_tuple prev in - let%bind ty'_lst = bind_map_list translate_type ty_lst in + let%bind ty'_lst = bind_map_list transpile_type ty_lst in let%bind path = tuple_access_to_lr ty' ty'_lst ind in let path' = List.map snd path in ok (List.nth ty_lst ind, acc @ path') @@ -469,7 +426,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind ty_map = trace_strong (corner_case ~loc:__LOC__ "not a record") @@ AST.Combinators.get_t_record prev in - let%bind ty'_map = bind_map_smap translate_type ty_map in + let%bind ty'_map = bind_map_smap transpile_type ty_map in let%bind path = record_access_to_lr ty' ty'_map prop in let path' = List.map snd path in ok (Map.String.find prop ty_map, acc @ path') @@ -477,20 +434,20 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | Access_map _k -> fail (corner_case ~loc:__LOC__ "no patch for map yet") in let%bind (_, path) = bind_fold_right_list aux (ty, []) path in - let%bind expr' = translate_annotated_expression expr in + let%bind expr' = transpile_annotated_expression expr in return (E_assignment (typed_name.type_name, path, expr')) ) | E_matching (expr, m) -> ( - let%bind expr' = translate_annotated_expression expr in + let%bind expr' = transpile_annotated_expression expr in match m with | Match_bool {match_true ; match_false} -> - let%bind (t , f) = bind_map_pair (translate_annotated_expression) (match_true, match_false) in + let%bind (t , f) = bind_map_pair (transpile_annotated_expression) (match_true, match_false) in return @@ E_if_bool (expr', t, f) | Match_option { match_none; match_some = ((name, tv), s) } -> - let%bind n = translate_annotated_expression match_none in + let%bind n = transpile_annotated_expression match_none in let%bind (tv' , s') = - let%bind tv' = translate_type tv in - let%bind s' = translate_annotated_expression s in + let%bind tv' = transpile_type tv in + let%bind s' = transpile_annotated_expression s in ok (tv' , s') in return @@ E_if_none (expr' , n , ((name , tv') , s')) | Match_variant (lst , variant) -> ( @@ -504,7 +461,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let rec aux t = match (t : _ Append_tree.t') with | Leaf (name , tv) -> - let%bind tv' = translate_type tv in + let%bind tv' = transpile_type tv in ok (`Leaf name , tv') | Node {a ; b} -> let%bind a' = aux a in @@ -520,7 +477,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind ((_ , name) , body) = trace_option (corner_case ~loc:__LOC__ "missing match clause") @@ List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in - let%bind body' = translate_annotated_expression body in + let%bind body' = transpile_annotated_expression body in return @@ E_let_in ((name , tv) , top , body') ) | ((`Node (a , b)) , tv) -> @@ -545,284 +502,54 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re | AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location ) -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 +and transpile_lambda_deep : Mini_c.Environment.t -> AST.lambda -> _ -> Mini_c.expression result = + fun env l (input_type , output_type)-> + let { binder ; body } : AST.lambda = l in (* Deep capture. Capture the relevant part of the environment. *) 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 ok sub_env in 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%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 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) -and translate_lambda env l = - let { binder ; input_type ; output_type ; result } : AST.lambda = l in - (* Try to translate it in an empty env, if it succeeds, transpiles it as a quote value, else, as a closure expression. *) - let fvs = AST.Free_variables.(annotated_expression (singleton binder) result) in +and transpile_lambda env l (input_type , output_type) = + let { binder ; body } : AST.lambda = l in + let fvs = AST.Free_variables.(annotated_expression (singleton binder) body) in let%bind result = match fvs with | [] -> ( - let%bind result' = translate_annotated_expression result in - let result' = ez_e_return result' in - let%bind input = translate_type input_type in - let%bind output = translate_type output_type in + let%bind result' = transpile_annotated_expression body in + 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 ; result = result'} in ok @@ Combinators.Expression.make_tpl (E_literal content , tv) ) | _ -> ( - translate_lambda_deep env l + transpile_lambda_deep env l (input_type , output_type) ) in ok result -let translate_declaration env (d:AST.declaration) : toplevel_statement result = +let transpile_declaration env (d:AST.declaration) : toplevel_statement result = match d with | Declaration_constant ({name;annotated_expression} , _) -> - let%bind expression = translate_annotated_expression annotated_expression in + let%bind expression = transpile_annotated_expression annotated_expression in let tv = Combinators.Expression.get_type expression in let env' = Environment.add (name, tv) env in ok @@ ((name, expression), environment_wrap env env') -let translate_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') = translate_declaration env cur in + let%bind ((_, env') as cur') = transpile_declaration env cur in ok (cur' :: tl, env'.post_environment) in 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%bind expr = translate_lambda Environment.empty l in - 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] *) -let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value = - let t = e.type_annotation in - let open! AST in - { - binder = "_" ; - input_type = Combinators.t_unit () ; - output_type = t ; - result = e ; - }, Combinators.(t_function (t_unit ()) t ()) - -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 - | [] -> fail @@ missing_entry_point name - | hd :: tl -> ( - let (AST.Declaration_constant (an , (pre_env , _))) = temp_unwrap_loc hd in - match an.name = name with - | false -> ( - let next = fun expr -> - let cur = e_a_let_in an.name an.annotated_expression expr pre_env in - acc cur in - aux (ok next) tl - ) - | true -> ( - match an.annotated_expression.expression with - | E_lambda l -> - let l' = { l with result = acc l.result } in - translate_main l' an.annotated_expression.location - | _ -> - let (l , _) = functionalize an.annotated_expression in - let l' = { l with result = acc l.result } in - translate_main l' an.annotated_expression.location - ) - ) - in - let%bind l = aux (ok (fun x -> x)) lst in - ok l - -open Combinators - -let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result = - let open Append_tree in - let rec aux tv : (string * value * AST.type_value) result= - match tv with - | Leaf (k, t), v -> ok (k, v, t) - | Node {a}, D_left v -> aux (a, v) - | Node {b}, D_right v -> aux (b, v) - | _ -> fail @@ internal_assertion_failure "bad constructor path" - in - let%bind (s, v, t) = aux (tree, v) in - ok (s, v, t) - -let extract_tuple (v : value) (tree : AST.type_value Append_tree.t') : ((value * AST.type_value) list) result = - let open Append_tree in - let rec aux tv : ((value * AST.type_value) list) result = - match tv with - | Leaf t, v -> ok @@ [v, t] - | Node {a;b}, D_pair (va, vb) -> - let%bind a' = aux (a, va) in - let%bind b' = aux (b, vb) in - ok (a' @ b') - | _ -> fail @@ internal_assertion_failure "bad tuple path" - in - aux (tree, v) - -let extract_record (v : value) (tree : _ Append_tree.t') : (_ list) result = - let open Append_tree in - let rec aux tv : ((string * (value * AST.type_value)) list) result = - match tv with - | Leaf (s, t), v -> ok @@ [s, (v, t)] - | Node {a;b}, D_pair (va, vb) -> - let%bind a' = aux (a, va) in - let%bind b' = aux (b, vb) in - ok (a' @ b') - | _ -> fail @@ internal_assertion_failure "bad record path" - in - aux (tree, v) - -let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression result = - let open! AST in - let return e = ok (make_a_e_empty e t) in - match t.type_value' with - | T_constant ("unit", []) -> ( - let%bind () = - trace_strong (wrong_mini_c_value "unit" v) @@ - get_unit v in - return (E_literal Literal_unit) - ) - | T_constant ("bool", []) -> ( - let%bind b = - trace_strong (wrong_mini_c_value "bool" v) @@ - get_bool v in - return (E_literal (Literal_bool b)) - ) - | T_constant ("int", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "int" v) @@ - get_int v in - return (E_literal (Literal_int n)) - ) - | T_constant ("nat", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "nat" v) @@ - get_nat v in - return (E_literal (Literal_nat n)) - ) - | T_constant ("timestamp", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "timestamp" v) @@ - get_timestamp v in - return (E_literal (Literal_timestamp n)) - ) - | T_constant ("tez", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "tez" v) @@ - get_nat v in - return (E_literal (Literal_tez n)) - ) - | T_constant ("string", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "string" v) @@ - get_string v in - return (E_literal (Literal_string n)) - ) - | T_constant ("bytes", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "bytes" v) @@ - get_bytes v in - return (E_literal (Literal_bytes n)) - ) - | T_constant ("address", []) -> ( - let%bind n = - trace_strong (wrong_mini_c_value "address" v) @@ - get_string v in - return (E_literal (Literal_address n)) - ) - | T_constant ("option", [o]) -> ( - let%bind opt = - trace_strong (wrong_mini_c_value "option" v) @@ - get_option v in - match opt with - | None -> ok (e_a_empty_none o) - | Some s -> - let%bind s' = untranspile s o in - ok (e_a_empty_some s') - ) - | T_constant ("map", [k_ty;v_ty]) -> ( - let%bind lst = - trace_strong (wrong_mini_c_value "map" v) @@ - get_map v in - let%bind lst' = - let aux = fun (k, v) -> - let%bind k' = untranspile k k_ty in - let%bind v' = untranspile v v_ty in - ok (k', v') in - bind_map_list aux lst in - return (E_map lst') - ) - | T_constant ("list", [ty]) -> ( - let%bind lst = - trace_strong (wrong_mini_c_value "list" v) @@ - get_list v in - let%bind lst' = - let aux = fun e -> untranspile e ty in - bind_map_list aux lst in - return (E_list lst') - ) - | T_constant ("set", [ty]) -> ( - let%bind lst = - trace_strong (wrong_mini_c_value "set" v) @@ - get_set v in - let%bind lst' = - let aux = fun e -> untranspile e ty in - bind_map_list aux lst in - return (E_set lst') - ) - | T_constant ("contract" , [_ty]) -> - fail @@ bad_untranspile "contract" v - | T_constant ("operation" , []) -> ( - let%bind op = - trace_strong (wrong_mini_c_value "operation" v) @@ - get_operation v in - return (E_literal (Literal_operation op)) - ) - | T_constant (name , _lst) -> - fail @@ unknown_untranspile name v - | T_sum m -> - let lst = kv_list_of_map m in - let%bind node = match Append_tree.of_list lst with - | Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type" - | Full t -> ok t - in - let%bind (name, v, tv) = - trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@ - extract_constructor v node in - let%bind sub = untranspile v tv in - return (E_constructor (name, sub)) - | T_tuple lst -> - let%bind node = match Append_tree.of_list lst with - | Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple" - | Full t -> ok t in - let%bind tpl = - trace_strong (corner_case ~loc:__LOC__ "tuple extract") @@ - extract_tuple v node in - let%bind tpl' = bind_list - @@ List.map (fun (x, y) -> untranspile x y) tpl in - return (E_tuple tpl') - | T_record m -> - let lst = kv_list_of_map m in - let%bind node = match Append_tree.of_list lst with - | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record" - | Full t -> ok t in - let%bind lst = - trace_strong (corner_case ~loc:__LOC__ "record extract") @@ - extract_record v node in - let%bind lst = bind_list - @@ List.map (fun (x, (y, z)) -> let%bind yz = untranspile y z in ok (x, yz)) lst in - let m' = map_of_kv_list lst in - return (E_record m') - | T_function _ -> fail @@ bad_untranspile "function" v diff --git a/src/passes/6-transpiler/untranspiler.ml b/src/passes/6-transpiler/untranspiler.ml new file mode 100644 index 000000000..d79e842b4 --- /dev/null +++ b/src/passes/6-transpiler/untranspiler.ml @@ -0,0 +1,193 @@ +open Helpers + +module AST = Ast_typed +module Append_tree = Tree.Append +open Mini_c +open Trace + +module Errors = struct + + let corner_case ~loc message = + let title () = "corner case" in + let content () = "we don't have a good error message for this case. we are +striving find ways to better report them and find the use-cases that generate +them. please report this to the developers." in + let data = [ + ("location" , fun () -> loc) ; + ("message" , fun () -> message) ; + ] in + error ~data title content + + let wrong_mini_c_value expected_type actual = + let title () = "illed typed intermediary value" in + let content () = "type of intermediary value doesn't match what was expected" in + let data = [ + ("expected_type" , fun () -> expected_type) ; + ("actual" , fun () -> Format.asprintf "%a" Mini_c.PP.value actual ) ; + ] in + error ~data title content + + let bad_untranspile bad_type value = + let title () = "untranspiling bad value" in + let content () = Format.asprintf "can not untranspile %s" bad_type in + let data = [ + ("bad_type" , fun () -> bad_type) ; + ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ; + ] in + error ~data title content + + let unknown_untranspile unknown_type value = + let title () = "untranspiling unknown value" in + let content () = Format.asprintf "can not untranspile %s" unknown_type in + let data = [ + ("unknown_type" , fun () -> unknown_type) ; + ("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ; + ] in + error ~data title content + +end + +open Errors + +let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression result = + let open! AST in + let return e = ok (make_a_e_empty e t) in + match t.type_value' with + | T_constant ("unit", []) -> ( + let%bind () = + trace_strong (wrong_mini_c_value "unit" v) @@ + get_unit v in + return (E_literal Literal_unit) + ) + | T_constant ("bool", []) -> ( + let%bind b = + trace_strong (wrong_mini_c_value "bool" v) @@ + get_bool v in + return (E_literal (Literal_bool b)) + ) + | T_constant ("int", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "int" v) @@ + get_int v in + return (E_literal (Literal_int n)) + ) + | T_constant ("nat", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "nat" v) @@ + get_nat v in + return (E_literal (Literal_nat n)) + ) + | T_constant ("timestamp", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "timestamp" v) @@ + get_timestamp v in + return (E_literal (Literal_timestamp n)) + ) + | T_constant ("tez", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "tez" v) @@ + get_nat v in + return (E_literal (Literal_tez n)) + ) + | T_constant ("string", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "string" v) @@ + get_string v in + return (E_literal (Literal_string n)) + ) + | T_constant ("bytes", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "bytes" v) @@ + get_bytes v in + return (E_literal (Literal_bytes n)) + ) + | T_constant ("address", []) -> ( + let%bind n = + trace_strong (wrong_mini_c_value "address" v) @@ + get_string v in + return (E_literal (Literal_address n)) + ) + | T_constant ("option", [o]) -> ( + let%bind opt = + trace_strong (wrong_mini_c_value "option" v) @@ + get_option v in + match opt with + | None -> ok (e_a_empty_none o) + | Some s -> + let%bind s' = untranspile s o in + ok (e_a_empty_some s') + ) + | T_constant ("map", [k_ty;v_ty]) -> ( + let%bind lst = + trace_strong (wrong_mini_c_value "map" v) @@ + get_map v in + let%bind lst' = + let aux = fun (k, v) -> + let%bind k' = untranspile k k_ty in + let%bind v' = untranspile v v_ty in + ok (k', v') in + bind_map_list aux lst in + return (E_map lst') + ) + | T_constant ("list", [ty]) -> ( + let%bind lst = + trace_strong (wrong_mini_c_value "list" v) @@ + get_list v in + let%bind lst' = + let aux = fun e -> untranspile e ty in + bind_map_list aux lst in + return (E_list lst') + ) + | T_constant ("set", [ty]) -> ( + let%bind lst = + trace_strong (wrong_mini_c_value "set" v) @@ + get_set v in + let%bind lst' = + let aux = fun e -> untranspile e ty in + bind_map_list aux lst in + return (E_set lst') + ) + | T_constant ("contract" , [_ty]) -> + fail @@ bad_untranspile "contract" v + | T_constant ("operation" , []) -> ( + let%bind op = + trace_strong (wrong_mini_c_value "operation" v) @@ + get_operation v in + return (E_literal (Literal_operation op)) + ) + | T_constant (name , _lst) -> + fail @@ unknown_untranspile name v + | T_sum m -> + let lst = kv_list_of_map m in + let%bind node = match Append_tree.of_list lst with + | Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type" + | Full t -> ok t + in + let%bind (name, v, tv) = + trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@ + extract_constructor v node in + let%bind sub = untranspile v tv in + return (E_constructor (name, sub)) + | T_tuple lst -> + let%bind node = match Append_tree.of_list lst with + | Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple" + | Full t -> ok t in + let%bind tpl = + trace_strong (corner_case ~loc:__LOC__ "tuple extract") @@ + extract_tuple v node in + let%bind tpl' = bind_list + @@ List.map (fun (x, y) -> untranspile x y) tpl in + return (E_tuple tpl') + | T_record m -> + let lst = kv_list_of_map m in + let%bind node = match Append_tree.of_list lst with + | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record" + | Full t -> ok t in + let%bind lst = + trace_strong (corner_case ~loc:__LOC__ "record extract") @@ + extract_record v node in + let%bind lst = bind_list + @@ List.map (fun (x, (y, z)) -> let%bind yz = untranspile y z in ok (x, yz)) lst in + let m' = map_of_kv_list lst in + return (E_record m') + | T_function _ -> fail @@ bad_untranspile "function" v diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 789000391..a06fc2a6e 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -1,14 +1,11 @@ open Trace open Mini_c - open Michelson - open Memory_proto_alpha.Protocol.Script_ir_translator - open Operators.Compiler -let get_predicate : string -> type_value -> expression list -> predicate result = fun s ty lst -> - match Map.String.find_opt s Operators.Compiler.predicates with +let get_operator : string -> type_value -> expression list -> predicate result = fun s ty lst -> + match Map.String.find_opt s Operators.Compiler.operators with | Some x -> ok x | None -> ( match s with @@ -196,7 +193,7 @@ and translate_expression (expr:expression) (env:environment) : michelson result PP.environment env ; 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%bind predicate = get_operator str ty lst in let%bind code = match (predicate, List.length lst) with | Constant c, 0 -> ok @@ seq [ pre_code ; diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index cdf983b6a..23c6aaf44 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -639,7 +639,7 @@ module Compiler = struct include Helpers.Compiler open Tezos_utils.Michelson - let predicates = Map.String.of_list [ + let operators = Map.String.of_list [ ("ADD" , simple_binary @@ prim I_ADD) ; ("SUB" , simple_binary @@ prim I_SUB) ; ("TIMES" , simple_binary @@ prim I_MUL) ; @@ -693,6 +693,9 @@ module Compiler = struct ("CONCAT" , simple_binary @@ prim I_CONCAT) ; ] - (* Some complex predicates will need to be added in compiler/compiler_program *) + (* + Some complex operators will need to be added in compiler/compiler_program. + All operators whose compilations involve a type are found there. + *) end diff --git a/src/stages/ast_typed/PP.ml b/src/stages/ast_typed/PP.ml index 3e8edf30c..514a091df 100644 --- a/src/stages/ast_typed/PP.ml +++ b/src/stages/ast_typed/PP.ml @@ -24,10 +24,9 @@ let rec annotated_expression ppf (ae:annotated_expression) : unit = | _ -> fprintf ppf "@[%a@]" expression ae.expression and lambda ppf l = - let {binder;input_type;output_type;result} = l in - fprintf ppf "lambda (%s:%a) : %a return %a" - binder type_value input_type type_value output_type - annotated_expression result + let ({ binder ; body } : lambda) = l in + fprintf ppf "lambda (%s) -> %a" + binder annotated_expression body and expression ppf (e:expression) : unit = match e with diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index ec745fabc..6b2358c28 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -56,6 +56,10 @@ let get_type' (x:type_value) = x.type_value' let get_environment (x:annotated_expression) = x.environment let get_expression (x:annotated_expression) = x.expression +let get_lambda e : _ result = match e with + | E_lambda l -> ok l + | _ -> simple_fail "not a lambda" + let get_t_bool (t:type_value) : unit result = match t.type_value' with | T_constant ("bool", []) -> ok () | _ -> simple_fail "not a bool" @@ -235,7 +239,7 @@ let e_a_string s = make_a_e (e_string s) (t_string ()) let e_a_address s = make_a_e (e_address s) (t_address ()) let e_a_pair a b = make_a_e (e_pair a b) (t_pair a.type_annotation b.type_annotation ()) let e_a_some s = make_a_e (e_some s) (t_option s.type_annotation ()) -let e_a_lambda l = make_a_e (e_lambda l) (t_function l.input_type l.output_type ()) +let e_a_lambda l in_ty out_ty = make_a_e (e_lambda l) (t_function in_ty out_ty ()) let e_a_none t = make_a_e e_none (t_option t ()) let e_a_tuple lst = make_a_e (E_tuple lst) (t_tuple (List.map get_type_annotation lst) ()) let e_a_record r = make_a_e (e_record r) (t_record (SMap.map get_type_annotation r) ()) diff --git a/src/stages/ast_typed/combinators_environment.ml b/src/stages/ast_typed/combinators_environment.ml index e8ca37530..4c41f7296 100644 --- a/src/stages/ast_typed/combinators_environment.ml +++ b/src/stages/ast_typed/combinators_environment.ml @@ -18,7 +18,7 @@ let e_a_empty_record r = e_a_record r Environment.full_empty let e_a_empty_map lst k v = e_a_map lst k v Environment.full_empty let e_a_empty_list lst t = e_a_list lst t Environment.full_empty let ez_e_a_empty_record r = ez_e_a_record r Environment.full_empty -let e_a_empty_lambda l = e_a_lambda l Environment.full_empty +let e_a_empty_lambda l i o = e_a_lambda l i o Environment.full_empty open Environment diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 091531789..a71ff3fae 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -171,7 +171,7 @@ module Free_variables = struct and lambda : bindings -> lambda -> bindings = fun b l -> let b' = union (singleton l.binder) b in - annotated_expression b' l.result + annotated_expression b' l.body and annotated_expression : bindings -> annotated_expression -> bindings = fun b ae -> expression b ae.expression diff --git a/src/stages/ast_typed/misc_smart.ml b/src/stages/ast_typed/misc_smart.ml index 0d0e8cd02..9e9520e3d 100644 --- a/src/stages/ast_typed/misc_smart.ml +++ b/src/stages/ast_typed/misc_smart.ml @@ -4,7 +4,7 @@ open Combinators open Misc let program_to_main : program -> string -> lambda result = fun p s -> - let%bind (main , input_type , output_type) = + let%bind (main , input_type , _) = let pred = fun d -> match d with | Declaration_constant (d , _) when d.name = s -> Some d.annotated_expression @@ -25,15 +25,13 @@ let program_to_main : program -> string -> lambda result = fun p s -> | Declaration_constant (_ , (_ , post_env)) -> post_env in List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in let binder = "@contract_input" in - let result = + let body = let input_expr = e_a_variable binder input_type env in let main_expr = e_a_variable s (get_type_annotation main) env in e_a_application main_expr input_expr env in ok { binder ; - input_type ; - output_type ; - result ; + body ; } module Captured_variables = struct diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index cf8c40fec..6fe7f921e 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -69,10 +69,10 @@ and named_type_value = { } and lambda = { - binder: name ; - input_type: tv ; - output_type: tv ; - result: ae ; + binder : name ; + (* input_type: tv ; + * output_type: tv ; *) + body : ae ; } and let_in = { diff --git a/src/stages/mini_c/combinators.ml b/src/stages/mini_c/combinators.ml index f7342987e..9e8467207 100644 --- a/src/stages/mini_c/combinators.ml +++ b/src/stages/mini_c/combinators.ml @@ -164,12 +164,10 @@ 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 = e - let d_unit : value = D_unit let basic_quote expr : anon_function result = - ok @@ quote "input" (ez_e_return expr) + ok @@ quote "input" expr let basic_int_quote expr : anon_function result = basic_quote expr