Mini_c: Remove T_deep_closure and D_function

src/main/compile/of_mini_c.ml

@@ -25,7 +25,7 @@ let compile_expression_as_function : expression -> _ result = fun e ->
 let compile_function = fun e ->
   let%bind (input , output) = get_t_function e.type_value in
   let%bind body = get_function e in
-  let%bind body = compile_value body (t_function input output) in
+  let%bind body = Compiler.Program.translate_function_body body [] input in
   let body = Self_michelson.optimize body in
   let%bind (input , output) = bind_map_pair Compiler.Type.Ty.type_ (input , output) in
   let open! Compiler.Program in

src/passes/6-transpiler/transpiler.ml

@@ -228,36 +228,7 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
   | Literal_unit -> D_unit
 
 and transpile_environment_element_type : AST.environment_element -> type_value result = fun ele ->
-  match (AST.get_type' ele.type_value , ele.definition) with
+  transpile_type ele.type_value
-  | (AST.T_function (arg , ret) , ED_declaration (ae , ((_ :: _) as captured_variables)) ) ->
-  begin
-    match ae.expression with
-    | E_lambda _ ->
-      let%bind ret' = transpile_type ret 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
-      if sub_env = [] then
-        transpile_type ele.type_value
-      else
-        ok @@ Combinators.t_deep_closure sub_env arg' ret'
-    | _ -> transpile_type ele.type_value
-  end
-  | _ -> 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
-  let aux prec (name , (ele : AST.environment_element)) =
-    let%bind tv' = transpile_environment_element_type ele in
-    ok @@ Environment.add (name , tv') prec
-  in
-  let%bind result =
-    bind_fold_right_list aux Environment.empty x' in
-  ok result
-
-and transpile_environment : AST.full_environment -> Environment.t result = fun x ->
-  let%bind nlst = bind_map_ne_list transpile_small_environment x in
-  ok @@ Environment.concat @@ List.Ne.to_list nlst
 
 and tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t result = fun t ->
   let%bind map_tv = get_t_sum t in
@@ -435,11 +406,8 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         )
     )
   | E_lambda l ->
-    let%bind env =
-      trace_strong (corner_case ~loc:__LOC__ "environment") @@
-      transpile_environment ae.environment in
     let%bind io = AST.get_t_function ae.type_annotation in
-    transpile_lambda env l io
+    transpile_lambda l io
   | E_list lst -> (
       let%bind t =
         trace_strong (corner_case ~loc:__LOC__ "not a list") @@
@@ -610,40 +578,14 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
       | AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location
     )
 
