From 79f2df2314f8fd89adfd8e924b1ca4e1fc8a4779 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Fri, 20 Mar 2020 11:54:31 +0100 Subject: [PATCH 1/4] optim for record --- src/passes/10-transpiler/transpiler.ml | 29 +++++++++++++++++++------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 6bb73efc0..2e167fdd9 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -474,14 +474,27 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = let expr = List.fold_left aux record' path in ok expr | E_record_update {record; path; update} -> - let%bind ty' = transpile_type (get_type_expression record) in - let%bind ty_lmap = - trace_strong (corner_case ~loc:__LOC__ "not a record") @@ - get_t_record (get_type_expression record) in - let%bind ty'_lmap = Ast_typed.Helpers.bind_map_lmap_t transpile_type ty_lmap in - let%bind path = - trace_strong (corner_case ~loc:__LOC__ "record access") @@ - record_access_to_lr ty' ty'_lmap path in + let rec aux res (r,p,up) = + let ty = get_type_expression r in + let%bind ty_lmap = + trace_strong (corner_case ~loc:__LOC__ "not a record") @@ + get_t_record (ty) in + let%bind ty' = transpile_type (ty) in + let%bind ty'_lmap = Ast_typed.Helpers.bind_map_lmap_t transpile_type ty_lmap in + let%bind p' = + trace_strong (corner_case ~loc:__LOC__ "record access") @@ + record_access_to_lr ty' ty'_lmap p in + let res' = res @ p' in + match (up:AST.expression).expression_content with + | AST.E_record_update {record=record'; path=path'; update=update'} -> ( + match record.expression_content with + | AST.E_record_accessor {record;path} when record = r && path = p -> + aux res' (record',path',update') + | _ -> ok @@ (up,res') + ) + | _ -> ok @@ (up,res') + in + let%bind (update, path) = aux [] (record, path, update) in let path = List.map snd path in let%bind update = transpile_annotated_expression update in let%bind record = transpile_annotated_expression record in From 1cbadbc7cfe6954818f58043580e4070239964cc Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Fri, 20 Mar 2020 14:28:20 +0100 Subject: [PATCH 2/4] add expression_eq in ast_typed --- src/bin/expect_tests/contract_tests.ml | 40 +++------- src/passes/10-transpiler/transpiler.ml | 8 +- src/stages/4-ast_typed/misc.ml | 102 +++++++++++++++++++++++++ src/stages/4-ast_typed/misc.mli | 1 + 4 files changed, 119 insertions(+), 32 deletions(-) diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index e49fd5ed5..af6a644d7 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -10,10 +10,10 @@ let%expect_test _ = [%expect {| 1874 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ; - [%expect {| 1189 bytes |}] ; + [%expect {| 1163 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "multisig-v2.ligo" ; "main" ] ; - [%expect {| 2897 bytes |}] ; + [%expect {| 2867 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "vote.mligo" ; "main" ] ; [%expect {| 617 bytes |}] ; @@ -388,36 +388,21 @@ let%expect_test _ = { DUP } ; DIP 5 { DUP } ; DIG 5 ; - DIP 6 { DUP } ; - DIG 6 ; - CAR ; - DIP 2 { DUP } ; - DIG 2 ; - CAR ; - SWAP ; - CDR ; - SWAP ; - PAIR ; - SWAP ; - CDR ; - SWAP ; - PAIR ; - DUP ; DIP { DUP } ; SWAP ; CAR ; - DIP 3 { DUP } ; - DIG 3 ; - CDR ; - SWAP ; - CAR ; + DIP { DUP ; CDR ; SWAP ; CAR ; CDR } ; PAIR ; + PAIR ; + DIP { DUP } ; SWAP ; CDR ; + DIP { DUP ; CDR ; SWAP ; CAR ; CAR } ; SWAP ; PAIR ; + PAIR ; CAR ; - DIP { DROP 7 } } ; + DIP { DROP 6 } } ; DUP ; CDR ; DIP { DIP 3 { DUP } ; DIG 3 ; CDR ; CDR } ; @@ -698,12 +683,9 @@ let%expect_test _ = { DIP { DUP } ; SWAP } ; DIP 3 { DUP } ; DIG 3 ; - DIP 4 { DUP } ; - DIG 4 ; - CAR ; - DIP 2 { DUP } ; - DIG 2 ; - DIP { DROP ; CDR } ; + CDR ; + DIP { DUP } ; + SWAP ; PAIR ; CAR ; DIP { DROP 4 } } ; diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 2e167fdd9..b66880e93 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -487,9 +487,11 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = let res' = res @ p' in match (up:AST.expression).expression_content with | AST.E_record_update {record=record'; path=path'; update=update'} -> ( - match record.expression_content with - | AST.E_record_accessor {record;path} when record = r && path = p -> - aux res' (record',path',update') + match record'.expression_content with + | AST.E_record_accessor {record;path} -> + if (AST.Misc.expression_eq record r && path = p) then + aux res' (record',path',update') + else ok @@ (up,res') | _ -> ok @@ (up,res') ) | _ -> ok @@ (up,res') diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 8612f2ece..e5b2322e4 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -527,3 +527,105 @@ let program_environment (program : program) : full_environment = let last_declaration = Location.unwrap List.(hd @@ rev program) in match last_declaration with | Declaration_constant { binder=_ ; expr=_ ; inline=_ ; post_env } -> post_env + +let rec expression_eq a b : bool = + match a.expression_content, b.expression_content with + | E_literal a, E_literal b -> literal_eq a b + | E_literal _, _ -> false + | E_constant {cons_name=ca;arguments=lsta}, E_constant {cons_name=cb;arguments=lstb} when ca == cb -> + let lst = List.combine lsta lstb in + let aux res (a,b) = res && expression_eq a b in + List.fold_left aux true lst + | E_constant _, _ -> false + | E_constructor {constructor=ca;element=ea}, E_constructor {constructor=cb;element=eb} when ca = cb -> + expression_eq ea eb + | E_constructor _, _ -> false + | E_variable a, E_variable b -> Var.equal a b + | E_variable _, _ -> false + | E_application {lamb=a;args=la}, E_application {lamb=b;args=lb} -> + expression_eq a b && expression_eq la lb + | E_application _, _ -> false + | E_lambda {binder=ba;result=ra}, E_lambda {binder=bb;result=rb} -> + Var.equal ba bb && expression_eq ra rb + | E_lambda _, _ -> false + | E_recursive {fun_name=na;fun_type=_;lambda={binder=ba;result=ra}}, + E_recursive {fun_name=nb;fun_type=_;lambda={binder=bb;result=rb}} -> + Var.equal na nb && Var.equal ba bb && expression_eq ra rb + | E_recursive _,_ -> false + | E_let_in {let_binder=na;rhs=ra;let_result=la;_}, E_let_in {let_binder=nb;rhs=rb;let_result=lb;_} -> + Var.equal na nb && expression_eq ra rb && expression_eq la lb + | E_let_in _,_ -> false + | E_record ra, E_record rb -> + let la = LMap.to_kv_list ra in + let lb = LMap.to_kv_list rb in + let lst = List.combine la lb in + let aux res ((Label ka,va),(Label kb,vb)) = + res && String.equal ka kb && expression_eq va vb + in + List.fold_left aux true lst + | E_record _,_ -> false + | E_record_accessor {record=ra;path=Label la}, E_record_accessor {record=rb;path=Label lb} -> + expression_eq ra rb && String.equal la lb + | E_record_accessor _, _ -> false + | E_record_update {record=ra;path=Label la;update=ua}, E_record_update {record=rb;path=Label lb; update=ub} -> + expression_eq ra rb && String.equal la lb && expression_eq ua ub + | E_record_update _, _ -> false + | E_matching {matchee=ma;cases=ca}, E_matching {matchee=mb;cases=cb} -> + expression_eq ma mb && matching_eq ca cb + | E_matching _, _ -> false + +and literal_eq la lb :bool = + match (la,lb) with + | Literal_bool a, Literal_bool b -> a = b + | Literal_bool _, _ -> false + | Literal_int a, Literal_int b -> a = b + | Literal_int _, _ -> false + | Literal_nat a, Literal_nat b -> a = b + | Literal_nat _, _ -> false + | Literal_timestamp a, Literal_timestamp b -> a = b + | Literal_timestamp _, _ -> false + | Literal_mutez a, Literal_mutez b -> a = b + | Literal_mutez _, _ -> false + | Literal_string a, Literal_string b -> a = b + | Literal_string _, _ -> false + | Literal_bytes a, Literal_bytes b -> a = b + | Literal_bytes _, _ -> false + | Literal_void, Literal_void -> true + | Literal_void, _ -> false + | Literal_unit, Literal_unit -> true + | Literal_unit, _ -> false + | Literal_address a, Literal_address b -> a = b + | Literal_address _, _ -> false + | Literal_signature a, Literal_signature b -> a = b + | Literal_signature _, _ -> false + | Literal_key a, Literal_key b -> a = b + | Literal_key _, _ -> false + | Literal_key_hash a, Literal_key_hash b -> a = b + | Literal_key_hash _, _ -> false + | Literal_chain_id a, Literal_chain_id b -> a = b + | Literal_chain_id _, _ -> false + | Literal_operation _, _ -> false + +and matching_eq ma mb : bool = + match (ma,mb) with + | Match_bool {match_true=ta;match_false=fa}, Match_bool {match_true=tb;match_false=fb} -> + expression_eq ta tb && expression_eq fa fb + | Match_bool _, _ -> false + | Match_option {match_some={opt=a;body=sa;_};match_none=na}, Match_option {match_some={opt=b;body=sb;_};match_none=nb} -> + Var.equal a b && expression_eq sa sb && expression_eq na nb + | Match_option _, _ -> false + | Match_list {match_nil=na;match_cons={hd=a;tl=aa;body=ca;_}}, Match_list {match_nil=nb;match_cons={hd=b;tl=bb;body=cb;_}} -> + expression_eq na nb && Var.equal a b && Var.equal aa bb && expression_eq ca cb + | Match_list _, _ -> false + | Match_tuple {vars=la;body=a;_}, Match_tuple {vars=lb;body=b;_} -> + let lst = List.combine la lb in + let aux res (a,b) = res && Var.equal a b in + List.fold_left aux (expression_eq a b) lst + | Match_tuple _, _ -> false + | Match_variant {cases=la;_}, Match_variant {cases=lb;_} -> + let lst = List.combine la lb in + let aux res ({constructor=Constructor ca;pattern=va;body=a}, {constructor=Constructor cb;pattern=vb;body=b}) = + res && String.equal ca cb && Var.equal va vb && expression_eq a b + in + List.fold_left aux true lst + | Match_variant _, _ -> false diff --git a/src/stages/4-ast_typed/misc.mli b/src/stages/4-ast_typed/misc.mli index 2a0a443fa..ed4813f1c 100644 --- a/src/stages/4-ast_typed/misc.mli +++ b/src/stages/4-ast_typed/misc.mli @@ -9,6 +9,7 @@ val merge_annotation : type_expression option -> type_expression option -> error (* No information about what made it fail *) val type_expression_eq : ( type_expression * type_expression ) -> bool +val expression_eq : expression -> expression -> bool module Free_variables : sig type bindings = expression_variable list From 2a8edb53da613d46e83f4f4c050cdfd633ec0beb Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Tue, 21 Apr 2020 18:01:46 +0200 Subject: [PATCH 3/4] reduce expression_eq to equal variable --- src/stages/4-ast_typed/misc.ml | 101 +-------------------------------- 1 file changed, 2 insertions(+), 99 deletions(-) diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index e5b2322e4..338178043 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -528,104 +528,7 @@ let program_environment (program : program) : full_environment = match last_declaration with | Declaration_constant { binder=_ ; expr=_ ; inline=_ ; post_env } -> post_env -let rec expression_eq a b : bool = +let expression_eq a b : bool = match a.expression_content, b.expression_content with - | E_literal a, E_literal b -> literal_eq a b - | E_literal _, _ -> false - | E_constant {cons_name=ca;arguments=lsta}, E_constant {cons_name=cb;arguments=lstb} when ca == cb -> - let lst = List.combine lsta lstb in - let aux res (a,b) = res && expression_eq a b in - List.fold_left aux true lst - | E_constant _, _ -> false - | E_constructor {constructor=ca;element=ea}, E_constructor {constructor=cb;element=eb} when ca = cb -> - expression_eq ea eb - | E_constructor _, _ -> false | E_variable a, E_variable b -> Var.equal a b - | E_variable _, _ -> false - | E_application {lamb=a;args=la}, E_application {lamb=b;args=lb} -> - expression_eq a b && expression_eq la lb - | E_application _, _ -> false - | E_lambda {binder=ba;result=ra}, E_lambda {binder=bb;result=rb} -> - Var.equal ba bb && expression_eq ra rb - | E_lambda _, _ -> false - | E_recursive {fun_name=na;fun_type=_;lambda={binder=ba;result=ra}}, - E_recursive {fun_name=nb;fun_type=_;lambda={binder=bb;result=rb}} -> - Var.equal na nb && Var.equal ba bb && expression_eq ra rb - | E_recursive _,_ -> false - | E_let_in {let_binder=na;rhs=ra;let_result=la;_}, E_let_in {let_binder=nb;rhs=rb;let_result=lb;_} -> - Var.equal na nb && expression_eq ra rb && expression_eq la lb - | E_let_in _,_ -> false - | E_record ra, E_record rb -> - let la = LMap.to_kv_list ra in - let lb = LMap.to_kv_list rb in - let lst = List.combine la lb in - let aux res ((Label ka,va),(Label kb,vb)) = - res && String.equal ka kb && expression_eq va vb - in - List.fold_left aux true lst - | E_record _,_ -> false - | E_record_accessor {record=ra;path=Label la}, E_record_accessor {record=rb;path=Label lb} -> - expression_eq ra rb && String.equal la lb - | E_record_accessor _, _ -> false - | E_record_update {record=ra;path=Label la;update=ua}, E_record_update {record=rb;path=Label lb; update=ub} -> - expression_eq ra rb && String.equal la lb && expression_eq ua ub - | E_record_update _, _ -> false - | E_matching {matchee=ma;cases=ca}, E_matching {matchee=mb;cases=cb} -> - expression_eq ma mb && matching_eq ca cb - | E_matching _, _ -> false - -and literal_eq la lb :bool = - match (la,lb) with - | Literal_bool a, Literal_bool b -> a = b - | Literal_bool _, _ -> false - | Literal_int a, Literal_int b -> a = b - | Literal_int _, _ -> false - | Literal_nat a, Literal_nat b -> a = b - | Literal_nat _, _ -> false - | Literal_timestamp a, Literal_timestamp b -> a = b - | Literal_timestamp _, _ -> false - | Literal_mutez a, Literal_mutez b -> a = b - | Literal_mutez _, _ -> false - | Literal_string a, Literal_string b -> a = b - | Literal_string _, _ -> false - | Literal_bytes a, Literal_bytes b -> a = b - | Literal_bytes _, _ -> false - | Literal_void, Literal_void -> true - | Literal_void, _ -> false - | Literal_unit, Literal_unit -> true - | Literal_unit, _ -> false - | Literal_address a, Literal_address b -> a = b - | Literal_address _, _ -> false - | Literal_signature a, Literal_signature b -> a = b - | Literal_signature _, _ -> false - | Literal_key a, Literal_key b -> a = b - | Literal_key _, _ -> false - | Literal_key_hash a, Literal_key_hash b -> a = b - | Literal_key_hash _, _ -> false - | Literal_chain_id a, Literal_chain_id b -> a = b - | Literal_chain_id _, _ -> false - | Literal_operation _, _ -> false - -and matching_eq ma mb : bool = - match (ma,mb) with - | Match_bool {match_true=ta;match_false=fa}, Match_bool {match_true=tb;match_false=fb} -> - expression_eq ta tb && expression_eq fa fb - | Match_bool _, _ -> false - | Match_option {match_some={opt=a;body=sa;_};match_none=na}, Match_option {match_some={opt=b;body=sb;_};match_none=nb} -> - Var.equal a b && expression_eq sa sb && expression_eq na nb - | Match_option _, _ -> false - | Match_list {match_nil=na;match_cons={hd=a;tl=aa;body=ca;_}}, Match_list {match_nil=nb;match_cons={hd=b;tl=bb;body=cb;_}} -> - expression_eq na nb && Var.equal a b && Var.equal aa bb && expression_eq ca cb - | Match_list _, _ -> false - | Match_tuple {vars=la;body=a;_}, Match_tuple {vars=lb;body=b;_} -> - let lst = List.combine la lb in - let aux res (a,b) = res && Var.equal a b in - List.fold_left aux (expression_eq a b) lst - | Match_tuple _, _ -> false - | Match_variant {cases=la;_}, Match_variant {cases=lb;_} -> - let lst = List.combine la lb in - let aux res ({constructor=Constructor ca;pattern=va;body=a}, {constructor=Constructor cb;pattern=vb;body=b}) = - res && String.equal ca cb && Var.equal va vb && expression_eq a b - in - List.fold_left aux true lst - | Match_variant _, _ -> false + | _, _ -> false From b47b5b1c37344e1c9565b8add7581a61f7354c36 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Wed, 22 Apr 2020 11:44:57 -0500 Subject: [PATCH 4/4] s/expression_eq/equal_variables/ to match the behavior --- src/passes/10-transpiler/transpiler.ml | 2 +- src/stages/4-ast_typed/misc.ml | 2 +- src/stages/4-ast_typed/misc.mli | 3 ++- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index b66880e93..37c005ef6 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -489,7 +489,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = | AST.E_record_update {record=record'; path=path'; update=update'} -> ( match record'.expression_content with | AST.E_record_accessor {record;path} -> - if (AST.Misc.expression_eq record r && path = p) then + if (AST.Misc.equal_variables record r && path = p) then aux res' (record',path',update') else ok @@ (up,res') | _ -> ok @@ (up,res') diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 338178043..95c1b9289 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -528,7 +528,7 @@ let program_environment (program : program) : full_environment = match last_declaration with | Declaration_constant { binder=_ ; expr=_ ; inline=_ ; post_env } -> post_env -let expression_eq a b : bool = +let equal_variables a b : bool = match a.expression_content, b.expression_content with | E_variable a, E_variable b -> Var.equal a b | _, _ -> false diff --git a/src/stages/4-ast_typed/misc.mli b/src/stages/4-ast_typed/misc.mli index ed4813f1c..924702ce8 100644 --- a/src/stages/4-ast_typed/misc.mli +++ b/src/stages/4-ast_typed/misc.mli @@ -9,7 +9,8 @@ val merge_annotation : type_expression option -> type_expression option -> error (* No information about what made it fail *) val type_expression_eq : ( type_expression * type_expression ) -> bool -val expression_eq : expression -> expression -> bool + +val equal_variables : expression -> expression -> bool module Free_variables : sig type bindings = expression_variable list