From ead7832c50ece26af7a80dc3f436489ac376c5e0 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Tue, 30 Jun 2020 14:31:04 -0500 Subject: [PATCH] Fix some polymorphic comparison bugs --- src/passes/05-purification/compiler.ml | 13 ++++++++----- src/passes/07-desugaring/decompiler.ml | 4 +++- src/passes/09-typing/08-typer-old/typer.ml | 2 +- src/passes/10-self_ast_typed/tail_recursion.ml | 4 +++- src/passes/12-self_mini_c/subst.ml | 2 +- src/stages/5-ast_typed/misc.ml | 3 ++- src/stages/5-ast_typed/misc_smart.ml | 3 ++- src/stages/6-mini_c/misc.ml | 6 ++++-- vendors/ligo-utils/simple-utils/location.ml | 6 ++++++ 9 files changed, 30 insertions(+), 13 deletions(-) diff --git a/src/passes/05-purification/compiler.ml b/src/passes/05-purification/compiler.ml index d0efbc869..325ff757e 100644 --- a/src/passes/05-purification/compiler.ml +++ b/src/passes/05-purification/compiler.ml @@ -3,7 +3,7 @@ module I = Ast_imperative module O = Ast_sugar open Trace -let compare_var : O.expression_variable -> O.expression_variable -> int = fun (a:O.expression_variable) (b:O.expression_variable) -> Var.compare a.wrap_content b.wrap_content +let compare_var = Location.compare_content ~compare:Var.compare let rec add_to_end (expression: O.expression) to_add = match expression.expression_content with @@ -25,10 +25,10 @@ let repair_mutable_variable_in_matching (match_body : O.expression) (element_nam ok (true,(name::decl_var, free_var),O.e_let_in let_binder false false rhs let_result) | E_let_in {let_binder;mut=true; rhs;let_result} -> let (name,_) = let_binder in - if List.mem name decl_var then + if List.mem ~compare:compare_var name decl_var then ok (true,(decl_var, free_var), O.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 free_var = if (List.mem ~compare:compare_var name free_var) then free_var else name::free_var in let expr = O.e_let_in (env,None) false false (O.e_update (O.e_variable env) [O.Access_record (Var.to_name name.wrap_content)] (O.e_variable name)) let_result in ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr) ) @@ -65,10 +65,13 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names : ok (true,(name::decl_var, free_var),ass_exp) | E_let_in {let_binder;mut=true; rhs;let_result} -> let (name,_) = let_binder in - if List.mem name decl_var then + if List.mem ~compare:compare_var name decl_var then ok (true,(decl_var, free_var), O.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 free_var = + if (List.mem ~compare:compare_var name free_var) + then free_var + else name::free_var in let expr = O.e_let_in (env,None) false false ( O.e_update (O.e_variable env) [O.Access_tuple Z.zero; O.Access_record (Var.to_name name.wrap_content)] (O.e_variable name) ) diff --git a/src/passes/07-desugaring/decompiler.ml b/src/passes/07-desugaring/decompiler.ml index afa624089..5a96ff2dc 100644 --- a/src/passes/07-desugaring/decompiler.ml +++ b/src/passes/07-desugaring/decompiler.ml @@ -66,7 +66,9 @@ let rec decompile_expression : O.expression -> (I.expression, desugaring_error) let%bind fun_type = decompile_type_expression fun_type in let%bind lambda = decompile_lambda lambda in return @@ I.E_recursive {fun_name;fun_type;lambda} - | O.E_let_in {let_binder;inline=false;rhs=expr1;let_result=expr2} when let_binder = (Location.wrap @@ Var.of_name "_", Some (O.t_unit ())) -> + | O.E_let_in {let_binder = (var, ty);inline=false;rhs=expr1;let_result=expr2} + when Var.equal var.wrap_content (Var.of_name "_") + && Pervasives.(=) ty (Some (O.t_unit ())) -> let%bind expr1 = decompile_expression expr1 in let%bind expr2 = decompile_expression expr2 in return @@ I.E_sequence {expr1;expr2} diff --git a/src/passes/09-typing/08-typer-old/typer.ml b/src/passes/09-typing/08-typer-old/typer.ml index 93292e5af..5f6e9afd5 100644 --- a/src/passes/09-typing/08-typer-old/typer.ml +++ b/src/passes/09-typing/08-typer-old/typer.ml @@ -743,7 +743,7 @@ and type_lambda e { match result.content with | I.E_let_in li -> ( match li.rhs.content with - | I.E_variable name when name = (binder) -> ( + | I.E_variable name when Location.equal_content ~equal:Var.equal name binder -> ( match snd li.let_binder with | Some ty -> ok ty | None -> default_action li.rhs () diff --git a/src/passes/10-self_ast_typed/tail_recursion.ml b/src/passes/10-self_ast_typed/tail_recursion.ml index a0a4cbe46..8de31b56f 100644 --- a/src/passes/10-self_ast_typed/tail_recursion.ml +++ b/src/passes/10-self_ast_typed/tail_recursion.ml @@ -2,6 +2,8 @@ open Errors open Ast_typed open Trace +let var_equal = Location.equal_content ~equal:Var.equal + let rec check_recursive_call : expression_variable -> bool -> expression -> (unit, self_ast_typed_error) result = fun n final_path e -> match e.expression_content with | E_literal _ -> ok () @@ -10,7 +12,7 @@ let rec check_recursive_call : expression_variable -> bool -> expression -> (uni ok () | E_variable v -> ( let%bind _ = Assert.assert_true (recursive_call_is_only_allowed_as_the_last_operation n e.location) - (final_path || n <> v) in + (final_path || not (var_equal n v)) in ok () ) | E_application {lamb;args} -> diff --git a/src/passes/12-self_mini_c/subst.ml b/src/passes/12-self_mini_c/subst.ml index 7d4b5f624..faa376a13 100644 --- a/src/passes/12-self_mini_c/subst.ml +++ b/src/passes/12-self_mini_c/subst.ml @@ -128,7 +128,7 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e let return_id = body in match body.content with | E_variable x' -> - if x' = x + if Location.equal_content ~equal:Var.equal x' x then expr else return_id | E_closure { binder; body } -> ( diff --git a/src/stages/5-ast_typed/misc.ml b/src/stages/5-ast_typed/misc.ml index 480b61fa7..fd9a99eaa 100644 --- a/src/stages/5-ast_typed/misc.ml +++ b/src/stages/5-ast_typed/misc.ml @@ -3,7 +3,8 @@ open Types module Free_variables = struct type bindings = expression_variable list - let mem : expression_variable -> bindings -> bool = List.mem + let var_compare = Location.compare_content ~compare:Var.compare + let mem : expression_variable -> bindings -> bool = List.mem ~compare:var_compare let singleton : expression_variable -> bindings = fun s -> [ s ] let union : bindings -> bindings -> bindings = (@) let unions : bindings list -> bindings = List.concat diff --git a/src/stages/5-ast_typed/misc_smart.ml b/src/stages/5-ast_typed/misc_smart.ml index 92a964586..8fae1c653 100644 --- a/src/stages/5-ast_typed/misc_smart.ml +++ b/src/stages/5-ast_typed/misc_smart.ml @@ -6,7 +6,8 @@ open Misc module Captured_variables = struct type bindings = expression_variable list - let mem : expression_variable -> bindings -> bool = List.mem + let var_compare = Location.compare_content ~compare:Var.compare + let mem : expression_variable -> bindings -> bool = List.mem ~compare:var_compare let singleton : expression_variable -> bindings = fun s -> [ s ] let union : bindings -> bindings -> bindings = (@) let unions : bindings list -> bindings = List.concat diff --git a/src/stages/6-mini_c/misc.ml b/src/stages/6-mini_c/misc.ml index 09a34b4ca..dbb3ea366 100644 --- a/src/stages/6-mini_c/misc.ml +++ b/src/stages/6-mini_c/misc.ml @@ -4,11 +4,13 @@ open Combinators module Free_variables = struct type bindings = expression_variable list - let mem : expression_variable -> bindings -> bool = List.mem + let var_equal = Location.equal_content ~equal:Var.equal + let var_compare = Location.compare_content ~compare:Var.compare + let mem : expression_variable -> bindings -> bool = List.mem ~compare:var_compare let singleton : expression_variable -> bindings = fun s -> [ s ] let mem_count : expression_variable -> bindings -> int = fun x fvs -> - List.length (List.filter (fun (a:expression_variable) -> Var.equal x.wrap_content a.wrap_content) fvs) + List.length (List.filter (var_equal x) fvs) let union : bindings -> bindings -> bindings = (@) let unions : bindings list -> bindings = List.concat let empty : bindings = [] diff --git a/vendors/ligo-utils/simple-utils/location.ml b/vendors/ligo-utils/simple-utils/location.ml index 96c361f3d..8febf4698 100644 --- a/vendors/ligo-utils/simple-utils/location.ml +++ b/vendors/ligo-utils/simple-utils/location.ml @@ -46,6 +46,12 @@ let compare_wrap ~compare:compare_content { wrap_content = wca ; location = la } | 0 -> compare la lb | c -> c +let compare_content ~compare:compare_content wa wb = + compare_content wa.wrap_content wb.wrap_content + +let equal_content ~equal:equal_content wa wb = + equal_content wa.wrap_content wb.wrap_content + let wrap ?(loc = generated) wrap_content = { wrap_content ; location = loc } let get_location x = x.location let unwrap { wrap_content ; _ } = wrap_content