balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

simplifying compiler

Browse Source
This commit is contained in:
galfour 2019-08-20 22:51:16 +02:00
parent 85c5630af4
commit de96a04681
10 changed files with 146 additions and 411 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

153
src/compiler/compiler_environment.ml
View File

@ -1,14 +1,12 @@
open Proto_alpha_utils
open Trace open Trace
open Mini_c open Mini_c
open Environment open Environment
open Michelson open Michelson
open Memory_proto_alpha.Script_ir_translator
module Stack = Meta_michelson.Stack module Stack = Meta_michelson.Stack
let get : environment -> string -> michelson result = fun e s -> let get : environment -> string -> michelson result = fun e s ->
let%bind (type_value , position) = let%bind (_ , position) =
let error = let error =
let title () = "Environment.get" in let title () = "Environment.get" in
let content () = Format.asprintf "%s in %a" let content () = Format.asprintf "%s in %a"
@ -26,22 +24,10 @@ let get : environment -> string -> michelson result = fun e s ->
in in
let code = aux position 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 ok code
let set : environment -> string -> michelson result = fun e s -> let set : environment -> string -> michelson result = fun e s ->
let%bind (type_value , position) = let%bind (_ , position) =
generic_try (simple_error "Environment.get") @@ generic_try (simple_error "Environment.get") @@
(fun () -> Environment.get_i s e) in (fun () -> Environment.get_i s e) in
let rec aux = fun n -> let rec aux = fun n ->
@ -54,37 +40,11 @@ let set : environment -> string -> michelson result = fun e s ->
in in
let code = aux position 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 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 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 ok code
let select ?(rev = false) ?(keep = true) : environment -> string list -> michelson result = fun e lst -> 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 in
List.fold_right' aux (seq []) e_lst 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 ok code
let select_env : environment -> environment -> michelson result = fun source filter -> 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 Assert.assert_true (List.length e <> 0) in
let code = seq @@ List.map (Function.constant i_pair) @@ List.tl e 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 ok code
let unpack : environment -> michelson result = fun e -> let unpack : environment -> michelson result = fun e ->
@ -192,26 +109,6 @@ let unpack : environment -> michelson result = fun e ->
] in ] in
let code = aux l 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 ok code
@ -239,53 +136,11 @@ let pack_select : environment -> string list -> michelson result = fun e lst ->
in in
List.fold_right' aux (true , seq []) 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 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 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 ok code
let pop : environment -> environment result = fun e -> let pop : environment -> environment result = fun e ->

295
src/compiler/compiler_program.ml
View File

