From e262f9e103ba09dc4f36785da136317eda0f606a Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Wed, 4 Dec 2019 13:34:20 -0600 Subject: [PATCH 1/4] Demonstrate a couple simple_for_collect bugs --- src/test/contracts/loop_bugs.ligo | 20 ++++++++++++++++++++ src/test/integration_tests.ml | 12 ++++++++++++ 2 files changed, 32 insertions(+) create mode 100644 src/test/contracts/loop_bugs.ligo diff --git a/src/test/contracts/loop_bugs.ligo b/src/test/contracts/loop_bugs.ligo new file mode 100644 index 000000000..1a18a6758 --- /dev/null +++ b/src/test/contracts/loop_bugs.ligo @@ -0,0 +1,20 @@ +function shadowing_in_body (var nee : unit) : string is block { + var st : string := ""; + var list1 : list(string) := list "to"; "to" end; + for x in list list1 block { + const x : string = "ta"; + st := st ^ x; + } +} with st +(* should be "tata" *) + +function shadowing_assigned_in_body (var nee : unit) : string is block { + var st : string := ""; + var list1 : list(string) := list "to"; "to" end; + for x in list list1 block { + st := st ^ x; + var st : string := "ta"; + st := st ^ x; + } +} with st +(* should be "toto" ??? *) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index f79d3e8e3..6238fb836 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -2253,6 +2253,17 @@ let no_semicolon_religo () : unit result = in ok () +let loop_bugs_ligo () : unit result = + let%bind program = type_file "./contracts/loop_bugs.ligo" in + let input = e_unit () in + let%bind () = + let expected = e_string "tata" in + expect_eq program "shadowing_in_body" input expected in + let%bind () = + let expected = e_string "toto" in + expect_eq program "shadowing_assigned_in_body" input expected in + ok () + let main = test_suite "Integration (End to End)" [ test "bytes unpack" bytes_unpack ; test "bytes unpack (mligo)" bytes_unpack_mligo ; @@ -2421,4 +2432,5 @@ let main = test_suite "Integration (End to End)" [ test "tuple type (mligo)" tuple_type_mligo ; test "tuple type (religo)" tuple_type_religo ; test "no semicolon (religo)" no_semicolon_religo ; + test "loop_bugs (ligo)" loop_bugs_ligo ; ] From c468cb94a141e748390354249fe2b2abe8eca208 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Tue, 18 Feb 2020 14:14:39 +0100 Subject: [PATCH 2/4] remove unused code --- src/passes/2-simplify/pascaligo.ml | 49 ------------------------------ 1 file changed, 49 deletions(-) diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index 901bf7818..0a550b917 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -3,7 +3,6 @@ open Ast_simplified module Raw = Parser.Pascaligo.AST module SMap = Map.String -module SSet = Set.Make (String) module ParserLog = Parser_pascaligo.ParserLog open Combinators @@ -14,54 +13,6 @@ let pseq_to_list = function None -> [] | Some lst -> npseq_to_list lst let get_value : 'a Raw.reg -> 'a = fun x -> x.value -let is_compiler_generated name = String.contains (Var.to_name name) '#' - -let _detect_local_declarations (for_body : expression) = - let%bind aux = Self_ast_simplified.fold_expression - (fun (nlist, cur_loop : expression_variable list * bool) (ass_exp : expression) -> - if cur_loop then - match ass_exp.expression_content with - | E_let_in {let_binder;mut=false;rhs = _;let_result = _} -> - let (name,_) = let_binder in - ok (name::nlist, cur_loop) - | E_constant {cons_name=C_MAP_FOLD;arguments= _} - | E_constant {cons_name=C_SET_FOLD;arguments= _} - | E_constant {cons_name=C_LIST_FOLD;arguments= _} -> ok @@ (nlist, false) - | _ -> ok (nlist, cur_loop) - else - ok @@ (nlist, cur_loop) - ) - ([], true) - for_body in - ok @@ fst aux - -let _detect_free_variables (for_body : expression) (local_decl_names : expression_variable list) = - let%bind captured_names = Self_ast_simplified.fold_expression - (fun (prev : expression_variable list) (ass_exp : expression) -> - match ass_exp.expression_content with - | E_constant {cons_name=n;arguments=[a;b]} - when n=C_OR || n=C_AND || n=C_LT || n=C_GT || - n=C_LE || n=C_GE || n=C_EQ || n=C_NEQ -> ( - match (a.expression_content,b.expression_content) with - | E_variable na , E_variable nb -> - let ret = [] in - let ret = if not (is_compiler_generated na) then - na::ret else ret in - let ret = if not (is_compiler_generated nb) then - nb::ret else ret in - ok (ret@prev) - | E_variable n , _ - | _ , E_variable n -> - if not (is_compiler_generated n) then - ok (n::prev) else ok prev - | _ -> ok prev) - | _ -> ok prev ) - [] - for_body in - let captured_names = List.map (fun (s) -> Var.to_name s) captured_names in - let local_decl_names = List.map (fun (s) -> Var.to_name s) local_decl_names in - ok @@ SSet.elements - @@ SSet.diff (SSet.of_list captured_names) (SSet.of_list local_decl_names) and repair_mutable_variable (for_body : expression) (element_names : expression_variable list) (env : expression_variable) = let%bind captured_names = Self_ast_simplified.fold_map_expression From 9de45285b27290e566e0c2ba134289ce8cf0b2a6 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Tue, 18 Feb 2020 14:19:11 +0100 Subject: [PATCH 3/4] remove Var.show --- src/passes/2-simplify/pascaligo.ml | 8 ++++---- vendors/ligo-utils/simple-utils/var.ml | 5 ----- vendors/ligo-utils/simple-utils/var.mli | 1 - 3 files changed, 4 insertions(+), 10 deletions(-) diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index 0a550b917..fd979b5fa 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -28,7 +28,7 @@ and repair_mutable_variable (for_body : expression) (element_names : expression_ ok (true,(decl_var, free_var), e_let_in let_binder false false rhs let_result) else( let free_var = if (List.mem name free_var) then free_var else name::free_var in - let expr = e_let_in (env,None) false false (e_update (e_variable env) (Var.show name) (e_variable name)) let_result in + let expr = e_let_in (env,None) false false (e_update (e_variable env) (Var.to_name name) (e_variable name)) let_result in ok (true,(decl_var, free_var), e_let_in let_binder false false rhs expr) ) | E_variable name -> @@ -62,7 +62,7 @@ and repair_mutable_variable_for_collect (for_body : expression) (element_names : let free_var = if (List.mem name free_var) then free_var else name::free_var in let expr = e_let_in (env,None) false false ( e_update (e_variable env) ("0") - (e_update (e_accessor (e_variable env) "0") (Var.show name) (e_variable name)) + (e_update (e_accessor (e_variable env) "0") (Var.to_name name) (e_variable name)) ) let_result in ok (true,(decl_var, free_var), e_let_in let_binder false false rhs expr) @@ -86,12 +86,12 @@ and store_mutable_variable (free_vars : expression_variable list) = if (List.length free_vars == 0) then e_unit () else - let aux var = (Var.show var, e_variable var) in + 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) = 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.show ev)) expr) + 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 diff --git a/vendors/ligo-utils/simple-utils/var.ml b/vendors/ligo-utils/simple-utils/var.ml index 05b44d62c..490d3430f 100644 --- a/vendors/ligo-utils/simple-utils/var.ml +++ b/vendors/ligo-utils/simple-utils/var.ml @@ -40,11 +40,6 @@ let to_name var = | None -> var.name | Some _ -> raise Tried_to_unfreshen_variable -let show v = - match v.counter with - | None -> Format.sprintf "%s" v.name - | Some i -> Format.sprintf "%s#%d" v.name i - let fresh ?name () = let name = Option.unopt ~default:"" name in let counter = incr global_counter ; Some !global_counter in diff --git a/vendors/ligo-utils/simple-utils/var.mli b/vendors/ligo-utils/simple-utils/var.mli index 934de4b19..6d4936761 100644 --- a/vendors/ligo-utils/simple-utils/var.mli +++ b/vendors/ligo-utils/simple-utils/var.mli @@ -31,7 +31,6 @@ val of_name : string -> 'a t (* TODO don't use this, this should not exist. *) val to_name : 'a t -> string -val show : 'a t -> string (* Generate a variable, using a counter value from a _global_ counter. If the name is not provided, it will be empty. *) From eee6dbaeb21d7a6391552ac15c03ccd588750fd2 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Wed, 19 Feb 2020 14:18:06 +0100 Subject: [PATCH 4/4] 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"