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

it types now

Browse Source
This commit is contained in:
Galfour 2019-05-04 21:36:35 +00:00
parent 9ebd206494
commit 6e30690f2f
11 changed files with 407 additions and 700 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

279
src/ligo/compiler/compiler_environment.ml
View File

@ -1,221 +1,112 @@
open Trace
open Mini_c
open Environment
open Micheline
open Micheline.Michelson
open Memory_proto_alpha.Script_ir_translator
module Stack = Meta_michelson.Stack
type element = environment_element
module Small = struct
open Small
open Append_tree
open Michelson
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
let rec to_michelson_get' = fun s env' ->
match env' with
| Leaf (n, tv) when n = s -> ok @@ (seq [], tv)
| Leaf _ -> fail @@ not_in_env' ~source:"to_michelson_get'" s env'
| Node {a;b} -> (
match%bind bind_lr @@ Tezos_utils.Tuple.map2 (to_michelson_get' s) (a, b) with
| `Left (x, tv) -> ok @@ (seq [i_car ; x], tv)
| `Right (x, tv) -> ok @@ (seq [i_cdr ; x], tv)
)
let to_michelson_get s = function
| Empty -> simple_fail "Schema.Small.get : not in env"
| Full x -> to_michelson_get' s x
let rec to_michelson_set' = fun s env' ->
match env' with
| Leaf (n, tv) when n = s -> ok (dip i_drop, tv)
| Leaf _ -> fail @@ not_in_env' ~source:"Small.to_michelson_set'" s env'
| Node {a;b} -> (
match%bind bind_lr @@ Tezos_utils.Tuple.map2 (to_michelson_set' s) (a, b) with
| `Left (x, tv) -> ok (seq [dip i_unpair ; x ; i_pair], tv)
| `Right (x, tv) -> ok (seq [dip i_unpiar ; x ; i_piar], tv)
)
let to_michelson_set s = function
| Empty -> simple_fail "Schema.Small.set : not in env"
| Full x -> to_michelson_set' s x
let rec to_michelson_append' = function
| Leaf _ -> ok i_piar
| Node{full=true} -> ok i_piar
| Node{a=Node _;b;full=false} ->
let%bind b = to_michelson_append' b in
ok @@ seq [dip i_unpiar ; b ; i_piar]
| Node{a=Leaf _;full=false} -> assert false
let to_michelson_append = function
| Empty -> ok (dip i_drop)
| Full x -> to_michelson_append' x
let rec to_mini_c_type' : _ -> type_value = function
| Leaf (_, t) -> t
| Node {a;b} -> T_pair(to_mini_c_type' a, to_mini_c_type' b)
let to_mini_c_type : _ -> type_value = function
| Empty -> T_base Base_unit
| Full x -> to_mini_c_type' x
end
let to_michelson_extend : t -> Michelson.t = fun _e ->
Michelson.i_comment "empty_extend"
let to_michelson_restrict : t -> Michelson.t result = fun e ->
match e with
| [] -> simple_fail "Restrict empty env"
| Empty :: _ -> ok @@ Michelson.i_comment "restrict empty"
| _ -> ok @@ Michelson.(seq [i_comment "restrict" ; i_cdr])
let to_ty = Compiler_type.Ty.environment
let to_michelson_type = Compiler_type.environment
let rec to_mini_c_type = function
| [] -> raise (Failure "Schema.Big.to_mini_c_type")
| [hd] -> Small.to_mini_c_type hd
| Append_tree.Empty :: tl -> to_mini_c_type tl
| hd :: tl -> T_pair(Small.to_mini_c_type hd, to_mini_c_type 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"
let get : environment -> string -> michelson result = fun e s ->
let%bind (type_value , position) =
generic_try (simple_error "Environment.get") @@
(fun () -> Environment.get_i s e) in
let rec aux = fun n ->
match n with
| 0 -> i_dup
| n -> dip @@ seq [
aux (n - 1) ;
i_swap ;
]
in
PP_helpers.(list_sep aux (const " "))
let code = aux position in
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)
)
let path_to_michelson_get = fun path ->
let open Michelson in
let aux step = match step with
| `Left -> i_car
| `Right -> i_cdr in
seq (List.map aux path)
let path_to_michelson_set = fun path ->
let open Michelson in
let aux acc step = match step with
| `Left -> seq [dip i_unpair ; acc ; i_pair]
| `Right -> seq [dip i_unpiar ; acc ; i_piar]
in
let init = dip i_drop in
List.fold_right' aux init path
let to_michelson_anonymous_add (t:t) =
let%bind code = match t with
| [] -> simple_fail "Schema.Big.Add.to_michelson_add"
| [hd] ->
let%bind small = Small.to_michelson_append hd in
ok Michelson.(seq [i_comment "big.small add" ; small])
| Empty :: _ -> ok @@ Michelson.(seq [i_comment "empty_add" ; i_pair])
| hd :: _ -> (
let%bind code = Small.to_michelson_append hd in
ok @@ Michelson.(seq [i_comment "big add" ; dip i_unpair ; code ; i_pair])
)
in
ok code
let to_michelson_add x (t:t) =
let%bind code = to_michelson_anonymous_add t in
let%bind _assert_type =
let new_schema = add x t in
let%bind (Ex_ty schema_ty) = to_ty t in
let%bind (Ex_ty new_schema_ty) = to_ty new_schema in
let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ (snd x) in
let input_stack_ty = Stack.(input_ty @: schema_ty @: nil) in
let output_stack_ty = Stack.(new_schema_ty @: nil) in
let error_message () = Format.asprintf
"\nold : %a\nnew : %a\ncode : %a\n"
PP.environment t
PP.environment new_schema
Tezos_utils.Micheline.Michelson.pp code in
let%bind () =
let error () = ok @@ simple_error "error producing Env.get" in
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let output_stack_ty = Stack.(ty @: input_stack_ty) in
let%bind _ =
trace_tzresult_lwt (fun () -> error (thunk "error parsing Schema.Big.to_michelson_add code") error_message ()) @@
Tezos_utils.Memory_proto_alpha.parse_michelson code
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code
let to_michelson_get (s:t) str : (Michelson.t * type_value) result =
let%bind (path, tv) = get_path str s in
let code = path_to_michelson_get path in
let set : environment -> string -> michelson result = fun e s ->
let%bind (type_value , position) =
generic_try (simple_error "Environment.get") @@
(fun () -> Environment.get_i s e) in
let rec aux = fun n ->
match n with
| 0 -> dip i_drop
| n -> seq [
i_swap ;
dip (aux (n - 1)) ;
]
in
let code = aux position in
let%bind _assert_type =
let%bind (Ex_ty schema_ty) = to_ty s in
let%bind schema_michelson = to_michelson_type s in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ tv in
let input_stack_ty = Stack.(schema_ty @: nil) in
let output_stack_ty = Stack.(ty @: nil) in
let error_message () =
Format.asprintf
"\ncode : %a\nschema type : %a"
Tezos_utils.Micheline.Michelson.pp code
Tezos_utils.Micheline.Michelson.pp schema_michelson
in
let%bind () =
let error () = ok @@ simple_error "error producing Env.get" in
let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let input_stack_ty = Stack.(ty @: env_stack_ty) in
let output_stack_ty = env_stack_ty in
let%bind _ =
trace_tzresult_lwt (fun () -> error (thunk "error parsing big.get code") error_message ()) @@
Tezos_utils.Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty
in
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok (code, tv)
ok code
let to_michelson_set str (s:t) : Michelson.t result =
let%bind (path, tv) = get_path str s in
let code = path_to_michelson_set path in
let add : environment -> (string * type_value) -> michelson result = fun e (_s , type_value) ->
let code = seq [] in
let%bind _assert_type =
let%bind (Ex_ty schema_ty) = to_ty s in
let%bind schema_michelson = to_michelson_type s in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ tv in
let input_stack_ty = Stack.(ty @: schema_ty @: nil) in
let output_stack_ty = Stack.(schema_ty @: nil) in
let error_message () =
Format.asprintf
"\ncode : %a\nschema : %a\nschema type : %a\npath : %a"
Tezos_utils.Micheline.Michelson.pp code
PP.environment s
Tezos_utils.Micheline.Michelson.pp schema_michelson
pp_path path
in
let%bind () =
let error () = ok @@ simple_error "error producing Env.get" in
let%bind (Stack.Ex_stack_ty env_stack_ty) = Compiler_type.Ty.environment e in
let%bind (Ex_ty ty) = Compiler_type.Ty.type_ type_value in
let input_stack_ty = Stack.(ty @: env_stack_ty) in
let output_stack_ty = Stack.(ty @: env_stack_ty) in
let%bind _ =
Trace.trace_tzresult_lwt (fun () -> error (thunk "error parsing big.set code") error_message ()) @@
Tezos_utils.Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty
in
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok @@ Michelson.(seq [ i_comment "set" ; code ])
ok code
let select : environment -> string list -> michelson result = fun e lst ->
let code =
let aux = fun acc (s , _) ->
seq [
if List.mem s lst
then seq []
else i_drop ;
dip acc ;
]
in
Environment.fold aux (seq []) e in
let%bind () =
let error () = ok @@ simple_error "error producing Env.get" in
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment e in
let e' = Environment.filter (fun (s , _) -> List.mem s lst) e in
let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment e' in
let%bind _ =
Trace.trace_tzresult_lwt_r error @@
Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty in
ok ()
in
ok code
let select_env : environment -> environment -> michelson result = fun e e' ->
let lst = Environment.get_names e' in
select e lst

598
src/ligo/compiler/compiler_program.ml
View File

@ -71,47 +71,31 @@ let rec translate_value (v:value) : michelson result = match v with
let%bind lst' = bind_map_list translate_value lst in
ok @@ seq lst'
and translate_function ({capture;content}:anon_function) : michelson result =
let {capture_type } = content in
match capture, capture_type with
| _, No_capture ->
let%bind body = translate_quote_body content in
ok @@ seq [ body ]
| Some value, Deep_capture senv -> (
let senv_type = Compiler_environment.Small.to_mini_c_type senv in
let%bind body = translate_closure_body content senv_type in
let%bind capture_m = translate_value value in
ok @@ d_pair capture_m body
)
| Some value, Shallow_capture env ->
let env_type = Compiler_environment.to_mini_c_type env in
let%bind body = translate_closure_body content env_type in
let%bind capture_m = translate_value value in
ok @@ d_pair capture_m body
| _ -> simple_fail "compiling closure without capture"
and translate_function (content:anon_function) : michelson result =
let%bind body = translate_quote_body content in
ok @@ seq [ body ]
and translate_expression ?(first=false) (expr:expression) : michelson result =
let (expr' , ty , env) = Combinators.Expression.(get_content expr , get_type expr , get_environment expr) in
and translate_expression ?(first=false) (expr:expression) (env:environment) : (michelson * environment) result =
let (expr' , ty , _) = Combinators.Expression.(get_content expr , get_type expr , get_environment expr) in
let error_message () = Format.asprintf "%a" PP.expression expr in
let virtual_push_first = virtual_push first in
let virtual_push = virtual_push false in
let return code =
let%bind (Ex_ty schema_ty) = Compiler_environment.to_ty env in
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment env in
let%bind output_type = Compiler_type.type_ ty in
let%bind (Ex_ty output_ty) =
let error_message () = Format.asprintf "%a" Michelson.pp output_type in
Trace.trace_tzresult_lwt (fun () -> error (thunk "error parsing output ty") error_message ()) @@
Tezos_utils.Memory_proto_alpha.parse_michelson_ty output_type in
let input_stack_ty = Stack.(Contract_types.unit @: schema_ty @: nil) in
let output_stack_ty = Stack.(Contract_types.(pair output_ty unit) @: schema_ty @: nil) in
let output_stack_ty = Stack.(output_ty @: input_stack_ty) in
let error_message () =
let%bind schema_michelson = Compiler_environment.to_michelson_type env in
let%bind schema_michelsons = Compiler_type.environment env in
ok @@ Format.asprintf
"expression : %a\ncode : %a\nschema type : %a\noutput type : %a"
PP.expression expr
Michelson.pp code
Michelson.pp schema_michelson
PP_helpers.(list_sep Michelson.pp (const ".")) schema_michelsons
Michelson.pp output_type
in
let%bind _ =
@ -124,298 +108,187 @@ and translate_expression ?(first=false) (expr:expression) : michelson result =
Tezos_utils.Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty
in
ok code
let env' = Environment.add ("_tmp_expression" , ty) env in
ok (code , env')
in
let%bind (code : michelson) =
trace (error (thunk "compiling expression") error_message) @@
match expr' with
| E_literal v ->
let%bind v = translate_value v in
let%bind t = Compiler_type.type_ ty in
return @@ virtual_push_first @@ i_push t v
| E_application(f, arg) -> (
match Combinators.Expression.get_type f with
| T_function _ -> (
trace (simple_error "Compiling quote application") @@
let%bind f = translate_expression ~first f in
let%bind arg = translate_expression arg in
return @@ virtual_push @@ seq [
i_comment "quote application" ;
i_comment "get f" ;
f ;
i_comment "get arg" ;
arg ;
i_unpair ; dip i_unpair ;
prim I_EXEC ;
]
)
| T_deep_closure (_small_env, _, _) -> (
trace (simple_error "Compiling deep closure application") @@
let%bind f' = translate_expression ~first f in
let%bind arg' = translate_expression arg in
let error =
let error_title () = "michelson type-checking closure application" in
let error_content () =
Format.asprintf "Env : %a\nclosure : %a\narg : %a\n"
PP.environment env
PP.expression_with_type f
PP.expression_with_type arg
in
error error_title error_content
trace (error (thunk "compiling expression") error_message) @@
match expr' with
| E_capture_environment _c -> simple_fail "capture"
| E_literal v ->
let%bind v = translate_value v in
let%bind t = Compiler_type.type_ ty in
return @@ virtual_push_first @@ i_push t v
| E_application(f, arg) -> (
match Combinators.Expression.get_type f with
| T_function _ -> (
trace (simple_error "Compiling quote application") @@
let%bind (f , env') = translate_expression ~first f env in
let%bind (arg , _) = translate_expression arg env' in
return @@ virtual_push @@ seq [
i_comment "quote application" ;
i_comment "get f" ;
f ;
i_comment "get arg" ;
arg ;
i_unpair ; dip i_unpair ;
prim I_EXEC ;
]
)
| T_deep_closure (_small_env, _, _) -> (
trace (simple_error "Compiling deep closure application") @@
let%bind (f' , env') = translate_expression ~first f env in
let%bind (arg' , _) = translate_expression arg env' in
let error =
let error_title () = "michelson type-checking closure application" in
let error_content () =
Format.asprintf "Env : %a\nclosure : %a\narg : %a\n"
PP.environment env
PP.expression_with_type f
PP.expression_with_type arg
in
trace error @@
return @@ virtual_push @@ seq [
i_comment "(* unit :: env *)" ;
i_comment "compute arg" ;
arg' ; i_unpair ;
i_comment "(* (arg * unit) :: env *)" ;
i_comment "compute closure" ;
dip @@ seq [f' ; i_unpair ; i_unpair] ;
i_comment "(* arg :: capture :: f :: unit :: env *)" ;
i_pair ;
i_exec ; (* output :: stack :: env *)
]
)
| T_shallow_closure (_, _, _) -> (
trace (simple_error "Compiling shallow closure application") @@
let%bind f' = translate_expression ~first f in
let%bind arg' = translate_expression arg in
let error =
let error_title () = "michelson type-checking closure application" in
let error_content () =
Format.asprintf "Env : %a\nclosure : %a\narg : %a\n"
PP.environment env
PP.expression_with_type f
PP.expression_with_type arg
in
error error_title error_content
in
trace error @@
return @@ virtual_push @@ seq [
i_comment "(* unit :: env *)" ;
i_comment "compute arg" ;
arg' ; i_unpair ;
i_comment "(* (arg * unit) :: env *)" ;
i_comment "compute closure" ;
dip @@ seq [f' ; i_unpair ; i_unpair] ;
i_comment "(* arg :: capture :: f :: unit :: env *)" ;
i_pair ;
i_exec ; (* output :: stack :: env *)
]
)
| _ -> simple_fail "E_applicationing something not appliable"
)
| E_variable x ->
let%bind (get, _) = Compiler_environment.to_michelson_get env x in
return @@ virtual_push_first @@ seq [
dip (seq [i_dup ; get]) ;
i_swap ;
]
| E_constant(str, lst) ->
let%bind lst' =
let aux i e =
let first = first && i = 0 in
translate_expression ~first e in
bind_list @@ List.mapi aux lst in
let%bind predicate = get_predicate str ty lst in
let%bind code = match (predicate, List.length lst) with
| Constant c, 0 -> ok @@ virtual_push_first @@ seq @@ lst' @ [
c ;
]
| Unary f, 1 -> ok @@ virtual_push @@ seq @@ lst' @ [
i_unpair ;
f ;
]
| Binary f, 2 -> ok @@ virtual_push @@ seq @@ lst' @ [
i_unpair ;
dip i_unpair ;
i_swap ;
f ;
]
| Ternary f, 3 -> ok @@ virtual_push @@ seq @@ lst' @ [
i_unpair ;
dip i_unpair ;
dip (dip i_unpair) ;
i_swap ;
dip i_swap ;
i_swap ;
f ;
]
| _ -> simple_fail "bad arity"
error error_title error_content
in
trace error @@
return @@ virtual_push @@ seq [
i_comment "(* unit :: env *)" ;
i_comment "compute arg" ;
arg' ; i_unpair ;
i_comment "(* (arg * unit) :: env *)" ;
i_comment "compute closure" ;
dip @@ seq [f' ; i_unpair ; i_unpair] ;
i_comment "(* arg :: capture :: f :: unit :: env *)" ;
i_pair ;
i_exec ; (* output :: stack :: env *)
]
)
| _ -> simple_fail "E_applicationing something not appliable"
)
| E_variable x ->
let%bind code = Compiler_environment.get env x in
return @@ seq [
dip (seq [i_dup ; code]) ;
i_swap ;
]
| E_constant(str, lst) ->
let%bind lst' =
let aux env expr =
let%bind (code , env') = translate_expression ~first expr env in
ok (env' , code)
in
return code
| E_empty_map sd ->
let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
return @@ virtual_push_first @@ i_empty_map src dst
| E_empty_list t ->
let%bind t' = Compiler_type.type_ t in
return @@ virtual_push_first @@ i_nil t'
| E_make_none o ->
let%bind o' = Compiler_type.type_ o in
return @@ virtual_push_first @@ i_none o'
| E_function anon -> (
match anon.capture_type with
| No_capture ->
let%bind body = translate_quote_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 = virtual_push_first @@ i_lambda input_type output_type body in
return code
| Deep_capture small_env ->
(* Capture the sub environment. *)
let env_type = Compiler_environment.Small.to_mini_c_type small_env in
let%bind body = translate_closure_body anon env_type in
let%bind (_env , build_capture_code) =
let aux_leaf = fun prec (var_name , tv) ->
let%bind (small_env , code) = prec in
let small_env' = Environment.add (var_name , tv) small_env in
let%bind append_code = Compiler_environment.to_michelson_add (var_name , tv) small_env in
let%bind (get_code , _) = Compiler_environment.to_michelson_get env var_name in
let code' = seq [
code ;
i_comment ("deep closure get " ^ var_name) ;
dip (seq [ i_dup ; get_code ] ) ; i_swap ;
append_code ;
] in
ok (small_env' , code')
in
Append_tree.fold_s_ne (ok (Environment.empty , i_push_unit)) aux_leaf small_env
in
let%bind input_type =
let input_type = Combinators.t_pair anon.input env_type in
Compiler_type.type_ input_type in
let%bind output_type = Compiler_type.type_ anon.output in
let code = virtual_push_first @@ seq [ (* stack :: env *)
i_comment "env on top" ;
dip build_capture_code ; i_swap ; (* small_env :: stack :: env *)
i_comment "lambda" ;
i_lambda input_type output_type body ; (* lambda :: small_env :: stack :: env *)
i_comment "pair env + lambda" ;
i_piar ; (* (small_env * lambda) :: stack :: env *)
i_comment "new stack" ;
] in
let error =
let error_title () = "michelson type-checking trace" in
let error_content () =
Format.asprintf "Env : %a\n"
PP.environment_small small_env
in
error error_title error_content
in
trace error @@
return code
| Shallow_capture env ->
(* Capture the whole environment. *)
let env_type = Compiler_environment.to_mini_c_type env in
let%bind body = translate_closure_body anon env_type in
let%bind input_type =
let input_type = Combinators.t_pair anon.input env_type in
Compiler_type.type_ input_type in
let%bind output_type = Compiler_type.type_ anon.output in
let code = virtual_push_first @@ seq [ (* stack :: env *)
i_comment "env on top" ;
dip i_dup ; i_swap ; (* env :: stack :: env *)
i_comment "lambda" ;
i_lambda input_type output_type body ; (* lambda :: env :: stack :: env *)
i_comment "pair env + lambda" ;
i_piar ; (* (env * lambda) :: stack :: env *)
i_comment "new stack" ;
] in
let error =
let error_title () = "michelson type-checking trace" in
let error_content () =
Format.asprintf "Env : %a\n"
PP.environment env
in
error error_title error_content
in
trace error @@
return code
)
| E_Cond (c, a, b) -> (
let%bind c' = translate_expression c in
let%bind a' = translate_expression a in
let%bind b' = translate_expression b in
let%bind code = ok (seq [
c' ; i_unpair ;
i_if a' b' ;
]) in
return code
)
| E_if_none (c, n, (_ , s)) -> (
let%bind c' = translate_expression c in
let%bind n' = translate_expression n in
let%bind s' = translate_expression s in
let%bind restrict = Compiler_environment.to_michelson_restrict s.environment in
let%bind code = ok (seq [
c' ; i_unpair ;
i_if_none n' (seq [
i_pair ;
s' ;
restrict ;
])
;
]) in
return code
)
| E_if_left (c, (_ , l), (_ , r)) -> (
let%bind c' = translate_expression c in
let%bind l' = translate_expression l in
let%bind r' = translate_expression r in
let%bind restrict_l = Compiler_environment.to_michelson_restrict l.environment in
let%bind restrict_r = Compiler_environment.to_michelson_restrict r.environment in
let%bind code = ok (seq [
c' ; i_unpair ;
i_if_left (seq [
i_swap ; dip i_pair ;
l' ;
i_comment "restrict left" ;
dip restrict_l ;
]) (seq [
i_swap ; dip i_pair ;
r' ;
i_comment "restrict right" ;
dip restrict_r ;
])
;
]) in
return code
)
| E_let_in (_, expr , body) -> (
let%bind expr' = translate_expression expr in
let%bind body' = translate_expression body in
let%bind restrict = Compiler_environment.to_michelson_restrict body.environment in
let%bind code = ok (seq [
expr' ;
bind_fold_map_list aux env lst in
let%bind predicate = get_predicate str ty lst in
let%bind code = match (predicate, List.length lst) with
| Constant c, 0 -> ok @@ seq @@ lst' @ [
c ;
]
| Unary f, 1 -> ok @@ seq @@ lst' @ [
i_unpair ;
i_swap ; dip i_pair ;
body' ;
i_comment "restrict let" ;
dip restrict ;
]) in
return code
)
in
ok code
f ;
]
| Binary f, 2 -> ok @@ seq @@ lst' @ [
i_unpair ;
dip i_unpair ;
i_swap ;
f ;
]
| Ternary f, 3 -> ok @@ seq @@ lst' @ [
i_unpair ;
dip i_unpair ;
dip (dip i_unpair) ;
i_swap ;
dip i_swap ;
i_swap ;
f ;
]
| _ -> simple_fail "bad arity"
in
return code
| E_empty_map sd ->
let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
return @@ i_empty_map src dst
| E_empty_list t ->
let%bind t' = Compiler_type.type_ t in
return @@ i_nil t'
| E_make_none o ->
let%bind o' = Compiler_type.type_ o in
return @@ i_none o'
| E_Cond (c, a, b) -> (
let%bind (c' , env') = translate_expression c env in
let%bind (a' , _) = translate_expression a env' in
let%bind (b' , _) = translate_expression b env' in
let%bind code = ok (seq [
c' ; i_unpair ;
i_if a' b' ;
]) in
return code
)
| E_if_none (c, n, (_ , s)) -> (
let%bind (c' , env') = translate_expression c env in
let%bind (n' , _) = translate_expression n env' in
let%bind (s' , _) = translate_expression s env' in
let%bind code = ok (seq [
c' ; i_unpair ;
i_if_none n' (seq [
i_pair ;
s' ;
])
;
]) in
return code
)
| E_if_left (c, (_ , l), (_ , r)) -> (
let%bind (c' , env') = translate_expression c env in
let%bind (l' , _) = translate_expression l env' in
let%bind (r' , _) = translate_expression r env' in
let%bind restrict_l = Compiler_environment.select_env env l.environment in
let%bind restrict_r = Compiler_environment.select_env env r.environment in
let%bind code = ok (seq [
c' ; i_unpair ;
i_if_left (seq [
i_swap ; dip i_pair ;
l' ;
i_comment "restrict left" ;
dip restrict_l ;
]) (seq [
i_swap ; dip i_pair ;
r' ;
i_comment "restrict right" ;
dip restrict_r ;
])
;
]) in
return code
)
| E_let_in (_, expr , body) -> (
let%bind (expr' , _) = translate_expression expr env in
let%bind (body' , _) = translate_expression body env in
let%bind restrict = Compiler_environment.select_env env body.environment in
let%bind code = ok (seq [
expr' ;
i_unpair ;
i_swap ; dip i_pair ;
body' ;
i_comment "restrict let" ;
dip restrict ;
]) in
return code
)
and translate_statement ((s', w_env) as s:statement) : michelson result =
let error_message () = Format.asprintf "%a" PP.statement s in
let return code =
let%bind (Ex_ty pre_ty) = Compiler_environment.to_ty w_env.pre_environment in
let input_stack_ty = Stack.(pre_ty @: nil) in
let%bind (Ex_ty post_ty) = Compiler_environment.to_ty w_env.post_environment in
let output_stack_ty = Stack.(post_ty @: nil) in
let%bind (Stack.Ex_stack_ty input_stack_ty) = Compiler_type.Ty.environment w_env.pre_environment in
let%bind (Stack.Ex_stack_ty output_stack_ty) = Compiler_type.Ty.environment w_env.post_environment in
let error_message () =
let%bind pre_env_michelson = Compiler_environment.to_michelson_type w_env.pre_environment in
let%bind post_env_michelson = Compiler_environment.to_michelson_type w_env.post_environment in
let%bind pre_env_michelson = Compiler_type.environment w_env.pre_environment in
let%bind post_env_michelson = Compiler_type.environment w_env.post_environment in
ok @@ Format.asprintf
"statement : %a\ncode : %a\npre type : %a\npost type : %a\n"
PP.statement s
Michelson.pp code
Michelson.pp pre_env_michelson
Michelson.pp post_env_michelson
PP_helpers.(list_sep Michelson.pp (const " ; ")) pre_env_michelson
PP_helpers.(list_sep Michelson.pp (const " ; ")) post_env_michelson
in
let%bind _ =
Trace.trace_tzresult_lwt_r (fun () -> let%bind error_message = error_message () in
@ -429,19 +302,18 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
in
trace (fun () -> error (thunk "compiling statement") error_message ()) @@ match s' with
| S_environment_extend ->
return @@ Compiler_environment.to_michelson_extend w_env.pre_environment
| S_environment_restrict ->
let%bind code = Compiler_environment.to_michelson_restrict w_env.pre_environment in
return code
| S_environment_add _ ->
simple_fail "add not ready yet"
| S_environment_select _ ->
simple_fail "select not ready yet"
| S_environment_load _ ->
simple_fail "load not ready yet"
(* | S_environment_add (name, tv) ->
* Environment.to_michelson_add (name, tv) w_env.pre_environment *)
| S_declaration (s, expr) ->
let tv = Combinators.Expression.get_type expr in
let%bind expr = translate_expression expr in
let%bind add = Compiler_environment.to_michelson_add (s, tv) w_env.pre_environment in
let%bind (expr , _) = translate_expression expr w_env.pre_environment in
let%bind add = Compiler_environment.add w_env.pre_environment (s, tv) in
return @@ seq [
i_comment "declaration" ;
seq [
@ -454,8 +326,8 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
];
]
| S_assignment (s, expr) ->
let%bind expr = translate_expression expr in
let%bind set = Compiler_environment.to_michelson_set s w_env.pre_environment in
let%bind (expr , _) = translate_expression expr w_env.pre_environment in
let%bind set = Compiler_environment.set w_env.pre_environment s in
return @@ seq [
i_comment "assignment" ;
seq [
@ -468,7 +340,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
];
]
| S_cond (expr, a, b) ->
let%bind expr = translate_expression expr in
let%bind (expr , _) = translate_expression expr w_env.pre_environment in
let%bind a' = translate_regular_block a in
let%bind b' = translate_regular_block b in
return @@ seq [
@ -480,7 +352,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
| S_do expr -> (
match Combinators.Expression.get_content expr with
| E_constant ("FAILWITH" , [ fw ] ) -> (
let%bind fw' = translate_expression fw in
let%bind (fw' , _) = translate_expression fw w_env.pre_environment in
return @@ seq [
i_push_unit ;
fw' ;
@ -489,7 +361,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
]
)
| _ -> (
let%bind expr' = translate_expression expr in
let%bind (expr' , _) = translate_expression expr w_env.pre_environment in
return @@ seq [
i_push_unit ;
expr' ;
@ -498,12 +370,12 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
)
)
| S_if_none (expr, none, ((name, tv), some)) ->
let%bind expr = translate_expression expr in
let%bind (expr , _) = translate_expression expr w_env.pre_environment in
let%bind none' = translate_regular_block none in
let%bind some' = translate_regular_block some in
let%bind add =
let env' = Environment.extend w_env.pre_environment in
Compiler_environment.to_michelson_add (name, tv) env' in
let env' = w_env.pre_environment in
Compiler_environment.add env' (name, tv) in
return @@ seq [
i_push_unit ; expr ; i_car ;
prim ~children:[
@ -512,38 +384,45 @@ and translate_statement ((s', w_env) as s:statement) : michelson result =
] I_IF_NONE
]
| S_while (expr, block) ->
let%bind expr = translate_expression expr in
let%bind (expr , _) = translate_expression expr w_env.pre_environment in
let%bind block' = translate_regular_block block in
let%bind restrict_block =
let env_while = (snd block).pre_environment in
Compiler_environment.to_michelson_restrict env_while in
Compiler_environment.select_env (snd block).post_environment env_while in
return @@ seq [
i_push_unit ; expr ; i_car ;
prim ~children:[seq [
Compiler_environment.to_michelson_extend w_env.pre_environment;
block' ;
restrict_block ;
i_push_unit ; expr ; i_car]] I_LOOP ;
]
| S_patch (name, lrs, expr) ->
let%bind expr' = translate_expression expr in
let%bind (name_path, _) = Environment.get_path name w_env.pre_environment in
let path = name_path @ lrs in
let set_code = Compiler_environment.path_to_michelson_set path in
let%bind (expr' , _) = translate_expression expr w_env.pre_environment in
let%bind get_code = Compiler_environment.get w_env.pre_environment name in
let modify_code =
let aux acc step = match step with
| `Left -> seq [dip i_unpair ; acc ; i_pair]
| `Right -> seq [dip i_unpiar ; acc ; i_piar]
in
let init = dip i_drop in
List.fold_right' aux init lrs
in
let%bind set_code = Compiler_environment.set w_env.pre_environment name in
let error =
let title () = "michelson type-checking patch" in
let content () =
let aux ppf = function
| `Left -> Format.fprintf ppf "left"
| `Right -> Format.fprintf ppf "right" in
Format.asprintf "Name path: %a\nSub path: %a\n"
PP_helpers.(list_sep aux (const " , ")) name_path
Format.asprintf "Sub path: %a\n"
PP_helpers.(list_sep aux (const " , ")) lrs
in
error title content in
trace error @@
return @@ seq [
i_push_unit ; expr' ; i_car ;
expr' ;
get_code ;
modify_code ;
set_code ;
]
@ -555,10 +434,10 @@ and translate_regular_block ((b, env):block) : michelson result =
in
let%bind codes =
let error_message () =
let%bind schema_michelson = Compiler_environment.to_michelson_type env.pre_environment in
let%bind schema_michelsons = Compiler_type.environment env.pre_environment in
ok @@ Format.asprintf "\nblock : %a\nschema : %a\n"
PP.block (b, env)
Tezos_utils.Micheline.Michelson.pp schema_michelson
PP_helpers.(list_sep Michelson.pp (const " ; ")) schema_michelsons
in
trace_r (fun () ->
let%bind error_message = error_message () in
@ -569,14 +448,14 @@ and translate_regular_block ((b, env):block) : michelson result =
let code = seq (List.rev codes) in
ok code
and translate_quote_body ({body;result} as f:anon_function_content) : michelson result =
and translate_quote_body ({body;result} as f:anon_function) : michelson result =
let%bind body = translate_regular_block body in
let%bind expr = translate_expression result in
let%bind (expr , _) = translate_expression result Environment.empty in
let code = seq [
i_comment "function body" ;
body ;
i_comment "function result" ;
i_push_unit ; expr ; i_car ;
expr ;
dip i_drop ;
] in
@ -604,59 +483,16 @@ and translate_quote_body ({body;result} as f:anon_function_content) : michelson
ok code
and translate_closure_body ({body;result} as f:anon_function_content) (env_type:type_value) : michelson result =
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
let%bind _assert_type =
let input = Combinators.t_pair f.input env_type in
let output = f.output in
let%bind (Ex_ty input_ty) = Compiler_type.Ty.type_ input in
let%bind (Ex_ty output_ty) = Compiler_type.Ty.type_ output in
let input_stack_ty = Stack.(input_ty @: nil) in
let output_stack_ty = Stack.(output_ty @: nil) in
let body_env = (snd body).pre_environment in
let error_message () =
Format.asprintf
"\nmini_c code :%a\nmichelson code : %a\ninput : %a\noutput : %a\nenv : %a\n"
PP.function_ f
Tezos_utils.Micheline.Michelson.pp code
PP.type_ input
PP.type_ output
PP.environment body_env
in
let%bind _ =
Trace.trace_tzresult_lwt (
error (thunk "error parsing closure code") error_message
) @@
Tezos_utils.Memory_proto_alpha.parse_michelson code
input_stack_ty output_stack_ty
in
ok ()
in
ok code
type compiled_program = {
input : ex_ty ;
output : ex_ty ;
body : michelson ;
}
let get_main : program -> string -> anon_function_content result = fun p entry ->
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_function f , T_function _)
when f.capture_type = No_capture && name = entry ->
Some f
| (E_literal (D_function {content ; capture = None}) , T_function _)
| (E_literal (D_function content) , T_function _)
when name = entry ->
Some content
| _ -> None
@ -669,7 +505,7 @@ let get_main : program -> string -> anon_function_content result = fun p entry -
let translate_program (p:program) (entry:string) : compiled_program result =
let%bind main = get_main p entry in
let {input;output} : anon_function_content = main in
let {input;output} : anon_function = main in
let%bind body = translate_quote_body main in
let%bind input = Compiler_type.Ty.type_ input in
let%bind output = Compiler_type.Ty.type_ output in
@ -685,10 +521,10 @@ let translate_contract : program -> string -> michelson result = fun p e ->
ok contract
let translate_entry (p:anon_function) : compiled_program result =
let {input;output} : anon_function_content = p.content in
let {input;output} : anon_function = p in
let%bind body =
trace (simple_error "compile entry body") @@
translate_quote_body p.content in
translate_quote_body p in
let%bind input = Compiler_type.Ty.type_ input in
let%bind output = Compiler_type.Ty.type_ output in
ok ({input;output;body}:compiled_program)

72
src/ligo/compiler/compiler_type.ml
View File

@ -29,7 +29,6 @@ module Ty = struct
match tv with
| T_base b -> comparable_type_base b
| T_deep_closure _ -> fail (not_comparable "deep closure")
| T_shallow_closure _ -> fail (not_comparable "shallow closure")
| T_function _ -> fail (not_comparable "function")
| T_or _ -> fail (not_comparable "or")
| T_pair _ -> fail (not_comparable "pair")
@ -69,12 +68,7 @@ module Ty = struct
let%bind (Ex_ty ret) = type_ ret in
ok @@ Ex_ty (Contract_types.lambda arg ret)
| T_deep_closure (c, arg, ret) ->
let%bind (Ex_ty capture) = environment_small c in
let%bind (Ex_ty arg) = type_ arg in
let%bind (Ex_ty ret) = type_ ret in
ok @@ Ex_ty Contract_types.(pair capture @@ lambda (pair arg capture) ret)
| T_shallow_closure (c, arg, ret) ->
let%bind (Ex_ty capture) = environment c in
let%bind (Ex_ty capture) = environment_representation c in
let%bind (Ex_ty arg) = type_ arg in
let%bind (Ex_ty ret) = type_ ret in
ok @@ Ex_ty Contract_types.(pair capture @@ lambda (pair arg capture) ret)
@ -89,25 +83,24 @@ module Ty = struct
let%bind (Ex_ty t') = type_ t in
ok @@ Ex_ty Contract_types.(option t')
and environment_small' = let open Append_tree in function
| Leaf (_, x) -> type_ x
| Node {a;b} ->
let%bind (Ex_ty a) = environment_small' a in
let%bind (Ex_ty b) = environment_small' b in
ok @@ Ex_ty (Contract_types.pair a b)
and environment_small = function
| Empty -> ok @@ Ex_ty Contract_types.unit
| Full x -> environment_small' x
and environment = function
| [] | [Empty] -> ok @@ Ex_ty Contract_types.unit
| [a] -> environment_small a
| Empty :: b -> environment b
and environment_representation = function
| [] -> ok @@ Ex_ty Contract_types.unit
| [a] -> type_ @@ snd a
| a::b ->
let%bind (Ex_ty a) = environment_small a in
let%bind (Ex_ty b) = environment b in
let%bind (Ex_ty a) = type_ @@ snd a in
let%bind (Ex_ty b) = environment_representation b in
ok @@ Ex_ty (Contract_types.pair a b)
and environment : environment -> Meta_michelson.Stack.ex_stack_ty result = fun env ->
let open Meta_michelson in
let%bind lst =
bind_map_list type_
@@ List.map snd env in
let aux (Stack.Ex_stack_ty st) (Ex_ty cur) =
Stack.Ex_stack_ty (Stack.stack cur st)
in
ok @@ List.fold_right' aux (Ex_stack_ty Stack.nil) lst
end
@ -150,12 +143,7 @@ let rec type_ : type_value -> O.michelson result =
let%bind ret = type_ ret in
ok @@ O.prim ~children:[arg;ret] T_lambda
| T_deep_closure (c, arg, ret) ->
let%bind capture = environment_small c in
let%bind arg = type_ arg in
let%bind ret = type_ ret in
ok @@ O.t_pair capture (O.t_lambda (O.t_pair arg capture) ret)
| T_shallow_closure (c, arg, ret) ->
let%bind capture = environment c in
let%bind capture = environment_closure c in
let%bind arg = type_ arg in
let%bind ret = type_ ret in
ok @@ O.t_pair capture (O.t_lambda (O.t_pair arg capture) ret)
@ -164,23 +152,15 @@ and environment_element (name, tyv) =
let%bind michelson_type = type_ tyv in
ok @@ O.annotate ("@" ^ name) michelson_type
and environment_small' = let open Append_tree in function
| Leaf x -> environment_element x
| Node {a;b} ->
let%bind a = environment_small' a in
let%bind b = environment_small' b in
ok @@ O.t_pair a b
and environment = fun env ->
bind_map_list type_
@@ List.map snd env
and environment_small = function
| Empty -> ok @@ O.prim O.T_unit
| Full x -> environment_small' x
and environment =
and environment_closure =
function
| [] | [Empty] -> simple_fail "Type of empty env"
| [a] -> environment_small a
| Empty :: b -> environment b
| [] -> simple_fail "Type of empty env"
| [a] -> type_ @@ snd a
| a :: b ->
let%bind a = environment_small a in
let%bind b = environment b in
let%bind a = type_ @@ snd a in
let%bind b = environment_closure b in
ok @@ O.t_pair a b

8
src/ligo/main/main.ml
View File

@ -102,7 +102,7 @@ let easy_run_typed
trace (simple_error "transpile mini_c entry") @@
transpile_entry program entry in
(if debug_mini_c then
Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main.content)
Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
) ;
let%bind mini_c_value = transpile_value input in
@ -111,7 +111,7 @@ let easy_run_typed
let error =
let title () = "run Mini_c" in
let content () =
Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main.content
Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
in
error title content in
trace error @@
@ -132,7 +132,7 @@ let easy_run_typed_simplified
trace (simple_error "transpile mini_c entry") @@
transpile_entry program entry in
(if debug_mini_c then
Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main.content)
Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main)
) ;
let%bind typed_value =
@ -148,7 +148,7 @@ let easy_run_typed_simplified
let error =
let title () = "run Mini_c" in
let content () =
Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main.content
Format.asprintf "\n%a" Mini_c.PP.function_ mini_c_main
in
error title content in
trace error @@

2
src/ligo/main/run_mini_c.ml
View File

@ -34,7 +34,7 @@ let run_entry ?amount (entry:anon_function) (input:value) : value result =
let error =
let title () = "compile entry" in
let content () =
Format.asprintf "%a" PP.function_ entry.content
Format.asprintf "%a" PP.function_ entry
in
error title content in
trace error @@

12
src/ligo/mini_c/PP.ml
View File

@ -50,7 +50,7 @@ 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.content
| 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
@ -60,11 +60,11 @@ and value_assoc ppf : (value * value) -> unit = fun (a, b) ->
fprintf ppf "%a -> %a" value a value b
and expression' ppf (e:expression') = match e with
| E_capture_environment s -> fprintf ppf "capture(%a)" PP_helpers.(list_sep string (const " ; ")) s
| E_variable v -> fprintf ppf "%s" v
| E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b
| E_constant(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst
| E_literal v -> fprintf ppf "%a" value v
| E_function c -> function_ ppf c
| E_empty_map _ -> fprintf ppf "map[]"
| E_empty_list _ -> fprintf ppf "list[]"
| E_make_none _ -> fprintf ppf "none"
@ -83,11 +83,8 @@ and expression_with_type : _ -> expression -> _ = fun ppf e ->
expression' e.content
type_ e.type_value
and function_ ppf ({binder ; input ; output ; body ; result ; capture_type}:anon_function_content) =
fprintf ppf "fun[%s] (%s:%a) : %a %a return %a"
(match capture_type with
| No_capture -> "quote"
| Deep_capture _ -> "deep")
and function_ ppf ({binder ; input ; output ; body ; result}:anon_function) =
fprintf ppf "fun (%s:%a) : %a %a return %a"
binder
type_ input
type_ output
@ -100,6 +97,7 @@ and declaration ppf ((n, e):assignment) = fprintf ppf "let %s = %a;" n expressio
and statement ppf ((s, _) : statement) = match s with
| S_environment_load _ -> fprintf ppf "load env"
| S_environment_select _ -> fprintf ppf "select 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

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

@ -123,11 +123,10 @@ let t_pair x y : type_value = T_pair ( x , y )
let t_union x y : type_value = T_or ( x , y )
let quote binder input output body result : anon_function =
let content : anon_function_content = {
{
binder ; input ; output ;
body ; result ; capture_type = No_capture ;
} in
{ content ; capture = None }
body ; result ;
}
let basic_quote i o b : anon_function result =
let%bind (_, e) = get_last_statement b in

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

@ -8,7 +8,8 @@ let basic_int_quote_env : environment =
let statement s' env : statement =
match s' with
| S_environment_load env' -> s', environment_wrap env env'
| S_environment_load (_ , env') -> s', environment_wrap env env'
| S_environment_select 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

43
src/ligo/mini_c/environment.ml
View File

@ -1,20 +1,45 @@
(* open Trace *)
open Types
module type ENVIRONMENT = sig
(* module type ENVIRONMENT = sig
* type element = environment_element
* type t = environment
*
* val empty : t
* val add : element -> t -> t
* val concat : t list -> t
* val get_opt : string -> t -> type_value option
* val get_i : string -> t -> (type_value * int)
* val of_list : element list -> t
* val closure_representation : t -> type_value
* end *)
module Environment (* : ENVIRONMENT *) = struct
type element = environment_element
type t = environment
val empty : t
val add : element -> t -> t
end
let empty : t = []
let add : element -> t -> t = List.cons
let concat : t list -> t = List.concat
let get_opt : string -> t -> type_value option = List.assoc_opt
let has : string -> t -> bool = fun s t ->
match get_opt s t with
| None -> false
| Some _ -> true
let get_i : string -> t -> (type_value * int) = List.assoc_i
let of_list : element list -> t = fun x -> x
let to_list : t -> element list = fun x -> x
let get_names : t -> string list = List.map fst
module Environment : ENVIRONMENT = struct
type element = environment_element
type t = environment
let empty = []
let add = List.cons
let fold : _ -> 'a -> t -> 'a = List.fold_left
let filter : _ -> t -> t = List.filter
let closure_representation : t -> type_value = fun t ->
match t with
| [] -> T_base Base_unit
| [ a ] -> snd a
| hd :: tl -> List.fold_left (fun acc cur -> T_pair (acc , snd cur)) (snd hd) tl
end
include Environment

17
src/ligo/mini_c/types.ml
View File

@ -47,9 +47,11 @@ type value =
(* | `Macro of anon_macro ... The future. *)
| D_function of anon_function
and selector = var_name list
and expression' =
| E_literal of value
| E_function of anon_function_expression
| E_capture_environment of selector
| E_constant of string * expression list
| E_application of expression * expression
| E_variable of var_name
@ -71,7 +73,8 @@ and expression = {
and assignment = var_name * expression
and statement' =
| S_environment_load of environment
| S_environment_select of environment
| S_environment_load of (expression * environment)
| S_environment_add of (var_name * type_value)
| S_declaration of assignment (* First assignment *)
| S_assignment of assignment
@ -85,22 +88,14 @@ and statement = statement' * environment_wrap
and toplevel_statement = assignment * environment_wrap
and anon_function_content = {
and anon_function = {
binder : string ;
input : type_value ;
output : type_value ;
body : block ;
result : expression ;
capture_type : capture ;
}
and anon_function = {
content : anon_function_content ;
capture : value option ;
}
and anon_function_expression = anon_function_content
and capture =
| No_capture (* For functions that don't capture their environments. Quotes. *)
| Deep_capture of environment (* Retrieves only the values it needs. Multiple SETs on init. Lighter GETs and SETs at use. *)

66
src/ligo/transpiler/transpiler.ml
View File

@ -3,6 +3,7 @@ open Mini_c
open Combinators
module AST = Ast_typed
module Append_tree = Tree.Append
open AST.Combinators
let temp_unwrap_loc = Location.unwrap
@ -161,16 +162,15 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li
)
| I_matching (expr, m) -> (
let%bind expr' = translate_annotated_expression env expr in
let env' = Environment.extend env in
let extend s =
let pre = Combinators.statement S_environment_extend env in
ok [ pre ; (s, environment_wrap env env) ] in
let restrict : block -> block = fun b -> Combinators.append_statement' b S_environment_restrict in
let env' = env in
let return s =
ok [ (s, environment_wrap env env) ] in
let restrict : block -> block = fun b -> Combinators.append_statement' b (S_environment_select env) in
match m with
| Match_bool {match_true ; match_false} -> (
let%bind true_branch = translate_block env' match_true in
let%bind false_branch = translate_block env' match_false in
extend @@ S_cond (expr', restrict true_branch, restrict false_branch)
return @@ S_cond (expr', restrict true_branch, restrict false_branch)
)
| Match_option {match_none ; match_some = ((name, t), sm)} -> (
let%bind none_branch = translate_block env' match_none in
@ -179,14 +179,13 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li
let env'' = Environment.add (name, t') env' in
translate_block env'' sm
in
extend (S_if_none (expr', restrict none_branch, ((name, t'), restrict some_branch)))
return @@ S_if_none (expr', restrict none_branch, ((name, t'), restrict some_branch))
)
| _ -> simple_fail "todo : match"
)
| I_loop (expr, body) ->
let%bind expr' = translate_annotated_expression env expr in
let env' = Environment.extend env in
let%bind body' = translate_block env' body in
let%bind body' = translate_block env body in
return (S_while (expr', body'))
| I_skip -> ok []
| I_do ae -> (
@ -204,18 +203,18 @@ and translate_literal : AST.literal -> value = fun l -> match l with
| Literal_address s -> D_string s
| Literal_unit -> D_unit
and transpile_small_environment : AST.small_environment -> Environment.Small.t result = fun x ->
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' = translate_type ele.type_value in
ok @@ Environment.Small.append (name , tv') prec
ok @@ Environment.add (name , tv') prec
in
trace (simple_error "transpiling small environment") @@
bind_fold_right_list aux Append_tree.Empty x'
bind_fold_right_list aux Environment.empty x'
and transpile_environment : AST.full_environment -> Environment.t result = fun x ->
let%bind nlst = bind_map_ne_list transpile_small_environment x in
ok @@ List.Ne.to_list nlst
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
@ -236,7 +235,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
| E_variable name ->
let%bind tv =
trace_option (simple_error "transpiler: variable not in env") @@
Environment.get_opt env name in
Environment.get_opt name env in
return ~tv @@ E_variable name
| E_application (a, b) ->
let%bind a = translate_annotated_expression env a in
@ -391,7 +390,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
let%bind ((_ , name) , body) =
trace_option (simple_error "not supposed to happen here: missing match clause") @@
List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
let env' = Environment.(add (name , tv) @@ extend env) in
let env' = Environment.(add (name , tv) env) in
let%bind body' = translate_annotated_expression env' body in
return ~env @@ E_let_in ((name , tv) , top , body')
)
@ -399,14 +398,14 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
let%bind a' =
let%bind a_ty = get_t_left tv in
let a_var = "left" , a_ty in
let env' = Environment.(add a_var @@ extend env) in
let env' = Environment.(add a_var env) in
let%bind e = aux ((Some (Expression.make (E_variable "left") a_ty env')) , env') a in
ok (a_var , e)
in
let%bind b' =
let%bind b_ty = get_t_right tv in
let b_var = "right" , b_ty in
let env' = Environment.(add b_var @@ extend env) in
let env' = Environment.(add b_var env) in
let%bind e = aux ((Some (Expression.make (E_variable "right") b_ty env')) , env') b in
ok (b_var , e)
in
@ -418,27 +417,12 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
simple_fail "only match bool and option exprs are translated yet"
)
and translate_lambda_shallow : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun 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 env' = Environment.extend env in
let%bind input_type' = translate_type input_type in
let new_env = Environment.add (binder, input_type') env' in
let%bind (_, e) as body = translate_block new_env body in
let%bind result = translate_annotated_expression e.post_environment result in
let%bind output_type' = translate_type output_type in
let tv = Combinators.t_shallow_closure env input_type' output_type' in
let capture_type = Shallow_capture env' in
let content = {binder;input=input_type';output=output_type';body;result;capture_type} in
ok @@ Combinators.Expression.make_tpl (E_function content, tv, env)
and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.expression result = fun env l ->
let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in
(* Deep capture. Capture the relevant part of the environment. Extend it with a new scope. Append it the input. *)
let%bind input_type' = translate_type input_type in
let%bind small_env =
let env' = Environment.extend env in
let env' = env in
let new_env = Environment.add (binder, input_type') env' in
let free_variables = Ast_typed.Misc.Free_variables.lambda [] l in
let%bind elements =
@ -448,20 +432,19 @@ and translate_lambda_deep : Mini_c.Environment.t -> AST.lambda -> Mini_c.express
let content () = Format.asprintf "%s in %a" x Mini_c.PP.environment new_env in
error title content in
trace_option not_found_error @@
Environment.get_opt new_env x in
Environment.get_opt x new_env in
bind_map_list aux free_variables in
let kvs = List.combine free_variables elements in
let small_env = Environment.Small.of_list kvs in
let small_env = Environment.of_list kvs in
ok small_env
in
let new_env = Environment.(add (binder , input_type') @@ extend @@ of_small small_env) in
let new_env = Environment.(add (binder , input_type') small_env) in
let%bind (_, e) as body = translate_block new_env body in
let%bind result = translate_annotated_expression e.post_environment result in
let%bind output_type' = translate_type output_type in
let tv = Combinators.t_deep_closure small_env input_type' output_type' in
let capture_type = Deep_capture small_env in
let content = {binder;input=input_type';output=output_type';body;result;capture_type} in
ok @@ Combinators.Expression.make_tpl (E_function content, tv, env)
let content = D_function {binder;input=input_type';output=output_type';body;result} in
ok @@ Combinators.Expression.make_tpl (E_literal content, tv, env)
and translate_lambda env l =
let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in
@ -479,12 +462,11 @@ and translate_lambda env l =
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 @@ Combinators.Expression.make_tpl (E_literal (D_function {capture=None;content}), tv, env)
let content = D_function {binder;input;output;body=body';result=result'} in
ok @@ Combinators.Expression.make_tpl (E_literal content, tv, env)
)
| _ -> (
trace (simple_error "translate lambda deep") @@