tmp

src/ligo/mini_c/PP.ml

@@ -28,25 +28,16 @@ let rec type_ ppf : type_value -> _ = function
   | T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_ k type_ v
   | T_list(t) -> fprintf ppf "list(%a)" type_ t
   | T_option(o) -> fprintf ppf "option(%a)" type_ o
-  | T_shallow_closure(_, a, b) -> fprintf ppf "[big_closure](%a) -> (%a)" type_ a type_ b
   | T_deep_closure(c, arg, ret) ->
       fprintf ppf "[%a](%a)->(%a)"
-        environment_small c
+        environment c
         type_ arg type_ ret
 
 and environment_element ppf ((s, tv) : environment_element) =
   Format.fprintf ppf "%s : %a" s type_ tv
 
-and environment_small' ppf e' = let open Append_tree in
+and environment ppf (x:environment) =
-  let lst = to_list' e' in
+  fprintf ppf "Env[%a]" (list_sep_d environment_element) x
-  fprintf ppf "S[%a]" (list_sep_d environment_element) lst
-
-and environment_small ppf e = let open Append_tree in
-  let lst = to_list e in
-  fprintf ppf "S[%a]" (list_sep_d environment_element) lst
-
-let environment ppf (x:environment) =
-  fprintf ppf "Env[%a]" (list_sep_d environment_small) x
 
 let rec value ppf : value -> unit = function
   | D_bool b -> fprintf ppf "%b" b
@@ -96,7 +87,6 @@ and function_ ppf ({binder ; input ; output ; body ; result ; capture_type}:anon
   fprintf ppf "fun[%s] (%s:%a) : %a %a return %a"
     (match capture_type with
      | No_capture -> "quote"
-     | Shallow_capture _ -> "shallow"
      | Deep_capture _ -> "deep")
     binder
     type_ input
@@ -109,8 +99,7 @@ and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e
 and declaration ppf ((n, e):assignment) = fprintf ppf "let %s = %a;" n expression e
 
 and statement ppf ((s, _) : statement) = match s with
-  | S_environment_extend -> fprintf ppf "extend"
+  | S_environment_load _ -> fprintf ppf "load env"
-  | S_environment_restrict -> fprintf ppf "restrict"
   | S_environment_add (name, tv) -> fprintf ppf "add %s %a" name type_ tv
   | S_declaration ass -> declaration ppf ass
   | S_assignment ass -> assignment ppf ass

src/ligo/mini_c/combinators.ml

@@ -118,7 +118,6 @@ 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_shallow_closure x y z : type_value = T_shallow_closure ( x , y , z )
 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 )

src/ligo/mini_c/combinators_smart.ml

@@ -8,8 +8,7 @@ let basic_int_quote_env : environment =
 
 let statement s' env : statement =
   match s' with
-  | S_environment_extend -> s', environment_wrap env (Environment.extend env)
+  | S_environment_load env' -> s', environment_wrap env env'
-  | S_environment_restrict -> s', environment_wrap env (Environment.restrict env)
   | S_environment_add (name, tv) -> s' , environment_wrap env (Environment.add (name , tv) env)
   | S_cond _ -> s' , id_environment_wrap env
   | S_do _ -> s' , id_environment_wrap env

src/ligo/mini_c/environment.ml

@@ -1,118 +1,20 @@
-open Trace
+(* open Trace *)
 open Types
 
+module type ENVIRONMENT = sig
   type element = environment_element
-
-module Small = struct
-  open Append_tree
-
-  type t' = environment_small'
-  type t = environment_small
-
-  let not_in_env' ?source s t' =
-    let title () = match source with
-      | None -> "Not in environment"
-      | Some source -> Format.asprintf "Not in environment' (%s)" source in
-    let content () =
-      Format.asprintf "Variable : %s, Environment' : %a"
-        s PP.environment_small' t' in
-    error title content
-
-  let not_in_env ?source s t =
-    let title () = match source with
-      | None -> "Not in environment"
-      | Some source -> Format.asprintf "Not in environment (%s)" source in
-    let content () =
-      Format.asprintf "Variable : %s, Environment : %a"
-        s PP.environment_small t in
-    error title content
-
-  let has' s = exists' (fun ((x, _):element) -> x = s)
-  let has s = function
-    | Empty -> false
-    | Full x -> has' s x
-
-  let empty : t = empty
-
-  let get_opt = assoc_opt
-
-  let append s (e:t) = if has (fst s) e then e else append s e
-
-  let of_list lst =
-    let rec aux = function
-      | [] -> Empty
-      | hd :: tl -> append hd (aux tl)
-    in
-    aux @@ List.rev lst
-
-
-  let rec to_list' (e:t') =
-    match e with
-    | Leaf x -> [x]
-    | Node {a;b} -> (to_list' a) @ (to_list' b)
-
-  let to_list (e:t) =
-    match e with
-    | Empty -> []
-    | Full x -> to_list' x
-
-  type bound = string list
-
-  let rec get_path' = fun s env' ->
-    match env' with
-    | Leaf (n, v) when n = s -> ok ([], v)
-    | Leaf _ -> fail @@ not_in_env' ~source:"get_path'" s env'
-    | Node {a;b} ->
-        match%bind bind_lr @@ Tezos_utils.Tuple.map2 (get_path' s) (a,b) with
-        | `Left (lst, v) -> ok ((`Left :: lst), v)
-        | `Right (lst, v) -> ok ((`Right :: lst), v)
-
-  let get_path = fun s env ->
-    match env with
-    | Empty -> fail @@ not_in_env ~source:"get_path" s env
-    | Full x -> get_path' s x
-end
-
   type t = environment
 