@ -9,8 +9,6 @@ open Memory_proto_alpha.Script_ir_translator
open Operators.Compiler open Operators.Compiler
open Proto_alpha_utils
let get_predicate : string -> type_value -> expression list -> predicate result = fun s ty lst -> let get_predicate : string -> type_value -> expression list -> predicate result = fun s ty lst ->
match Map.String.find_opt s Operators.Compiler.predicates with match Map.String.find_opt s Operators.Compiler.predicates with
| Some x -> ok x | 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") | 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_bool b -> ok @@ prim (if b then D_True else D_False)
| D_int n -> ok @@ int (Z.of_int n) | D_int n -> ok @@ int (Z.of_int n)
| D_nat 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_bytes s -> ok @@ bytes (Tezos_stdlib.MBytes.of_bytes s)
| D_unit -> ok @@ prim D_Unit | D_unit -> ok @@ prim D_Unit
| D_pair (a, b) -> ( | D_pair (a, b) -> (
let%bind a = translate_value a in let%bind (a_ty , b_ty) = get_t_pair ty in
let%bind b = translate_value b 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 ok @@ prim ~children:[a;b] D_Pair
) )
| D_left a -> translate_value a >>? fun a -> ok @@ prim ~children:[a] D_Left | D_left a -> (
| D_right b -> translate_value b >>? fun b -> ok @@ prim ~children:[b] D_Right let%bind (a_ty , _) = get_t_or ty in
| D_function anon -> translate_function anon 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_none -> ok @@ prim D_None
| D_some s -> | D_some s ->
let%bind s' = translate_value s in let%bind s' = translate_value s ty in
ok @@ prim ~children:[s'] D_Some ok @@ prim ~children:[s'] D_Some
| D_map lst -> | D_map lst -> (
let%bind lst' = bind_map_list (bind_map_pair translate_value) lst in 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 sorted = List.sort (fun (x , _) (y , _) -> compare x y) lst' in
let aux (a, b) = prim ~children:[a;b] D_Elt in let aux (a, b) = prim ~children:[a;b] D_Elt in
ok @@ seq @@ List.map aux sorted 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' 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 let sorted = List.sort compare lst' in
ok @@ seq sorted ok @@ seq sorted
)
| D_operation _ -> | D_operation _ ->
simple_fail "can't compile an operation" simple_fail "can't compile an operation"
and translate_function (content:anon_function) : michelson result = and translate_expression (expr:expression) (env:environment) : 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 =
let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in let (expr' , ty) = Combinators.Expression.(get_content expr , get_type expr) in
let error_message () = let error_message () =
Format.asprintf "\n- expr: %a\n- type: %a\n" PP.expression expr PP.type_ ty Format.asprintf "\n- expr: %a\n- type: %a\n" PP.expression expr PP.type_ ty
in in
(* let i_skip = i_push_unit in *) let return code = ok code 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
trace (error (thunk "compiling expression") error_message) @@ trace (error (thunk "compiling expression") error_message) @@
match expr' with match expr' with
| E_skip -> return ~end_env:env ~unit_opt:true @@ seq [] | E_skip -> return @@ i_push_unit
| 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_literal v -> | 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 let%bind t = Compiler_type.type_ ty in
return @@ i_push t v return @@ i_push t v
| E_application(f, arg) -> ( | E_application(f, arg) -> (
match Combinators.Expression.get_type f with match Combinators.Expression.get_type f with
| T_function _ -> ( | T_function _ -> (
trace (simple_error "Compiling quote application") @@ trace (simple_error "Compiling quote application") @@
let%bind (f , env') = translate_expression ~push_var_name:"application_f" f env in let%bind f = translate_expression f env in
let%bind (arg , _) = translate_expression ~push_var_name:"application_arg" arg env' in let%bind arg = translate_expression arg env in
return @@ seq [ return @@ seq [
i_comment "quote application" ; i_comment "quote application" ;
i_comment "get f" ; 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 , _) -> ( | T_deep_closure (small_env, input_ty , _) -> (
trace (simple_error "Compiling deep closure application") @@ trace (simple_error "Compiling deep closure application") @@
let%bind (arg' , env') = translate_expression ~push_var_name:"closure_arg" arg env in let%bind arg' = translate_expression arg env in
let%bind (f' , env'') = translate_expression ~push_var_name:"closure_f" f env' in let%bind f' = translate_expression f env in
let%bind f_ty = Compiler_type.type_ f.type_value in
let%bind append_closure = Compiler_environment.add_packed_anon small_env input_ty in let%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 [ return @@ seq [
i_comment "closure application" ; i_comment "closure application" ;
i_comment "arg" ; 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 let%bind code = Compiler_environment.get env x in
return code return code
| E_sequence (a , b) -> ( | E_sequence (a , b) -> (
let%bind (a' , env_a) = translate_expression a env in let%bind a' = translate_expression a env in
let%bind (b' , env_b) = translate_expression b env_a in let%bind b' = translate_expression b env in
return ~end_env:env_b @@ seq [ return @@ seq [
a' ; a' ;
b' ; b' ;
] ]
@ -264,12 +191,12 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m
let module L = Logger.Stateful() in let module L = Logger.Stateful() in
let%bind lst' = let%bind lst' =
let aux env expr = 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" L.log @@ Format.asprintf "\n%a -> %a in %a\n"
PP.expression expr PP.expression expr
Michelson.pp code Michelson.pp code
PP.environment env ; PP.environment env ;
ok (env' , code) ok (env , code)
in in
bind_fold_map_right_list aux env lst in bind_fold_map_right_list aux env lst in
let%bind predicate = get_predicate str ty 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 let%bind o' = Compiler_type.type_ o in
return @@ i_none o' return @@ i_none o'
| E_if_bool (c, a, b) -> ( | E_if_bool (c, a, b) -> (
let%bind (c' , env') = translate_expression ~push_var_name:"bool_condition" c env in let%bind c' = translate_expression c env in
let%bind popped = Compiler_environment.pop env' in let%bind a' = translate_expression a env in
let%bind (a' , env_a') = translate_expression ~push_var_name:"if_true" a popped in let%bind b' = translate_expression b env in
let%bind (b' , _env_b') = translate_expression ~push_var_name:"if_false" b popped in
let%bind code = ok (seq [ let%bind code = ok (seq [
c' ; c' ;
i_if a' b' ; i_if a' b' ;
]) in ]) in
return ~end_env:env_a' code return code
) )
| E_if_none (c, n, (ntv , s)) -> ( | E_if_none (c, n, (ntv , s)) -> (
let%bind (c' , env') = translate_expression ~push_var_name:"if_none_condition" c env in let%bind c' = translate_expression c env in
let%bind popped = Compiler_environment.pop env' in let%bind n' = translate_expression n env in
let%bind (n' , _) = translate_expression ~push_var_name:"if_none" n popped in let s_env = Environment.add ntv env in
let s_env = Environment.add ntv popped in let%bind s' = translate_expression s s_env 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 popped' = Compiler_environment.pop s_env' in let%bind restrict_s = Compiler_environment.select_env popped' env in
let%bind restrict_s = Compiler_environment.select_env popped' popped in
let%bind code = ok (seq [ let%bind code = ok (seq [
c' ; c' ;
i_if_none n' (seq [ i_if_none n' (seq [
@ -341,11 +266,11 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m
return code return code
) )
| E_if_left (c, (l_ntv , l), (r_ntv , r)) -> ( | 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 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 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_l = Compiler_environment.select_env l_env env in
let%bind restrict_r = Compiler_environment.select_env r_env env in let%bind restrict_r = Compiler_environment.select_env r_env env in
let%bind code = ok (seq [ let%bind code = ok (seq [
@ -364,13 +289,13 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m
return code return code
) )
| E_let_in (v , expr , body) -> ( | 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 env' =
let%bind popped = Compiler_environment.pop expr_env in let%bind popped = Compiler_environment.pop env in
ok @@ Environment.add v popped 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 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 Compiler_environment.select_env popped env in
let%bind code = ok (seq [ let%bind code = ok (seq [
expr' ; expr' ;
@ -381,29 +306,29 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m
return code return code
) )
| E_iterator (name , (v , body) , expr) -> ( | E_iterator (name , (v , body) , expr) -> (
let%bind (expr' , expr_env) = translate_expression ~push_var_name:"iter_expr" expr env in let%bind expr' = translate_expression expr env in
let%bind popped = Compiler_environment.pop expr_env in let%bind popped = Compiler_environment.pop env in
let%bind env' = ok @@ Environment.add v popped 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 match name with
| "ITER" -> ( | "ITER" -> (
let%bind restrict = let%bind restrict =
Compiler_environment.select_env body_env popped in Compiler_environment.select_env env popped in
let%bind code = ok (seq [ let%bind code = ok (seq [
expr' ; expr' ;
i_iter (seq [body' ; restrict]) ; i_iter (seq [body' ; restrict]) ;
]) in ]) in
return ~end_env:popped code return code
) )
| "MAP" -> ( | "MAP" -> (
let%bind restrict = 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 Compiler_environment.select_env popped' popped in
let%bind code = ok (seq [ let%bind code = ok (seq [
expr' ; expr' ;
i_map (seq [body' ; dip restrict]) ; i_map (seq [body' ; dip restrict]) ;
]) in ]) in
return ~prepend_env:popped code return code
) )
| s -> ( | s -> (
let error = error (thunk "bad iterator") (thunk s) in 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) -> ( | E_assignment (name , lrs , expr) -> (
let%bind (expr' , env') = translate_expression ~push_var_name:"assignment_expr" expr env in let%bind expr' = translate_expression expr env in
let%bind get_code = Compiler_environment.get env' name in let%bind get_code = Compiler_environment.get env name in
let modify_code = let modify_code =
let aux acc step = match step with let aux acc step = match step with
| `Left -> seq [dip i_unpair ; acc ; i_pair] | `Left -> seq [dip i_unpair ; acc ; i_pair]
@ -433,7 +358,7 @@ and translate_expression ?push_var_name (expr:expression) (env:environment) : (m
in in
error title content in error title content in
trace error @@ trace error @@
return ~end_env:env ~unit_opt:true @@ seq [ return @@ seq [
i_comment "assign: start # env" ; i_comment "assign: start # env" ;
expr' ; expr' ;
i_comment "assign: compute rhs # rhs : env" ; 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) -> ( | E_while (expr , block) -> (
let%bind (expr' , env') = translate_expression ~push_var_name:"while_expr" expr env in let%bind expr' = translate_expression expr env in
let%bind popped = Compiler_environment.pop env' in let%bind popped = Compiler_environment.pop env in
let%bind (block' , env'') = translate_expression block popped in let%bind block' = translate_expression block popped in
let%bind restrict_block = Compiler_environment.select_env env'' popped in let%bind restrict_block = Compiler_environment.select_env env popped in
return ~end_env:env ~unit_opt:true @@ seq [ return @@ seq [
expr' ; expr' ;
prim ~children:[seq [ prim ~children:[seq [
block' ; 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 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 [ let code = seq [
i_comment "function result" ; i_comment "function result" ;
expr ; expr ;
] in ] 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 ok code
type compiled_program = { type compiled_program = {
@ -502,12 +402,12 @@ type compiled_program = {
body : michelson ; 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) = let is_main (((name , expr), _):toplevel_statement) =
match Combinators.Expression.(get_content expr , get_type expr)with 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 -> when name = entry ->
Some content Some (content , ty)
| _ -> None | _ -> None
in in
let%bind main = let%bind main =
@ -517,18 +417,17 @@ let get_main : program -> string -> anon_function result = fun p entry ->
ok main ok main
let translate_program (p:program) (entry:string) : compiled_program result = let translate_program (p:program) (entry:string) : compiled_program result =
let%bind main = get_main p entry in let%bind (main , (input , output)) = get_main p entry in
let {input;output} : anon_function = main in let%bind body = translate_quote_body main input in
let%bind body = translate_quote_body main in
let%bind input = Compiler_type.Ty.type_ input in let%bind input = Compiler_type.Ty.type_ input in
let%bind output = Compiler_type.Ty.type_ output in let%bind output = Compiler_type.Ty.type_ output in
ok ({input;output;body}:compiled_program) ok ({input;output;body}:compiled_program)
let translate_entry (p:anon_function) : compiled_program result = let translate_entry (p:anon_function) ty : compiled_program result =
let {input;output} : anon_function = p in let (input , output) = ty in
let%bind body = let%bind body =
trace (simple_error "compile entry 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 input = Compiler_type.Ty.type_ input in
let%bind output = Compiler_type.Ty.type_ output in let%bind output = Compiler_type.Ty.type_ output in
ok ({input;output;body}:compiled_program) ok ({input;output;body}:compiled_program)
@ -547,11 +446,11 @@ them. please report this to the developers." in
end end
open Errors 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 = let%bind compiled_program =
trace_strong (corner_case ~loc:__LOC__ "compiling") @@ trace_strong (corner_case ~loc:__LOC__ "compiling") @@
translate_entry f in translate_entry f ty in
let%bind (param_ty , storage_ty) = Combinators.get_t_pair f.input 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 param_michelson = Compiler_type.type_ param_ty in
let%bind storage_michelson = Compiler_type.type_ storage_ty in let%bind storage_michelson = Compiler_type.type_ storage_ty in
let contract = Michelson.contract param_michelson storage_michelson compiled_program.body in let contract = Michelson.contract param_michelson storage_michelson compiled_program.body in

8
src/main/run_mini_c.ml
View File

@ -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 Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in
ok (Ex_typed_value (output_ty, output)) 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%bind compiled =
let error = let error =
let title () = "compile entry" in let title () = "compile entry" in
@ -31,13 +31,13 @@ let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:v
in in
error title content in error title content in
trace error @@ trace error @@
translate_entry entry in translate_entry entry ty in
let%bind input_michelson = translate_value input in let%bind input_michelson = translate_value input (fst ty) in
if debug_michelson then ( if debug_michelson then (
Format.printf "Program: %a\n" Michelson.pp compiled.body ; Format.printf "Program: %a\n" Michelson.pp compiled.body ;
Format.printf "Expression: %a\n" PP.expression entry.result ; Format.printf "Expression: %a\n" PP.expression entry.result ;
Format.printf "Input: %a\n" PP.value input ; 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 ; Format.printf "Compiled Input: %a\n" Michelson.pp input_michelson ;
) ; ) ;
let%bind ex_ty_value = run_aux ?options compiled input_michelson in let%bind ex_ty_value = run_aux ?options compiled input_michelson in

20
src/main/run_source.ml
View File

@ -47,8 +47,8 @@ include struct
end end
let transpile_value let transpile_value
(e:Ast_typed.annotated_expression) : Mini_c.value result = (e:Ast_typed.annotated_expression) : (Mini_c.value * _) result =
let%bind f = let%bind (f , ty) =
let open Transpiler in let open Transpiler in
let (f , _) = functionalize e in let (f , _) = functionalize e in
let%bind main = translate_main f e.location in let%bind main = translate_main f e.location in
@ -56,8 +56,8 @@ let transpile_value
in in
let input = Mini_c.Combinators.d_unit 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 ok (r , snd ty)
let parsify_pascaligo = fun source -> let parsify_pascaligo = fun source ->
let%bind raw = let%bind raw =
@ -148,12 +148,12 @@ let compile_contract_file : string -> string -> s_syntax -> string result = fun
let%bind typed = let%bind typed =
trace (simple_error "typing") @@ trace (simple_error "typing") @@
Typer.type_program simplified in Typer.type_program simplified in
let%bind mini_c = let%bind (mini_c , mini_c_ty) =
trace (simple_error "transpiling") @@ trace (simple_error "transpiling") @@
Transpiler.translate_entry typed entry_point in Transpiler.translate_entry typed entry_point in
let%bind michelson = let%bind michelson =
trace (simple_error "compiling") @@ trace (simple_error "compiling") @@
Compiler.translate_contract mini_c in Compiler.translate_contract mini_c mini_c_ty in
let str = let str =
Format.asprintf "%a" Michelson.pp_stripped michelson in Format.asprintf "%a" Michelson.pp_stripped michelson in
ok str ok str
@ -184,12 +184,12 @@ let compile_contract_parameter : string -> string -> string -> s_syntax -> strin
let%bind () = let%bind () =
trace (simple_error "expression type doesn't match type parameter") @@ trace (simple_error "expression type doesn't match type parameter") @@
Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in 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") @@ trace (simple_error "transpiling expression") @@
transpile_value typed in transpile_value typed in
let%bind michelson = let%bind michelson =
trace (simple_error "compiling expression") @@ trace (simple_error "compiling expression") @@
Compiler.translate_value mini_c in Compiler.translate_value mini_c mini_c_ty in
let str = let str =
Format.asprintf "%a" Michelson.pp_stripped michelson in Format.asprintf "%a" Michelson.pp_stripped michelson in
ok str ok str
@ -223,12 +223,12 @@ let compile_contract_storage : string -> string -> string -> s_syntax -> string
let%bind () = let%bind () =
trace (simple_error "expression type doesn't match type storage") @@ trace (simple_error "expression type doesn't match type storage") @@
Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in 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") @@ trace (simple_error "transpiling expression") @@
transpile_value typed in transpile_value typed in
let%bind michelson = let%bind michelson =
trace (simple_error "compiling expression") @@ trace (simple_error "compiling expression") @@
Compiler.translate_value mini_c in Compiler.translate_value mini_c mini_c_ty in
let str = let str =
Format.asprintf "%a" Michelson.pp_stripped michelson in Format.asprintf "%a" Michelson.pp_stripped michelson in
ok str ok str

12
src/main/run_typed.ml
View File

@ -2,7 +2,7 @@ open Trace
let transpile_value let transpile_value
(e:Ast_typed.annotated_expression) : Mini_c.value result = (e:Ast_typed.annotated_expression) : Mini_c.value result =
let%bind f = let%bind (f , ty) =
let open Transpiler in let open Transpiler in
let (f , _) = functionalize e in let (f , _) = functionalize e in
let%bind main = translate_main f e.location in let%bind main = translate_main f e.location in
@ -10,7 +10,7 @@ let transpile_value
in in
let input = Mini_c.Combinators.d_unit 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 ok r
let evaluate_typed let evaluate_typed
@ -18,12 +18,12 @@ let evaluate_typed
?options (entry:string) (program:Ast_typed.program) : Ast_typed.annotated_expression result = ?options (entry:string) (program:Ast_typed.program) : Ast_typed.annotated_expression result =
trace (simple_error "easy evaluate typed") @@ trace (simple_error "easy evaluate typed") @@
let%bind result = let%bind result =
let%bind mini_c_main = let%bind (mini_c_main , ty) =
Transpiler.translate_entry program entry in Transpiler.translate_entry program entry in
(if debug_mini_c then (if debug_mini_c then
Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) 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 in
let%bind typed_result = let%bind typed_result =
let%bind typed_main = Ast_typed.get_entry program entry in 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)) Ast_typed.assert_type_value_eq (arg_ty , (Ast_typed.get_type_annotation input))
in in
let%bind mini_c_main = let%bind (mini_c_main , ty) =
trace (simple_error "transpile mini_c entry") @@ trace (simple_error "transpile mini_c entry") @@
Transpiler.translate_entry program entry in Transpiler.translate_entry program entry in
(if debug_mini_c then (if debug_mini_c then
@ -59,7 +59,7 @@ let run_typed
in in
error title content in error title content in
trace error @@ 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 typed_result =
let%bind main_result_type = let%bind main_result_type =
let%bind typed_main = Ast_typed.get_functional_entry program entry in let%bind typed_main = Ast_typed.get_functional_entry program entry in

10
src/mini_c/PP.ml
View File

@ -66,10 +66,6 @@ and value_assoc ppf : (value * value) -> unit = fun (a, b) ->
fprintf ppf "%a -> %a" value a value b fprintf ppf "%a -> %a" value a value b
and expression' ppf (e:expression') = match e with 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_skip -> fprintf ppf "skip"
| E_variable v -> fprintf ppf "V(%s)" v | E_variable v -> fprintf ppf "V(%s)" v
| E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b | 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 expression' e.content
type_ e.type_value type_ e.type_value
and function_ ppf ({binder ; input ; output ; result}:anon_function) = and function_ ppf ({binder ; result}:anon_function) =
fprintf ppf "fun (%s:%a) : %a (%a)" fprintf ppf "fun %s -> (%a)"
binder binder
type_ input
type_ output
expression result expression result
and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e

16
src/mini_c/combinators.ml
View File

@ -82,6 +82,10 @@ let get_t_pair (t:type_value) = match t with
| T_pair (a, b) -> ok (a, b) | T_pair (a, b) -> ok (a, b)
| _ -> simple_fail "not a type pair" | _ -> 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 let get_t_map (t:type_value) = match t with
| T_map kv -> ok kv | T_map kv -> ok kv
| _ -> simple_fail "not a type map" | _ -> 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_pair x y : type_value = T_pair ( x , y )
let t_union x y : type_value = T_or ( 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 ; 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_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 d_unit : value = D_unit
let basic_quote i o expr : anon_function result = let basic_quote expr : anon_function result =
ok @@ quote "input" i o (ez_e_return expr) ok @@ quote "input" (ez_e_return expr)
let basic_int_quote expr : anon_function result = 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 } let environment_wrap pre_environment post_environment = { pre_environment ; post_environment }

9
src/mini_c/types.ml
View File

@ -11,7 +11,7 @@ type type_base =
type type_value = type type_value =
| T_pair of (type_value * type_value) | T_pair of (type_value * type_value)
| T_or 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_deep_closure of environment * type_value * type_value
| T_base of type_base | T_base of type_base
| T_map of (type_value * type_value) | T_map of (type_value * type_value)
@ -57,10 +57,6 @@ and selector = var_name list
and expression' = and expression' =
| E_literal of value | 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_skip
| E_constant of string * expression list | E_constant of string * expression list
| E_application of expression * expression | 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_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_let_in of ((var_name * type_value) * expression * expression)
| E_sequence of (expression * expression) | E_sequence of (expression * expression)
(* | E_sequence_drop of (expression * expression) *)
| E_assignment of (string * [`Left | `Right] list * expression) | E_assignment of (string * [`Left | `Right] list * expression)
| E_while of expression * expression | E_while of expression * expression
@ -91,8 +86,6 @@ and toplevel_statement = assignment * environment_wrap
and anon_function = { and anon_function = {
binder : string ; binder : string ;
input : type_value ;
output : type_value ;
result : expression ; result : expression ;
} }

2
src/test/compiler_tests.ml
View File

@ -5,7 +5,7 @@ open Test_helpers
let run_entry_int (e:anon_function) (n:int) : int result = let run_entry_int (e:anon_function) (n:int) : int result =
let param : value = D_int n in 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 match result with
| D_int n -> ok n | D_int n -> ok n
| _ -> simple_fail "result is not an int" | _ -> simple_fail "result is not an int"

32
src/transpiler/transpiler.ml
View File

@ -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 -> 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 let { binder ; input_type ; output_type ; result } : AST.lambda = l in
(* Deep capture. Capture the relevant part of the environment. *) (* 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 free_variables = Ast_typed.Free_variables.lambda [] l in
let sub_env = Mini_c.Environment.select free_variables env in let sub_env = Mini_c.Environment.select free_variables env in
let tv = Environment.closure_representation sub_env in ok sub_env in
ok (free_variables , sub_env , tv) 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 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 output = translate_type output_type in
let%bind result = translate_annotated_expression result in let%bind result = translate_annotated_expression result in
let result = let f_literal = D_function { binder ; result } in
let load_expr = Expression.make_tpl (E_variable binder , input) in let expr' = E_literal f_literal in
ez_e_return @@ ez_e_sequence (E_environment_load (load_expr , init_env)) result in ok (expr' , raw_input , output) 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 tv = Mini_c.t_deep_closure c_env input_tv output_tv 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 = and translate_lambda env l =
let { binder ; input_type ; output_type ; result } : AST.lambda = l in 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 input = translate_type input_type in
let%bind output = translate_type output_type in let%bind output = translate_type output_type in
let tv = Combinators.t_function input output 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) 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 let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in
ok statements 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 let%bind expr = translate_lambda Environment.empty l in
match Combinators.Expression.get_content expr with match expr.content , expr.type_value with
| E_literal (D_function f) -> ok f | E_literal (D_function f) , T_function ty -> ok (f , ty)
| _ -> fail @@ not_functional_main loc | _ -> fail @@ not_functional_main loc
(* From an expression [expr], build the expression [fun () -> expr] *) (* 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 ; result = e ;
}, Combinators.(t_function (t_unit ()) t ()) }, 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 rec aux acc (lst:AST.program) =
let%bind acc = acc in let%bind acc = acc in
match lst with match lst with