tmp

src/ligo/ast_typed.ml

@@ -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
 

src/ligo/mini_c/combinators.ml

@@ -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 ;

src/ligo/mini_c/compiler.ml

@@ -203,8 +203,8 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul
           ] in
         ok code
     | E_function anon -> (
-        match ty with
+        match anon.capture_type with
-        | T_function (_, _) ->
+        | 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 [
+            let code = seq [ (* stack :: env *)
-                dip i_dup ; i_swap ;
+                dip i_dup ; i_swap ; (* env :: stack :: env *)
-                i_lambda input_type output_type body ;
+                i_lambda input_type output_type body ; (* lambda :: env :: stack :: env *)
-                i_piar ;
+                i_piar ; (* (env * lambda) :: stack :: env *)
-                i_pair ;
+                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 (

src/ligo/transpiler.ml

@@ -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 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 in
-  let%bind (expr, _, _) = translate_lambda Environment.empty l t' in
   match expr with
   | E_literal (D_function f) -> ok f
   | _ -> simple_fail "main is not a function"