From 9ebd206494d82f156c92b689e4ed7db0e78e494e Mon Sep 17 00:00:00 2001 From: Galfour Date: Sat, 4 May 2019 16:36:24 +0000 Subject: [PATCH] tmp --- src/ligo/mini_c/PP.ml | 19 +--- src/ligo/mini_c/combinators.ml | 1 - src/ligo/mini_c/combinators_smart.ml | 3 +- src/ligo/mini_c/environment.ml | 124 +++------------------------ src/ligo/mini_c/types.ml | 18 +--- src/ligo/transpiler/transpiler.ml | 2 +- 6 files changed, 23 insertions(+), 144 deletions(-) diff --git a/src/ligo/mini_c/PP.ml b/src/ligo/mini_c/PP.ml index c20198de2..8523c423e 100644 --- a/src/ligo/mini_c/PP.ml +++ b/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 - let lst = to_list' e' in - 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 +and environment ppf (x:environment) = + fprintf ppf "Env[%a]" (list_sep_d environment_element) 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_restrict -> fprintf ppf "restrict" + | S_environment_load _ -> fprintf ppf "load env" | 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 diff --git a/src/ligo/mini_c/combinators.ml b/src/ligo/mini_c/combinators.ml index 0c8069fd4..fd7fee000 100644 --- a/src/ligo/mini_c/combinators.ml +++ b/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 ) diff --git a/src/ligo/mini_c/combinators_smart.ml b/src/ligo/mini_c/combinators_smart.ml index a95e12149..287981097 100644 --- a/src/ligo/mini_c/combinators_smart.ml +++ b/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_restrict -> s', environment_wrap env (Environment.restrict env) + | S_environment_load env' -> s', environment_wrap env 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 diff --git a/src/ligo/mini_c/environment.ml b/src/ligo/mini_c/environment.ml index 0171748fe..cb8067bdc 100644 --- a/src/ligo/mini_c/environment.ml +++ b/src/ligo/mini_c/environment.ml @@ -1,118 +1,20 @@ -open Trace +(* open Trace *) open Types -type element = environment_element +module type ENVIRONMENT = sig + type element = environment_element + type t = environment -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 + val empty : t + val add : element -> t -> t end -type t = environment +module Environment : ENVIRONMENT = struct + type element = environment_element + type t = environment -let empty : t = [Small.empty] -let extend t : t = Small.empty :: t -let restrict t : t = List.tl t -let of_small small : t = [small] + let empty = [] + let add = List.cons +end -let rec get_opt : t -> string -> type_value option = fun t k -> - match t with - | [] -> None - | 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 - | [] -> raise (Failure "Schema.Big.has") - | [hd] -> Small.has x hd - | 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 -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) - ) +include Environment diff --git a/src/ligo/mini_c/types.ml b/src/ligo/mini_c/types.ml index 172e2d7d2..6ad53d247 100644 --- a/src/ligo/mini_c/types.ml +++ b/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_shallow_closure of environment * 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_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_small = environment_element Append_tree.t - -and environment = environment_small list +and environment = environment_element 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_restrict + | S_environment_load of environment | 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_small (* Retrieves only the values it needs. Multiple SETs on init. Lighter 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. *) and block' = statement list diff --git a/src/ligo/transpiler/transpiler.ml b/src/ligo/transpiler/transpiler.ml index 5e9d31a02..ed8e1504a 100644 --- a/src/ligo/transpiler/transpiler.ml +++ b/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'))