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

Merge branch 'feature/elim-dead-lambdas' into 'dev'

Browse Source 
Eliminate dead lambdas

See merge request ligolang/ligo!167
This commit is contained in:
Gabriel Alfour 2019-11-04 15:49:45 +00:00
commit 5e44be6baa
13 changed files with 175 additions and 145 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/main/compile/dune
View File

@ -12,6 +12,7 @@
ast_typed
transpiler
mini_c
self_mini_c
compiler
self_michelson
)

5
src/main/compile/of_mini_c.ml
View File

@ -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
@ -33,14 +33,17 @@ let compile_function = fun e ->
let compile_expression_as_function_entry = fun program name ->
let%bind aggregated = aggregate_entry program name true in
let%bind aggregated = Self_mini_c.all_expression aggregated in
compile_function aggregated
let compile_function_entry = fun program name ->
let%bind aggregated = aggregate_entry program name false in
let%bind aggregated = Self_mini_c.all_expression aggregated in
compile_function aggregated
let compile_contract_entry = fun program name ->
let%bind aggregated = aggregate_entry program name false in
let%bind aggregated = Self_mini_c.all_expression aggregated in
let%bind compiled = compile_function aggregated in
let%bind (param_ty , storage_ty) =
let%bind fun_ty = get_t_function aggregated.type_value in

67
src/passes/6-transpiler/transpiler.ml
View File

@ -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
| (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 =
fun env l (input_type , output_type)->
and transpile_lambda l (input_type , output_type) =
let { binder ; body } : AST.lambda = l in
(* Deep capture. Capture the relevant part of the environment. *)
let%bind c_env =
let free_variables = Ast_typed.Free_variables.lambda [] l in
let sub_env = Mini_c.Environment.select free_variables env in
ok sub_env in
let%bind (f_expr' , input_tv , output_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 closure = E_closure { binder ; body = result'} in
ok @@ Combinators.Expression.make_tpl (closure , tv)
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)

5
src/passes/6-transpiler/transpiler.mli
View File

@ -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 : Environment.t -> AST.lambda -> expression result
val transpile_lambda : AST.lambda -> expression result
val transpile_declaration : environment -> AST.declaration -> toplevel_statement result
*)

18
src/passes/7-self_mini_c/helpers.ml
View File

@ -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 -> (
match v with
| D_function an -> self init' an.body
| _ -> ok init'
)
| E_literal _ -> 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')

29
src/passes/7-self_mini_c/self_mini_c.ml Normal file
View File

@ -0,0 +1,29 @@
open Mini_c
open Trace
(* Overly conservative for now: ok to treat pure things as impure,
must not treat impure things as pure. *)
let is_pure : expression -> bool = fun e ->
match e.content with
| E_closure _ -> true
| _ -> false
let rec elim_dead_lambdas : expression -> expression result = fun e ->
let changed = ref false in (* ugh *)
let mapper : Helpers.mapper = fun e ->
match e.content with
| E_let_in ((x, _), e1, e2) when is_pure e1 ->
let fvs = Free_variables.expression [] e2 in
if Free_variables.mem x fvs
then ok e
else
(* pure e1 is not used, eliminate! *)
(changed := true ; ok e2)
| _ -> ok e in
let%bind e = Helpers.map_expression mapper e in
if !changed
then elim_dead_lambdas e
else ok e
let all_expression : expression -> expression result =
elim_dead_lambdas

41
src/passes/8-compiler/compiler_program.ml
View File

@ -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) -> (
let selector = List.map fst small_env in
let%bind closure_pack_code = Compiler_environment.pack_closure env selector 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
return @@ seq [
closure_pack_code ;
i_push lambda_ty lambda_body_code ;
i_swap ;
i_apply ;
]
)
| _ -> simple_fail "expected closure type"
| T_function (input_ty , output_ty) ->
translate_function anon env input_ty output_ty
| _ -> simple_fail "expected function 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

14
src/passes/8-compiler/compiler_type.ml
View File

@ -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,9 +233,12 @@ 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
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 =

5
src/stages/mini_c/PP.ml
View File

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

11
src/stages/mini_c/combinators.ml
View File

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

4
src/stages/mini_c/combinators.mli
View File

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

106
src/stages/mini_c/misc.ml
View File

@ -22,11 +22,106 @@ module Errors = struct
end
module Free_variables = struct
type bindings = string list
let mem : string -> bindings -> bool = List.mem
let singleton : string -> bindings = fun s -> [ s ]
let union : bindings -> bindings -> bindings = (@)
let unions : bindings list -> bindings = List.concat
let empty : bindings = []
let of_list : string list -> bindings = fun x -> x
let rec expression : bindings -> expression -> bindings = fun b e ->
let self = expression b in
match e.content with
| E_literal v -> value b v
| E_closure f -> lambda b f
| E_skip -> empty
| E_constant (_, xs) -> unions @@ List.map self xs
| E_application (f, x) -> unions @@ [ self f ; self x ]
| E_variable n -> var_name b n
| E_make_empty_map _ -> empty
| E_make_empty_list _ -> empty
| E_make_empty_set _ -> empty
| E_make_none _ -> empty
| E_iterator (_, ((v, _), body), expr) ->
unions [ expression (union (singleton v) b) body ;
self expr ;
]
| E_fold (((v, _), body), collection, initial) ->
unions [ expression (union (singleton v) b) body ;
self collection ;
self initial ;
]
| E_if_bool (x, bt, bf) -> unions [ self x ; self bt ; self bf ]
| E_if_none (x, bn, ((s, _), bs)) ->
unions [ self x ;
self bn ;
expression (union (singleton s) b) bs ;
]
| E_if_cons (x, bnil , (((h, _) , (t, _)) , bcons)) ->
unions [ self x ;
self bnil ;
expression (unions [ singleton h ; singleton t ; b ]) bcons ;
]
| E_if_left (x, ((l, _), bl), ((r, _), br)) ->
unions [ self x ;
expression (union (singleton l) b) bl ;
expression (union (singleton r) b) br ;
]
| E_let_in ((v , _) , expr , body) ->
unions [ self expr ;
expression (union (singleton v) b) body ;
]
| E_sequence (x, y) -> union (self x) (self y)
(* we do not consider the assigned variable free... seems strange,
but, matches ast_typed, and does not cause any troubles? *)
| E_assignment (_, _, e) -> self e
| E_while (cond , body) -> union (self cond) (self body)
and var_name : bindings -> var_name -> bindings = fun b n ->
if mem n b
then empty
else singleton n
and value : bindings -> value -> bindings = fun b v ->
let self = value b in
match v with
| D_unit
| D_bool _
| D_nat _
| D_timestamp _
| D_mutez _
| D_int _
| D_string _
| D_bytes _
| D_none
| D_operation _
-> empty
| D_pair (x, y) -> unions [ self x ; self y ]
| D_left x
| D_right x
| D_some x
-> self x
| D_map kvs
| D_big_map kvs
-> unions @@ List.map (fun (k, v) -> unions [ self k ; self v ]) kvs
| D_list xs
| D_set xs
-> unions @@ List.map self xs
and lambda : bindings -> anon_function -> bindings = fun b l ->
let b = union (singleton l.binder) b in
expression b l.body
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 }
@ -82,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'

2
src/stages/mini_c/types.ml
View File

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