From eee6dbaeb21d7a6391552ac15c03ccd588750fd2 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Wed, 19 Feb 2020 14:18:06 +0100 Subject: [PATCH] make while_loop, for_int and for_collect more similar --- src/bin/expect_tests/contract_tests.ml | 115 +++++++++++-------------- src/passes/2-simplify/pascaligo.ml | 95 ++++++++++++-------- src/stages/common/PP.ml | 2 +- src/stages/mini_c/PP.ml | 2 +- 4 files changed, 112 insertions(+), 102 deletions(-) diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 2a3c4bd8d..b3ccd0aa0 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 {| 1747 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ; - [%expect {| 1358 bytes |}] ; + [%expect {| 1324 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "multisig-v2.ligo" ; "main" ] ; - [%expect {| 3294 bytes |}] ; + [%expect {| 3231 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "vote.mligo" ; "main" ] ; [%expect {| 642 bytes |}] ; @@ -371,17 +371,16 @@ let%expect_test _ = SWAP ; DIP { DROP 2 } } { PUSH string "Invalid signature" ; FAILWITH } ; - DIP { DROP ; DUP } ; - SWAP ; + DIP 2 { DUP } ; + DIG 2 ; DIP { DUP } ; SWAP ; - DIP { DROP 2 } } + DIP { DROP 3 } } { DUP } ; - DIP { DROP } ; - DIP 3 { DUP } ; - DIG 3 ; - DIP 3 { DUP } ; - DIG 3 ; + DIP 4 { DUP } ; + DIG 4 ; + DIP 4 { DUP } ; + DIG 4 ; SWAP ; CDR ; SWAP ; @@ -389,13 +388,12 @@ let%expect_test _ = CAR ; DIP { DUP } ; PAIR ; - DIP { DROP 3 } } + DIP { DROP 4 } } { DUP } ; - DIP { DROP } ; - DIP 4 { DUP } ; - DIG 4 ; DIP 5 { DUP } ; DIG 5 ; + DIP 6 { DUP } ; + DIG 6 ; CAR ; DIP 2 { DUP } ; DIG 2 ; @@ -423,7 +421,7 @@ let%expect_test _ = SWAP ; PAIR ; CAR ; - DIP { DROP 6 } } ; + DIP { DROP 7 } } ; DIP 3 { DUP } ; DIG 3 ; DIP { DUP } ; @@ -450,14 +448,12 @@ let%expect_test _ = DIP { DUP } ; SWAP ; DIP { DROP 2 } } ; - DIP { DROP } ; - DIP 2 { DUP } ; - DIG 2 ; + DIP 3 { DUP } ; + DIG 3 ; CAR ; DIP { DUP } ; PAIR ; - DIP { DROP 2 } } ; - DIP { DROP } ; + DIP { DROP 3 } } ; DUP ; CAR ; CAR ; @@ -465,7 +461,7 @@ let%expect_test _ = EXEC ; DIP { DUP ; CDR } ; PAIR ; - DIP { DROP 6 } } } |} ] + DIP { DROP 7 } } } |} ] let%expect_test _ = run_ligo_good [ "compile-contract" ; contract "multisig-v2.ligo" ; "main" ] ; @@ -589,14 +585,13 @@ let%expect_test _ = DIP { DUP } ; SWAP ; DIP { DROP 2 } } ; - DIP { DROP } ; - DIP 2 { DUP } ; - DIG 2 ; + DIP 3 { DUP } ; + DIG 3 ; CAR ; DIP { DUP } ; PAIR ; - DIP 2 { DUP } ; - DIG 2 ; + DIP 3 { DUP } ; + DIG 3 ; PUSH bool True ; SENDER ; UPDATE ; @@ -604,8 +599,7 @@ let%expect_test _ = CDR ; SWAP ; PAIR ; - DIP { DROP 2 } } ; - DIP { DROP } ; + DIP { DROP 3 } } ; DUP ; CAR ; DIP { DUP } ; @@ -624,11 +618,11 @@ let%expect_test _ = GT ; IF { PUSH string "Maximum number of proposal reached" ; FAILWITH } { PUSH unit Unit } ; - DIP 7 { DUP } ; - DIG 7 ; + DIP 8 { DUP } ; + DIG 8 ; DIP { DIP 3 { DUP } ; DIG 3 } ; PAIR ; - DIP { DIP 6 { DUP } ; DIG 6 ; NIL operation ; SWAP ; PAIR } ; + DIP { DIP 7 { DUP } ; DIG 7 ; NIL operation ; SWAP ; PAIR } ; PAIR ; DIP { DIP 2 { DUP } ; DIG 2 } ; PAIR ; @@ -640,8 +634,8 @@ let%expect_test _ = GE ; IF { DIP 3 { DUP } ; DIG 3 ; - DIP 8 { DUP } ; - DIG 8 ; + DIP 9 { DUP } ; + DIG 9 ; DIP { DIP 4 { DUP } ; DIG 4 ; CAR ; CDR ; CDR ; NONE (set address) } ; UPDATE ; DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ; @@ -654,7 +648,7 @@ let%expect_test _ = CDR ; CAR ; CDR ; - DIP { DIP 9 { DUP } ; DIG 9 } ; + DIP { DIP 10 { DUP } ; DIG 10 } ; EXEC ; DIP { DUP } ; SWAP ; @@ -663,7 +657,7 @@ let%expect_test _ = CDR ; CAR ; CDR ; - DIP { DIP 10 { DUP } ; DIG 10 } ; + DIP { DIP 11 { DUP } ; DIG 11 } ; CONCAT ; SHA256 ; DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CAR } ; @@ -724,11 +718,10 @@ let%expect_test _ = PAIR ; DIP { DROP } } { DUP } ; - DIP { DROP } ; - DIP 4 { DUP } ; - DIG 4 ; DIP 5 { DUP } ; DIG 5 ; + DIP 6 { DUP } ; + DIG 6 ; CAR ; DIP 2 { DUP } ; DIG 2 ; @@ -736,7 +729,7 @@ let%expect_test _ = DIP { DROP ; CDR } ; PAIR ; CAR ; - DIP { DROP 5 } } ; + DIP { DROP 6 } } ; DIP 4 { DUP } ; DIG 4 ; DIP 4 { DUP } ; @@ -764,8 +757,8 @@ let%expect_test _ = { DUP ; DIP 4 { DUP } ; DIG 4 ; - DIP 9 { DUP } ; - DIG 9 ; + DIP 10 { DUP } ; + DIG 10 ; DIP { DIP 6 { DUP } ; DIG 6 ; SOME ; @@ -780,14 +773,13 @@ let%expect_test _ = SWAP ; CAR ; PAIR } ; - DIP { DROP } ; DUP ; CAR ; CDR ; CDR ; DIP { DUP ; CDR } ; PAIR ; - DIP { DROP 13 } } ; + DIP { DROP 15 } } ; DIP { DROP } } { DUP ; DIP { DIP { DUP } ; SWAP } ; @@ -848,16 +840,15 @@ let%expect_test _ = SWAP ; DIP { DROP 2 } } { DUP } ; - DIP { DROP } ; DUP ; - DIP 2 { DUP } ; - DIG 2 ; - DIP { DIP 5 { DUP } ; DIG 5 } ; + DIP 3 { DUP } ; + DIG 3 ; + DIP { DIP 6 { DUP } ; DIG 6 } ; PAIR ; DIP { DUP } ; PAIR ; - DIP 3 { DUP } ; - DIG 3 ; + DIP 4 { DUP } ; + DIG 4 ; SIZE ; PUSH nat 0 ; SWAP ; @@ -865,8 +856,8 @@ let%expect_test _ = EQ ; IF { DIP { DUP } ; SWAP ; - DIP 7 { DUP } ; - DIG 7 ; + DIP 8 { DUP } ; + DIG 8 ; DIP { DIP 2 { DUP } ; DIG 2 ; CAR ; CDR ; CDR ; NONE (set address) } ; UPDATE ; DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ; @@ -884,10 +875,10 @@ let%expect_test _ = { DUP ; DIP 2 { DUP } ; DIG 2 ; - DIP 8 { DUP } ; - DIG 8 ; - DIP { DIP 5 { DUP } ; - DIG 5 ; + DIP 9 { DUP } ; + DIG 9 ; + DIP { DIP 6 { DUP } ; + DIG 6 ; SOME ; DIP { DIP 3 { DUP } ; DIG 3 ; CAR ; CDR ; CDR } } ; UPDATE ; @@ -900,11 +891,10 @@ let%expect_test _ = SWAP ; CAR ; PAIR } ; - DIP { DROP } ; - DIP 5 { DUP } ; - DIG 5 ; - DIP 2 { DUP } ; - DIG 2 ; + DIP 7 { DUP } ; + DIG 7 ; + DIP 3 { DUP } ; + DIG 3 ; SWAP ; CAR ; PAIR ; @@ -936,13 +926,12 @@ let%expect_test _ = SWAP ; CAR ; PAIR ; - DIP { DROP 5 } } ; - DIP { DROP } ; + DIP { DROP 7 } } ; DUP ; CDR ; NIL operation ; PAIR ; - DIP { DROP 5 } } ; + DIP { DROP 6 } } ; DIP { DROP 2 } } } |} ] let%expect_test _ = diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index fd979b5fa..a7ce6ea0e 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -14,7 +14,7 @@ let pseq_to_list = function | Some lst -> npseq_to_list lst let get_value : 'a Raw.reg -> 'a = fun x -> x.value -and repair_mutable_variable (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = +and repair_mutable_variable_in_matching (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = let%bind captured_names = Self_ast_simplified.fold_map_expression (* TODO : these should use Variables sets *) (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) -> @@ -46,7 +46,7 @@ and repair_mutable_variable (for_body : expression) (element_names : expression_ for_body in ok @@ captured_names -and repair_mutable_variable_for_collect (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = +and repair_mutable_variable_in_loops (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = let%bind captured_names = Self_ast_simplified.fold_map_expression (* TODO : these should use Variables sets *) (fun (decl_var,free_var : expression_variable list * expression_variable list) (ass_exp : expression) -> @@ -89,14 +89,14 @@ and store_mutable_variable (free_vars : expression_variable list) = let aux var = (Var.to_name var, e_variable var) in e_record_ez (List.map aux free_vars) -and restore_mutable_variable (expr : expression) (free_vars : expression_variable list) (env :expression_variable) = +and restore_mutable_variable (expr : expression->expression) (free_vars : expression_variable list) (env :expression_variable) = let aux (f:expression -> expression) (ev:expression_variable) = ok @@ fun expr -> f (e_let_in (ev,None) true false (e_accessor (e_variable env) (Var.to_name ev)) expr) in let%bind ef = bind_fold_list aux (fun e -> e) free_vars in ok @@ fun expr'_opt -> match expr'_opt with - | None -> ok @@ e_let_in (env,None) false false expr (ef (e_skip ())) - | Some expr' -> ok @@ e_let_in (env,None) false false expr (ef expr') + | None -> ok @@ expr (ef (e_skip ())) + | Some expr' -> ok @@ expr (ef expr') @@ -434,7 +434,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = let%bind match_false = simpl_expression c.ifnot in let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in let env = Var.fresh () in - let%bind (_, match_expr) = repair_mutable_variable match_expr [] env in + let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in return @@ match_expr | ECase c -> ( @@ -451,7 +451,7 @@ let rec simpl_expression (t:Raw.expr) : expr result = let%bind cases = simpl_cases lst in let match_expr = e_matching ~loc e cases in let env = Var.fresh () in - let%bind (_, match_expr) = repair_mutable_variable match_expr [] env in + let%bind (_, match_expr) = repair_mutable_variable_in_matching match_expr [] env in return @@ match_expr ) | EMap (MapInj mi) -> ( @@ -892,12 +892,16 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul let%bind match_true = match_true @@ Some (e_variable env) in let%bind match_false = match_false @@ Some (e_variable env) in - let%bind ((_,free_vars_true), match_true) = repair_mutable_variable match_true [] env in - let%bind ((_,free_vars_false), match_false) = repair_mutable_variable match_false [] env in + let%bind ((_,free_vars_true), match_true) = repair_mutable_variable_in_matching match_true [] env in + let%bind ((_,free_vars_false), match_false) = repair_mutable_variable_in_matching match_false [] env in let free_vars = free_vars_true @ free_vars_false in if (List.length free_vars != 0) then let match_expr = e_matching expr ~loc (Match_bool {match_true; match_false}) in - let return_expr = e_let_in (env,None) false false (store_mutable_variable free_vars) match_expr in + let return_expr = fun expr -> + e_let_in (env,None) false false (store_mutable_variable free_vars) @@ + e_let_in (env,None) false false match_expr @@ + expr + in restore_mutable_variable return_expr free_vars env else return_statement @@ e_matching expr ~loc (Match_bool {match_true=match_true'; match_false=match_false'}) @@ -945,7 +949,7 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul let%bind case_clause'= case_clause @@ None in let%bind case_clause = case_clause @@ Some(e_variable env) in let%bind case_vars = get_case_variables x.value.pattern in - let%bind ((_,free_vars), case_clause) = repair_mutable_variable case_clause case_vars env in + let%bind ((_,free_vars), case_clause) = repair_mutable_variable_in_matching case_clause case_vars env in ok (free_vars::fv,(x.value.pattern, case_clause, case_clause')) in bind_fold_map_list aux [] (npseq_to_list c.cases.value) in let free_vars = List.concat fv in @@ -957,7 +961,11 @@ and simpl_single_instruction : Raw.instruction -> (_ -> expression result) resul let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in let%bind m = simpl_cases cases in let match_expr = e_matching ~loc expr m in - let return_expr = e_let_in (env,None) false false (store_mutable_variable free_vars) match_expr in + let return_expr = fun expr -> + e_let_in (env,None) false false (store_mutable_variable free_vars) @@ + e_let_in (env,None) false false match_expr @@ + expr + in restore_mutable_variable return_expr free_vars env ) ) @@ -1180,26 +1188,32 @@ and simpl_while_loop : Raw.while_loop -> (_ -> expression result) result = fun w let binder = Var.fresh () in let%bind cond = simpl_expression wl.cond in - let%bind for_body = simpl_block wl.block.value in - let ctrl = (e_variable binder) - in + in + + let%bind for_body = simpl_block wl.block.value in let%bind for_body = for_body @@ Some( ctrl ) in - let%bind ((_,captured_name_list),for_body) = repair_mutable_variable for_body [] binder in + let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [] binder in let aux name expr= - e_let_in (name,None) false false (e_accessor (e_variable binder) (Var.to_name name)) expr + e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr in - let init_rec = store_mutable_variable @@ captured_name_list in + let init_rec = e_tuple [store_mutable_variable @@ captured_name_list] in let restore = fun expr -> List.fold_right aux captured_name_list expr in let continue_expr = e_constant C_CONTINUE [for_body] in let stop_expr = e_constant C_STOP [e_variable binder] in - let aux_func = e_cond cond continue_expr (stop_expr) in - let aux_func = (restore (aux_func)) in - let aux_func = e_lambda binder None None @@ aux_func in + let aux_func = + e_lambda binder None None @@ + restore @@ + e_cond cond continue_expr stop_expr in let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in - let return_expr = e_let_in (env_rec,None) false false init_rec (loop) in + let return_expr = fun expr -> + e_let_in (env_rec,None) false false init_rec @@ + e_let_in (env_rec,None) false false loop @@ + e_let_in (env_rec,None) false false (e_accessor (e_variable env_rec) "0") @@ + expr + in restore_mutable_variable return_expr captured_name_list env_rec @@ -1216,37 +1230,42 @@ and simpl_for_int : Raw.for_int -> (_ -> expression result) result = fun fi -> let step = e_int 1 in let ctrl = e_let_in (it,Some t_int) false false (e_constant C_ADD [ var ; step ]) - (e_let_in (binder, None) false false (e_update (e_variable binder) name var) + (e_let_in (binder, None) false false (e_update (e_variable binder) "1" var) (e_variable binder)) in (* Modify the body loop*) let%bind for_body = simpl_block fi.block.value in - let%bind for_body = for_body @@ Some( ctrl ) in - let%bind ((_,captured_name_list),for_body) = repair_mutable_variable for_body [it] binder in + let%bind for_body = for_body @@ Some ctrl in + let%bind ((_,captured_name_list),for_body) = repair_mutable_variable_in_loops for_body [it] binder in let aux name expr= - e_let_in (name,None) false false (e_accessor (e_variable binder) (Var.to_name name)) expr + e_let_in (name,None) false false (e_accessor (e_accessor (e_variable binder) "0") (Var.to_name name)) expr in (* restores the initial value of the free_var*) let restore = fun expr -> List.fold_right aux captured_name_list expr in (*Prep the lambda for the fold*) - let continue_expr = e_constant C_CONTINUE [for_body] in + let continue_expr = e_constant C_CONTINUE [restore(for_body)] in let stop_expr = e_constant C_STOP [e_variable binder] in - let aux_func = e_cond cond continue_expr (stop_expr) in - let aux_func = e_let_in (it,Some t_int) false false (e_accessor (e_variable binder) name) (restore (aux_func)) in - let aux_func = e_lambda binder None None @@ aux_func in + let aux_func = e_lambda binder None None @@ + e_let_in (it,Some t_int) false false (e_accessor (e_variable binder) "1") @@ + e_cond cond continue_expr (stop_expr) in (* Make the fold_while en precharge the vakye *) let loop = e_constant C_FOLD_WHILE [aux_func; e_variable env_rec] in - let init_rec = store_mutable_variable @@ it::captured_name_list in - let return_expr = e_let_in (env_rec,None) false false init_rec (loop) in - let return_expr = e_let_in (it, Some t_int) false false value @@ return_expr in + let init_rec = e_pair (store_mutable_variable @@ captured_name_list) var in + + let return_expr = fun expr -> + e_let_in (it, Some t_int) false false value @@ + e_let_in (env_rec,None) false false init_rec @@ + e_let_in (env_rec,None) false false loop @@ + e_let_in (env_rec,None) false false (e_accessor (e_variable env_rec) "0") @@ + expr + in restore_mutable_variable return_expr captured_name_list env_rec and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun fc -> - let _elt_name = fc.var.value in let binder = Var.of_name "arguments" in let%bind element_names = ok @@ match fc.bind_to with | Some v -> [Var.of_name fc.var.value;Var.of_name (snd v).value] @@ -1254,9 +1273,8 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun let env = Var.fresh () in let%bind for_body = simpl_block fc.block.value in - let%bind _for_body' = for_body None in let%bind for_body = for_body @@ Some (e_accessor (e_variable binder) "0") in - let%bind ((_,free_vars), for_body) = repair_mutable_variable_for_collect for_body element_names binder in + let%bind ((_,free_vars), for_body) = repair_mutable_variable_in_loops for_body element_names binder in let init_record = store_mutable_variable free_vars in let%bind collect = simpl_expression fc.expr in @@ -1275,7 +1293,10 @@ and simpl_for_collect : Raw.for_collect -> (_ -> expression result) result = fun let lambda = e_lambda binder None None (restore for_body) in let op_name = match fc.collection with | Map _ -> C_MAP_FOLD | Set _ -> C_SET_FOLD | List _ -> C_LIST_FOLD in - let fold = e_constant op_name [lambda; collect ; init_record] in + let fold = fun expr -> + e_let_in (env,None) false false (e_constant op_name [lambda; collect ; init_record]) @@ + expr + in restore_mutable_variable fold free_vars env and simpl_declaration_list declarations : diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index 7a943c603..a04d303a7 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -235,7 +235,7 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct | TC_key_hash -> "key_hash" | TC_signature -> - "signatuer" + "signature" | TC_timestamp -> "timestamp" | TC_chain_id -> diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index 626b6a23c..0fde6061c 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -44,7 +44,7 @@ and type_constant ppf (tc:type_constant) : unit = | TC_address -> "address" | TC_key -> "key" | TC_key_hash -> "key_hash" - | TC_signature -> "signatuer" + | TC_signature -> "signature" | TC_timestamp -> "timestamp" | TC_chain_id -> "chain_id" | TC_void -> "void"