-and transpile_lambda_deep : Mini_c.Environment.t -> AST.lambda -> _ -> Mini_c.expression result =
+and transpile_lambda l (input_type , output_type) =
-  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 result' = transpile_annotated_expression body in
-  let%bind c_env =
+  let%bind input = transpile_type input_type in
-    let free_variables = Ast_typed.Free_variables.lambda [] l in
+  let%bind output = transpile_type output_type in
-    let sub_env = Mini_c.Environment.select free_variables env in
+  let tv = Combinators.t_function input output in
-    ok sub_env in
+  let closure = E_closure { binder ; body = result'} in
-  let%bind (f_expr' , input_tv , output_tv) =
+  ok @@ Combinators.Expression.make_tpl (closure , tv)
-    let%bind raw_input = transpile_type input_type in
-    let%bind output = transpile_type output_type in
-    let%bind body = transpile_annotated_expression body in
-    let expr' = E_closure { binder ; body } in
-    ok (expr' , raw_input , output) in
-  let tv = Mini_c.t_deep_closure c_env input_tv output_tv in
-  ok @@ Expression.make_tpl (f_expr' , tv)
-
-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' = 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 ; body = result'} in
-        ok @@ Combinators.Expression.make_tpl (E_literal content , tv)
-      )
-    | _ -> (
-        transpile_lambda_deep env l (input_type , output_type)
-      ) in
-  ok result
 
 let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
   match d with
@@ -671,7 +613,6 @@ let check_storage f ty loc : (anon_function * _) result =
       | T_pair (a , b) -> (aux (snd a) true) && (aux (snd b) false)
       | T_or (a,b) -> (aux (snd a) false) && (aux (snd b) false)
       | T_function (a,b) -> (aux a false) && (aux b false)
-      | T_deep_closure (_,a,b) -> (aux a false) && (aux b false)
       | T_map (a,b) -> (aux a false) && (aux b false)
       | T_list a -> (aux a false)
       | T_set a -> (aux a false)

src/passes/6-transpiler/transpiler.mli

@@ -33,14 +33,11 @@ val tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [
 val record_access_to_lr : type_value -> type_value AST.type_name_map -> string -> (type_value * [`Left | `Right]) list result 
 val translate_literal : AST.literal -> value
 val transpile_environment_element_type : AST.environment_element -> type_value result
-val transpile_small_environment : AST.small_environment -> Environment.t result
-val transpile_environment : AST.full_environment -> Environment.t result
 val tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t result
 *)
 val transpile_annotated_expression : AST.annotated_expression -> expression result
 (*
-val transpile_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result
+val transpile_lambda : AST.lambda -> expression result
-val transpile_lambda : Environment.t -> AST.lambda -> expression result
 val transpile_declaration : environment -> AST.declaration -> toplevel_statement result
 *)
 

src/passes/7-self_mini_c/helpers.ml

@@ -11,8 +11,6 @@ let rec fold_type_value : ('a -> type_value -> 'a result) -> 'a -> type_value ->
   | T_map (a, b)
   | T_big_map (a, b) ->
      bind_fold_pair self init' (a, b)
-  | T_deep_closure (env, a, b) ->
-     bind_fold_list self init' (List.map snd env @ [a; b])
   | T_list a
   | T_set a
   | T_contract a
@@ -31,11 +29,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
   | E_make_empty_set _ -> (
     ok init'
   )
-  | E_literal v -> (
+  | E_literal _ -> ok init'
-    match v with
-    | D_function an -> self init' an.body
-    | _ -> ok init'
-  )
   | E_constant (_, lst) -> (
       let%bind res = bind_fold_list self init' lst in
       ok res
@@ -96,16 +90,8 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
   let%bind e' = f e in
   let return content = ok { e' with content } in
   match e'.content with
-  | E_variable _ | E_skip | E_make_none _
+  | E_variable _ | E_literal _ | E_skip | E_make_none _
   | E_make_empty_map (_,_) | E_make_empty_list _ | E_make_empty_set _ as em -> return em
-  | E_literal v -> (
-      let%bind v' = match v with
-      | D_function an ->
-        let%bind body = self an.body in
-        ok @@ D_function { an with body }
-      | _ -> ok v in
-      return @@ E_literal v'
-  )
   | E_constant (name, lst) -> (
       let%bind lst' = bind_map_list self lst in
       return @@ E_constant (name,lst')

src/passes/8-compiler/compiler_program.ml

@@ -86,11 +86,6 @@ let rec translate_value (v:value) ty : michelson result = match v with
       let%bind b' = translate_value b b_ty in
       ok @@ prim ~children:[b'] D_Right
     )
-  | D_function func -> (
-      match ty with
-      | T_function (in_ty , _) -> translate_function_body func [] in_ty
-      | _ -> simple_fail "expected function type"
-    )
   | D_none -> ok @@ prim D_None
   | D_some s ->
       let%bind s' = translate_value s ty in
@@ -143,19 +138,9 @@ and translate_expression (expr:expression) (env:environment) : michelson result
       return @@ i_push t v
   | E_closure anon -> (
       match ty with
-      | T_deep_closure (small_env , input_ty , output_ty) -> (
+      | T_function (input_ty , output_ty) ->
-          let selector = List.map fst small_env in
+        translate_function anon env input_ty output_ty
-          let%bind closure_pack_code = Compiler_environment.pack_closure env selector in
+      | _ -> simple_fail "expected function type"
-          let%bind lambda_ty = Compiler_type.lambda_closure (small_env , input_ty , output_ty) in
-          let%bind lambda_body_code = translate_function_body anon small_env input_ty in
-          return @@ seq [
-            closure_pack_code ;
-            i_push lambda_ty lambda_body_code ;
-            i_swap ;
-            i_apply ;
-          ]
-        )
-      | _ -> simple_fail "expected closure type"
     )
   | E_application (f , arg) -> (
       trace (simple_error "Compiling quote application") @@
@@ -407,6 +392,24 @@ and translate_function_body ({body ; binder} : anon_function) lst input : michel
 
   ok code
 
+and translate_function anon env input_ty output_ty : michelson result =
+  let fvs = Mini_c.Free_variables.lambda [] anon in
+  let small_env = Mini_c.Environment.select fvs env in
+  let%bind lambda_ty = Compiler_type.lambda_closure (small_env , input_ty , output_ty) in
+  let%bind lambda_body_code = translate_function_body anon small_env input_ty in
+  match fvs with
+  | [] -> ok @@ seq [ i_push lambda_ty lambda_body_code ]
+  | _ :: _ ->
+    let selector = List.map fst small_env in
+    let%bind closure_pack_code = Compiler_environment.pack_closure env selector in
+    ok @@ seq [
+      closure_pack_code ;
+      i_push lambda_ty lambda_body_code ;
+      i_swap ;
+      i_apply ;
+    ]
+
+
 type compiled_program = {
   input : ex_ty ;
   output : ex_ty ;
@@ -416,7 +419,7 @@ type compiled_program = {
 let get_main : program -> string -> (anon_function * _) result = fun p entry ->
   let is_main (((name , expr), _):toplevel_statement) =
     match Combinators.Expression.(get_content expr , get_type expr)with
-    | (E_literal (D_function content) , T_function ty)
+    | (E_closure content , T_function ty)
       when name = entry ->
         Some (content , ty)
     | _ ->  None

src/passes/8-compiler/compiler_type.ml

@@ -73,7 +73,6 @@ module Ty = struct
   let comparable_type : type_value -> ex_comparable_ty result = fun tv ->
     match tv with
     | T_base b -> comparable_type_base b
-    | T_deep_closure _ -> fail (not_comparable "deep closure")
     | T_function _ -> fail (not_comparable "function")
     | T_or _ -> fail (not_comparable "or")
     | T_pair _ -> fail (not_comparable "pair")
@@ -117,10 +116,6 @@ module Ty = struct
         let%bind (Ex_ty arg) = type_ arg in
         let%bind (Ex_ty ret) = type_ ret in
         ok @@ Ex_ty (lambda arg ret)
-    | T_deep_closure (_, arg, ret) ->
-        let%bind (Ex_ty arg) = type_ arg in
-        let%bind (Ex_ty ret) = type_ ret in
-        ok @@ Ex_ty (lambda arg ret)
     | T_map (k, v) ->
         let%bind (Ex_comparable_ty k') = comparable_type k in
         let%bind (Ex_ty v') = type_ v in
@@ -221,10 +216,6 @@ let rec type_ : type_value -> O.michelson result =
       let%bind arg = type_ arg in
       let%bind ret = type_ ret in
       ok @@ O.prim ~children:[arg;ret] T_lambda
-  | T_deep_closure (_ , arg , ret) ->
-      let%bind arg = type_ arg in
-      let%bind ret = type_ ret in
-      ok @@ O.prim ~children:[arg;ret] T_lambda
 
 and annotated : type_value annotated -> O.michelson result =
   function
@@ -242,10 +233,13 @@ and environment = fun env ->
   @@ List.map snd env
 
 and lambda_closure = fun (c , arg , ret) ->
-  let%bind capture = environment_closure c in
   let%bind arg = type_ arg in
   let%bind ret = type_ ret in
-  ok @@ O.t_lambda (O.t_pair capture arg) ret
+  match c with
+  | [] -> ok @@ O.t_lambda arg ret
+  | _ :: _ ->
+    let%bind capture = environment_closure c in
+    ok @@ O.t_lambda (O.t_pair capture arg) ret
 
 and environment_closure =
   function

src/stages/mini_c/PP.ml

@@ -33,10 +33,6 @@ let rec type_ ppf : type_value -> _ = function
   | T_set(t) -> fprintf ppf "set(%a)" type_ t
   | T_option(o) -> fprintf ppf "option(%a)" type_ o
   | T_contract(t) -> fprintf ppf "contract(%a)" type_ t
-  | T_deep_closure(c, arg, ret) ->
-      fprintf ppf "[%a](%a)->(%a)"
-        environment c
-        type_ arg type_ ret
 
 and annotated ppf : type_value annotated -> _ = function
   | (Some ann, a) -> fprintf ppf "(%a %%%s)" type_ a ann
@@ -63,7 +59,6 @@ let rec value ppf : value -> unit = function
   | D_pair (a, b) -> fprintf ppf "(%a), (%a)" value a value b
   | D_left a -> fprintf ppf "L(%a)" value a
   | D_right b -> fprintf ppf "R(%a)" value b
-  | D_function x -> function_ ppf x
   | D_none -> fprintf ppf "None"
   | D_some s -> fprintf ppf "Some (%a)" value s
   | D_map m -> fprintf ppf "Map[%a]" (list_sep_d value_assoc) m

src/stages/mini_c/combinators.ml

@@ -77,22 +77,18 @@ let get_set (v:value) = match v with
 
 let get_function_with_ty (e : expression) =
   match (e.content , e.type_value) with
-  | E_literal (D_function f) , T_function ty -> ok (f , ty)
+  | E_closure f , T_function ty -> ok (f , ty)
   | _ -> simple_fail "not a function with functional type"
 
 let get_function (e : expression) =
   match (e.content) with
-  | E_literal (D_function f) -> ok (D_function f)
+  | E_closure f -> ok f
   | _ -> simple_fail "not a function"
 
 let get_t_function tv = match tv with
   | T_function ty -> ok ty
   | _ -> simple_fail "not a function"
 
-let get_t_closure tv = match tv with
-  | T_deep_closure ty -> ok ty
-  | _ -> simple_fail "not a function"
-
 let get_t_option (v:type_value) = match v with
   | T_option t -> ok t
   | _ -> simple_fail "not an option"
@@ -169,7 +165,6 @@ let t_unit : type_value = T_base Base_unit
 let t_nat : type_value = T_base Base_nat
 
 let t_function x y : type_value = T_function ( x , y )
-let t_deep_closure x y z : type_value = T_deep_closure ( x , y , z )
 let t_pair x y : type_value = T_pair ( x , y )
 let t_union x y : type_value = T_or ( x , y )
 
@@ -194,7 +189,7 @@ let ez_e_sequence a b : expression = Expression.(make_tpl (E_sequence (make_tpl
 let d_unit : value = D_unit
 
 let basic_quote expr in_ty out_ty : expression result =
-  let expr' = E_literal (D_function (quote "input" expr)) in
+  let expr' = E_closure (quote "input" expr) in
   ok @@ Expression.make_tpl (expr' , t_function in_ty out_ty)
 
 let basic_int_quote expr : expression result =

src/stages/mini_c/combinators.mli

@@ -30,9 +30,8 @@ val get_big_map : value -> ( value * value ) list result
 val get_list : value -> value list result
 val get_set : value -> value list result
 val get_function_with_ty : expression -> ( anon_function * ( type_value * type_value) ) result
-val get_function : expression -> value  result
+val get_function : expression -> anon_function result
 val get_t_function : type_value -> ( type_value * type_value ) result
-val get_t_closure : type_value -> ( environment * type_value * type_value ) result
 val get_t_option : type_value -> type_value result
 val get_pair : value -> ( value * value ) result
 val get_t_pair : type_value -> ( type_value * type_value ) result
@@ -57,7 +56,6 @@ val t_int : type_value
 val t_unit : type_value 
 val t_nat : type_value 
 val t_function : type_value -> type_value -> type_value
-val t_deep_closure : environment -> type_value -> type_value -> type_value
 val t_pair : type_value annotated -> type_value annotated -> type_value
 val t_union : type_value annotated -> type_value annotated -> type_value
 (*

src/stages/mini_c/misc.ml

@@ -110,8 +110,6 @@ module Free_variables = struct
     | D_list xs
     | D_set xs
       -> unions @@ List.map self xs
-    | D_function f ->
-      lambda b f
 
   and lambda : bindings -> anon_function -> bindings = fun b l ->
     let b = union (singleton l.binder) b in
@@ -123,7 +121,7 @@ end
    Converts `expr` in `fun () -> expr`.
 *)
 let functionalize (body : expression) : expression =
-  let content = E_literal (D_function { binder = "_" ; body }) in
+  let content = E_closure { binder = "_" ; body } in
   let type_value = t_function t_unit body.type_value in
   { content ; type_value }
 
@@ -179,19 +177,14 @@ let aggregate_entry (lst : program) (name : string) (to_functionalize : bool) :
     fun expr -> List.fold_right' aux expr pre_declarations
   in
   match (entry_expression.content , to_functionalize) with
-  | (E_literal (D_function l) , false) -> (
-      let l' = { l with body = wrapper l.body } in
-      let e' = { entry_expression with content = E_literal (D_function l') } in
-      ok e'
-    )
   | (E_closure l , false) -> (
       let l' = { l with body = wrapper l.body } in
       let%bind t' =
-        let%bind (_ , input_ty , output_ty) = get_t_closure entry_expression.type_value in
+        let%bind (input_ty , output_ty) = get_t_function entry_expression.type_value in
         ok (t_function input_ty output_ty)
       in
       let e' = {
-        content = E_literal (D_function l') ;
+        content = E_closure l' ;
         type_value = t' ;
       } in
       ok e'

src/stages/mini_c/types.ml

@@ -14,7 +14,6 @@ type type_value =
   | T_pair of (type_value annotated * type_value annotated)
   | T_or of (type_value annotated * type_value annotated)
   | T_function of (type_value * type_value)
-  | T_deep_closure of (environment * type_value * type_value)
   | T_base of type_base
   | T_map of (type_value * type_value)
   | T_big_map of (type_value * type_value)
@@ -54,7 +53,6 @@ type value =
   | D_list of value list
   | D_set of value list
   (* | `Macro of anon_macro ... The future. *)
-  | D_function of anon_function
   | D_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
 
 and selector = var_name list