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

tmp

Browse Source
This commit is contained in:
Galfour 2019-04-17 22:53:43 +00:00
parent c74e2846df
commit 079e997cc4
4 changed files with 36 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/ligo/ast_typed.ml
View File

@ -560,6 +560,7 @@ module Combinators = struct
type_value (T_sum map) None
let t_function param result ?s () : type_value = type_value (T_function (param, result)) s
let t_shallow_closure param result ?s () : type_value = type_value (T_function (param, result)) s
let get_annotation (x:annotated_expression) = x.type_annotation

3
src/ligo/mini_c/combinators.ml
View File

@ -80,6 +80,9 @@ let get_last_statement ((b', _):block) : statement result =
let t_int : type_value = T_base Base_int
let t_nat : type_value = T_base Base_nat
let t_function x y : type_value = T_function ( x , y )
let t_pair x y : type_value = T_pair ( x , y )
let quote binder input output body result : anon_function =
let content : anon_function_content = {
binder ; input ; output ;

25
src/ligo/mini_c/compiler.ml
View File

@ -203,8 +203,8 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul
] in
ok code
| E_function anon -> (
match ty with
| T_function (_, _) ->
match anon.capture_type with
| No_capture ->
let%bind body = translate_function_body anon in
let%bind input_type = Compiler_type.type_ anon.input in
let%bind output_type = Compiler_type.type_ anon.output in
@ -213,7 +213,7 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul
i_pair ;
] in
ok code
| T_deep_closure (small_env, _, _) ->
| Deep_capture small_env ->
(* Capture the variable bounds, assemble them. On call, append the input. *)
let%bind body = translate_function_body anon in
let%bind capture = Environment.Small.to_mini_c_capture env small_env in
@ -228,19 +228,18 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul
i_pair ;
] in
ok code
| T_shallow_closure (_, _, _) ->
| Shallow_capture _ ->
(* Capture the whole environment. *)
let%bind body = translate_function_body anon in
let%bind input_type = Compiler_type.type_ anon.input in
let%bind output_type = Compiler_type.type_ anon.output in
let code = seq [
dip i_dup ; i_swap ;
i_lambda input_type output_type body ;
i_piar ;
i_pair ;
let code = seq [ (* stack :: env *)
dip i_dup ; i_swap ; (* env :: stack :: env *)
i_lambda input_type output_type body ; (* lambda :: env :: stack :: env *)
i_piar ; (* (env * lambda) :: stack :: env *)
i_pair ; (* new_stack :: env *)
] in
ok code
| _ -> simple_fail "expected function code"
)
| E_Cond (c, a, b) -> (
let%bind c' = translate_expression c in
@ -431,7 +430,9 @@ and translate_function_body ({body;result} as f:anon_function_content) : michels
let%bind body = translate_regular_block body in
let%bind expr = translate_expression result in
let code = seq [
i_comment "function body" ;
body ;
i_comment "function result" ;
i_push_unit ; expr ; i_car ;
dip i_drop ;
] in
@ -443,8 +444,10 @@ and translate_function_body ({body;result} as f:anon_function_content) : michels
let output_stack_ty = Stack.(output_ty @: nil) in
let error_message () =
Format.asprintf
"\ncode : %a\n"
"\ncode : %a\ninput : %a\noutput : %a\n"
Tezos_utils.Micheline.Michelson.pp code
PP.type_ f.input
PP.type_ f.output
in
let%bind _ =
Trace.trace_tzresult_lwt (

33
src/ligo/transpiler.ml
View File

@ -288,7 +288,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
ok (E_make_none o, tv, env)
| _ -> ok (E_constant (name, lst'), tv, env)
)
| E_lambda l -> translate_lambda env l tv
| E_lambda l -> translate_lambda env l
| E_list lst ->
let%bind t = Mini_c.Combinators.get_t_list tv in
let%bind lst' = bind_map_list (translate_annotated_expression env) lst in
@ -320,7 +320,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
simple_fail "only match bool exprs are translated yet"
)
and translate_lambda_shallow env l tv =
and translate_lambda_shallow env l =
let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in
(* Shallow capture. Capture the whole environment. Extend it with a new scope. Append it the input. *)
let%bind input = translate_type input_type in
@ -329,20 +329,20 @@ and translate_lambda_shallow env l tv =
let%bind (_, e) as body = translate_block full_env body in
let%bind result = translate_annotated_expression e.post_environment result in
let capture_type = Shallow_capture sub_env in
let input = Environment.to_mini_c_type full_env in
let input' = Environment.to_mini_c_type full_env in
let%bind output = translate_type output_type in
let content = {binder;input;output;body;result;capture_type} in
let tv =
let open Combinators in
let f = t_function input' output in
let env_type = Environment.to_mini_c_type env in
t_pair env_type f
in
let content = {binder;input=input';output;body;result;capture_type} in
ok (E_function content, tv, env)
and translate_lambda env l tv =
and translate_lambda env l =
let { binder ; input_type ; output_type ; body ; 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%bind init_env =
let%bind input = translate_type input_type in
ok Environment.(add (binder, input) env) in
let%bind empty_env =
let%bind input = translate_type input_type in
ok Environment.(add (binder, input) empty) in
let ((_body_bounds , body_fvs) , result_fvs) = AST.Free_variables.(
let bindings = singleton binder in
let ((body_bounds , _) as b) = block' bindings body in
@ -350,18 +350,22 @@ and translate_lambda env l tv =
) in
match (body_fvs, result_fvs) with
| [] , [] -> (
let%bind empty_env =
let%bind input = translate_type input_type in
ok Environment.(add (binder, input) empty) in
let%bind ((_, e) as body') = translate_block empty_env body in
let%bind result' = translate_annotated_expression e.post_environment result in
trace (simple_error "translate quote") @@
let capture_type = No_capture in
let%bind input = translate_type input_type in
let%bind output = translate_type output_type in
let tv = Combinators.t_function input output in
let content = {binder;input;output;body=body';result=result';capture_type} in
ok (E_literal (D_function {capture=None;content}), tv, env)
)
| _ -> (
trace (simple_error "translate lambda shallow") @@
translate_lambda_shallow init_env l tv
translate_lambda_shallow env l
)
let translate_declaration env (d:AST.declaration) : toplevel_statement result =
@ -380,9 +384,8 @@ let translate_program (lst:AST.program) : program result =
let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in
ok statements
let translate_main (l:AST.lambda) (t:AST.type_value) : anon_function result =
let%bind t' = translate_type t in
let%bind (expr, _, _) = translate_lambda Environment.empty l t' in
let translate_main (l:AST.lambda) (_t:AST.type_value) : anon_function result =
let%bind (expr, _, _) = translate_lambda Environment.empty l in
match expr with
| E_literal (D_function f) -> ok f
| _ -> simple_fail "main is not a function"