-let empty : t = [Small.empty]
+  val empty : t
-let extend t : t = Small.empty :: t
+  val add : element -> t -> t
-let restrict t : t = List.tl t
+end
-let of_small small : t = [small]
 
-let rec get_opt : t -> string -> type_value option = fun t k ->
+module Environment : ENVIRONMENT = struct
-  match t with
+  type element = environment_element
-  | [] -> None
+  type t = environment
-  | hd :: tl -> (
-      match Small.get_opt hd k with
-      | None -> get_opt tl k
-      | Some v -> Some v
-    )
 
-let rec has x : t -> bool = function
+  let empty = []
-  | [] -> raise (Failure "Schema.Big.has")
+  let add = List.cons
-  | [hd] -> Small.has x hd
+end
-  | hd :: tl -> Small.has x hd || has x tl
-let add x : t -> t = function
-  | [] -> raise (Failure "Schema.Big.add")
-  | hd :: tl -> Small.append x hd :: tl
 
-type path = [`Left | `Right] list
+include Environment
-let pp_path : _ -> path -> unit =
-  let open Format in
-  let aux ppf lr = match lr with
-    | `Left -> fprintf ppf "L"
-    | `Right -> fprintf ppf "R"
-  in
-  PP_helpers.(list_sep aux (const " "))
-
-let rec get_path : string -> environment -> ([`Left | `Right] list * type_value) result = fun s t ->
-  match t with
-  | [] -> simple_fail "Get path : empty big schema"
-  | [ x ] -> Small.get_path s x
-  | Empty :: tl -> get_path s tl
-  | hd :: tl -> (
-      match%bind bind_lr_lazy (Small.get_path s hd, (fun () -> get_path s tl)) with
-      | `Left (lst, v) -> ok (`Left :: lst, v)
-      | `Right (lst, v) -> ok (`Right :: lst, v)
-    )

src/ligo/mini_c/types.ml

@@ -1,5 +1,3 @@
-module Append_tree = Tree.Append
-
 type type_name = string
 
 type type_base =
@@ -13,21 +11,15 @@ type type_value =
   | T_pair of (type_value * type_value)
   | T_or of type_value * type_value
   | T_function of type_value * type_value
-  | T_deep_closure of environment_small * type_value * type_value
+  | T_deep_closure of environment * type_value * type_value
-  | T_shallow_closure of environment * type_value * type_value
   | T_base of type_base
   | T_map of (type_value * type_value)
   | T_list of type_value
   | T_option of type_value
 
-
 and environment_element = string * type_value
 
-and environment_small' = environment_element Append_tree.t'
+and environment = environment_element list
-
-and environment_small = environment_element Append_tree.t
-
-and environment = environment_small list
 
 type environment_wrap = {
   pre_environment : environment ;
@@ -79,8 +71,7 @@ and expression = {
 and assignment = var_name * expression
 
 and statement' =
-  | S_environment_extend
+  | S_environment_load of environment
-  | S_environment_restrict
   | S_environment_add of (var_name * type_value)
   | S_declaration of assignment (* First assignment *)
   | S_assignment of assignment
@@ -112,8 +103,7 @@ and anon_function_expression = anon_function_content
 
 and capture =
   | No_capture (* For functions that don't capture their environments. Quotes. *)
-  | Shallow_capture of environment (* Duplicates the whole environment. A single DUP. Heavier GETs and SETs at use. *)
+  | Deep_capture of environment (* Retrieves only the values it needs. Multiple SETs on init. Lighter GETs and SETs at use. *)
-  | Deep_capture of environment_small (* Retrieves only the values it needs. Multiple SETs on init. Lighter GETs and SETs at use. *)
 
 and block' = statement list
 

src/ligo/transpiler/transpiler.ml

@@ -358,7 +358,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
           let%bind n = translate_annotated_expression env match_none in
           let%bind (tv' , s') =
             let%bind tv' = translate_type tv in
-            let env' = Environment.(add (name , tv') @@ extend env) in
+            let env' = Environment.(add (name , tv') @@ env) in
             let%bind s' = translate_annotated_expression env' s in
             ok (tv' , s') in
           return @@ E_if_none (expr' , n , ((name , tv') , s'))