From 4967abc44c0e3fb7f61a74aa69739dad9f74eb90 Mon Sep 17 00:00:00 2001 From: Danil Usoltsev Date: Thu, 12 Mar 2026 22:15:49 +0300 Subject: [PATCH 1/4] add some tests for infix operator --- EML/tests/additional_tests/custom_op_pipe.ml | 7 +++ .../additional_tests/custom_op_via_op.ml | 7 +++ EML/tests/anf_tests.ml | 24 ++++++++++ EML/tests/infer.t | 9 ++++ EML/tests/inferencer_tests.ml | 44 +++++++++++++++++++ EML/tests/llvm.t | 6 +++ EML/tests/parser_tests.ml | 18 ++++++++ EML/tests/riscv.t | 6 +++ 8 files changed, 121 insertions(+) create mode 100644 EML/tests/additional_tests/custom_op_pipe.ml create mode 100644 EML/tests/additional_tests/custom_op_via_op.ml diff --git a/EML/tests/additional_tests/custom_op_pipe.ml b/EML/tests/additional_tests/custom_op_pipe.ml new file mode 100644 index 00000000..b309e49d --- /dev/null +++ b/EML/tests/additional_tests/custom_op_pipe.ml @@ -0,0 +1,7 @@ +let ( ~> ) x f = f x +let succ x = x + 1 + +let main = + let () = print_int (10 ~>succ) in + 0 +;; diff --git a/EML/tests/additional_tests/custom_op_via_op.ml b/EML/tests/additional_tests/custom_op_via_op.ml new file mode 100644 index 00000000..db25a282 --- /dev/null +++ b/EML/tests/additional_tests/custom_op_via_op.ml @@ -0,0 +1,7 @@ +let ( ** ) x y = x * y +let ( +++ ) x y = (x ** y) + 1 + +let main = + let () = print_int (3 +++ 4) in + 0 +;; diff --git a/EML/tests/anf_tests.ml b/EML/tests/anf_tests.ml index 5df7fa9e..54f797cd 100644 --- a/EML/tests/anf_tests.ml +++ b/EML/tests/anf_tests.ml @@ -304,3 +304,27 @@ let%expect_test "anf_roundtrip_types_partial" = | Error e -> Printf.printf "FAIL: %s\n" e); [%expect {| OK: types preserved after ANF round-trip |}] ;; + + +let%expect_test "custom_infix_operator_lowers_to_app" = + parse_and_anf "let ( =^.^= ) x y = (x * 10) + y"; + [%expect + {| +[(AnfValue (NonRec, + ("=^.^=", 2, + (AnfExpr + (ComplexLambda ([(PatVariable "x")], + (AnfExpr + (ComplexLambda ([(PatVariable "y")], + (AnfLet (NonRec, "anf_t0", + (ComplexBinOper (Multiply, (ImmediateVar "x"), + (ImmediateConst (ConstInt 10)))), + (AnfExpr + (ComplexBinOper (Plus, (ImmediateVar "anf_t0"), + (ImmediateVar "y")))) + )) + ))) + )))), + [])) + ]|}] +;; \ No newline at end of file diff --git a/EML/tests/infer.t b/EML/tests/infer.t index 08e22066..5aacc691 100644 --- a/EML/tests/infer.t +++ b/EML/tests/infer.t @@ -114,3 +114,12 @@ SPDX-License-Identifier: LGPL-3.0-or-later $ make infer many_tests/do_not_type/099.ml 2>&1 | sed -n '1p' Inferencer error: Left-hand side error: Only variables are allowed on the left-hand side of let rec. + $ make infer additional_tests/custom_op_via_op.ml + val ** : int -> int -> int + val +++ : int -> int -> int + val main: int + + $ make infer additional_tests/custom_op_pipe.ml + val ~> : t0 -> (t0 -> t1) -> t1 + val succ: int -> int + val main: int diff --git a/EML/tests/inferencer_tests.ml b/EML/tests/inferencer_tests.ml index 78369081..92a1bb3d 100644 --- a/EML/tests/inferencer_tests.ml +++ b/EML/tests/inferencer_tests.ml @@ -440,3 +440,47 @@ let%expect_test "test_ast_pattern_unit_lambda" = pretty_printer_infer_simple_expression (ExpLambda (PatUnit, [], ExpConst (ConstInt 1))); [%expect {|unit -> int|}] ;; + +let%expect_test "custom_infix_operator" = + pretty_printer_parse_and_infer + {| let ( ** ) x y = x * y +let main = 2 ** 3 |}; + [%expect + {| + val **: int -> int -> int + val main: int|}] +;; + +let%expect_test "custom_infix_bind_like" = + pretty_printer_parse_and_infer + {| let ( >>= ) n _ = if n <= 1 then 1 else n * (n - 1) +let main = 3 >>= 0 |}; + [%expect + {| + val >>=: int -> t1 -> int + val main: int|}] +;; + +let%expect_test "custom_infix_power" = + pretty_printer_parse_and_infer + {| let rec ( ^^ ) x n = if n <= 0 then 1 else x * (x ^^ (n - 1)) +let main = 2 ^^ 10 |}; + [%expect + {| + val ^^: int -> int -> int + val main: int|}] +;; + +let%expect_test "custom_infix_compose" = + pretty_printer_parse_and_infer + {| let ( @@ ) f g = fun x -> f (g x) +let succ x = x + 1 +let double x = x * 2 +let main = (succ @@ double) 10 |}; + [%expect + {| + val @@: (t3 -> t4) -> (t2 -> t3) -> t2 -> t4 + val double: int -> int + val main: int + val succ: int -> int|}] +;; diff --git a/EML/tests/llvm.t b/EML/tests/llvm.t index fb3db451..09a657fc 100644 --- a/EML/tests/llvm.t +++ b/EML/tests/llvm.t @@ -81,3 +81,9 @@ SPDX-License-Identifier: LGPL-3.0-or-later $ make compile_llvm additional_tests/custom_op_cat.ml 34 + + $ make compile_llvm additional_tests/custom_op_via_op.ml + 13 + + $ make compile_llvm additional_tests/custom_op_pipe.ml + 11 diff --git a/EML/tests/parser_tests.ml b/EML/tests/parser_tests.ml index f801679d..cf851fdf 100644 --- a/EML/tests/parser_tests.ml +++ b/EML/tests/parser_tests.ml @@ -233,3 +233,21 @@ let%expect_test "test_unit" = ] |}] ;; + + +let%expect_test "custom_infix_operator" = + parse_test {| let ( ** ) x y = x * y in 2 ** 3 |}; + [%expect + {| +[(SEval + (ExpLet (NonRec, + ((PatVariable "**"), + (ExpLambda ((PatVariable "x"), [(PatVariable "y")], + (ExpBinOper ((Custom "*"), (ExpIdent "x"), (ExpIdent "y")))))), + [], + (ExpBinOper ((Custom "**"), (ExpConst (ConstInt 2)), + (ExpConst (ConstInt 3)))) + ))) + ] + |}] +;; \ No newline at end of file diff --git a/EML/tests/riscv.t b/EML/tests/riscv.t index 2cd6d6c3..c472fa75 100644 --- a/EML/tests/riscv.t +++ b/EML/tests/riscv.t @@ -83,3 +83,9 @@ SPDX-License-Identifier: LGPL-3.0-or-later $ make compile_riscv additional_tests/custom_op_cat.ml 34 + + $ make compile_llvm additional_tests/custom_op_via_op.ml + 13 + + $ make compile_llvm additional_tests/custom_op_pipe.ml + 11 From 7f51364ac2c34d455dbf5ae99ef66f1733838bd7 Mon Sep 17 00:00:00 2001 From: Danil Usoltsev Date: Thu, 12 Mar 2026 22:35:52 +0300 Subject: [PATCH 2/4] add priority for infix operator --- EML/lib/frontend/parser.ml | 83 +++++++++++++++++++++++++++++--------- EML/tests/dune | 1 + EML/tests/infer.t | 8 ++-- EML/tests/parser_tests.ml | 59 +++++++++++++++++---------- 4 files changed, 107 insertions(+), 44 deletions(-) diff --git a/EML/lib/frontend/parser.ml b/EML/lib/frontend/parser.ml index f92bca06..52c86255 100644 --- a/EML/lib/frontend/parser.ml +++ b/EML/lib/frontend/parser.ml @@ -82,6 +82,44 @@ let is_operator_char_infix = function | '|' | ':' | _ -> false ;; +let is_custom_power_op op = + String.length op >= 2 && String.equal (String.sub op ~pos:0 ~len:2) "**" +;; + +let first_char op = String.get op 0 + +let is_custom_mul_op op = + not (is_custom_power_op op) + && + match first_char op with + | '*' | '/' | '%' -> true + | _ -> false +;; + +let is_custom_add_op op = + match first_char op with + | '+' | '-' -> true + | _ -> false +;; + +let is_custom_concat_op op = + match first_char op with + | '@' | '^' -> true + | _ -> false +;; + +let is_custom_cmp_op op = + match first_char op with + | '=' | '<' | '>' | '|' | '&' | '$' -> true + | _ -> false +;; + +let is_custom_lowest_op op = + match first_char op with + | '!' | '?' | '~' | '.' -> true + | _ -> false +;; + let white_space = take_while Char.is_whitespace let token s = white_space *> string s let token1 s = white_space *> s @@ -303,6 +341,14 @@ let parse_expr_bin_oper parse_bin_op tkn = token tkn *> return (fun e1 e2 -> ExpBinOper (parse_bin_op, e1, e2)) ;; +let parse_right_associative expr oper = + let rec parse () = + expr >>= fun left -> + (oper >>= fun combine -> parse () >>| fun right -> combine left right) <|> return left + in + parse () +;; + let multiply = parse_expr_bin_oper Multiply "*" let division = parse_expr_bin_oper Division "/" let plus = parse_expr_bin_oper Plus "+" @@ -322,17 +368,14 @@ let compare = let and_op = parse_expr_bin_oper And "&&" let or_op = parse_expr_bin_oper Or "||" -let parse_custom_infix = - white_space *> take_while1 is_operator_char_infix - >>| fun op -> fun e1 e2 -> ExpBinOper (Custom op, e1, e2) -;; - -let parse_custom_infix_except except = +let parse_custom_infix_when pred = white_space *> take_while1 is_operator_char_infix >>= fun op -> - if List.mem except op ~equal:String.equal + if Option.is_some (builtin_op_of_string op) then fail "builtin" - else return (fun e1 e2 -> ExpBinOper (Custom op, e1, e2)) + else if pred op + then return (fun e1 e2 -> ExpBinOper (Custom op, e1, e2)) + else fail "custom_op_mismatch" ;; let parse_expr_ident = parse_ident >>| fun x -> ExpIdent x @@ -534,32 +577,34 @@ let parse_top_expr parse_expr = ] ;; -let lower_than_ops1 = [ "+"; "-"; ">="; "<="; "<>"; "="; ">"; "<"; "&&"; "||" ] -let lower_than_ops2 = [ ">="; "<="; "<>"; "="; ">"; "<"; "&&"; "||" ] -let lower_than_cmp = [ "&&"; "||" ] let parse_exp_apply e right = let app = parse_expr_apply e right in let app = parse_expr_unar_oper app <|> app in + let power = parse_right_associative app (parse_custom_infix_when is_custom_power_op) in let ops1 = parse_left_associative - app - (parse_custom_infix_except lower_than_ops1 <|> multiply <|> division) - app + power + (parse_custom_infix_when is_custom_mul_op <|> multiply <|> division) + power in let ops2 = parse_left_associative ops1 - (parse_custom_infix_except lower_than_ops2 <|> plus <|> minus) + (parse_custom_infix_when is_custom_add_op <|> plus <|> minus) ops1 in + let concat = + parse_right_associative ops2 (parse_custom_infix_when is_custom_concat_op) + in let cmp = parse_left_associative - ops2 - (parse_custom_infix_except lower_than_cmp <|> compare) - ops2 + concat + (parse_custom_infix_when is_custom_cmp_op <|> parse_custom_infix_when is_custom_lowest_op <|> compare) + concat in - parse_left_associative cmp (parse_custom_infix <|> and_op <|> or_op) cmp + let bool_and = parse_right_associative cmp and_op in + parse_right_associative bool_and or_op ;; let parse_expr = diff --git a/EML/tests/dune b/EML/tests/dune index e341b8ce..6acbc543 100644 --- a/EML/tests/dune +++ b/EML/tests/dune @@ -26,6 +26,7 @@ (file ../bin/EML.exe) (file Makefile) (file ../lib/runtime/rv64_runtime.a) + (source_tree additional_tests) (source_tree gc_tests) (source_tree many_tests))) diff --git a/EML/tests/infer.t b/EML/tests/infer.t index 5aacc691..4afeba3d 100644 --- a/EML/tests/infer.t +++ b/EML/tests/infer.t @@ -115,11 +115,11 @@ SPDX-License-Identifier: LGPL-3.0-or-later Inferencer error: Left-hand side error: Only variables are allowed on the left-hand side of let rec. $ make infer additional_tests/custom_op_via_op.ml - val ** : int -> int -> int - val +++ : int -> int -> int + val **: int -> int -> int + val +++: int -> int -> int val main: int $ make infer additional_tests/custom_op_pipe.ml - val ~> : t0 -> (t0 -> t1) -> t1 - val succ: int -> int val main: int + val succ: int -> int + val ~>: t0 -> (t0 -> t2) -> t2 diff --git a/EML/tests/parser_tests.ml b/EML/tests/parser_tests.ml index cf851fdf..d11dfc8f 100644 --- a/EML/tests/parser_tests.ml +++ b/EML/tests/parser_tests.ml @@ -27,20 +27,20 @@ let main = fac 4 |}; ((PatVariable "fac"), (ExpLambda ((PatVariable "n"), [], (ExpBranch ( - (ExpBinOper ((Custom "<="), (ExpIdent "n"), - (ExpConst (ConstInt 1)))), + (ExpBinOper (LowestEqual, (ExpIdent "n"), (ExpConst (ConstInt 1)) + )), (ExpConst (ConstInt 1)), (Some (ExpLet (NonRec, ((PatVariable "n1"), - (ExpBinOper ((Custom "-"), (ExpIdent "n"), + (ExpBinOper (Minus, (ExpIdent "n"), (ExpConst (ConstInt 1))))), [], (ExpLet (NonRec, ((PatVariable "m"), (ExpApply ((ExpIdent "fac"), (ExpIdent "n1")))), [], - (ExpBinOper ((Custom "*"), (ExpIdent "n"), - (ExpIdent "m"))) + (ExpBinOper (Multiply, (ExpIdent "n"), (ExpIdent "m") + )) )) ))) )) @@ -62,12 +62,11 @@ let%expect_test "factorial" = ((PatVariable "factorial"), (ExpLambda ((PatVariable "n"), [], (ExpBranch ( - (ExpBinOper ((Custom "<"), (ExpIdent "n"), (ExpConst (ConstInt 2)) - )), + (ExpBinOper (LowerThan, (ExpIdent "n"), (ExpConst (ConstInt 2)))), (ExpConst (ConstInt 1)), - (Some (ExpBinOper ((Custom "*"), (ExpIdent "n"), + (Some (ExpBinOper (Multiply, (ExpIdent "n"), (ExpApply ((ExpIdent "factorial"), - (ExpBinOper ((Custom "-"), (ExpIdent "n"), + (ExpBinOper (Minus, (ExpIdent "n"), (ExpConst (ConstInt 1)))) )) ))) @@ -86,16 +85,15 @@ let%expect_test "fibonacci" = ((PatVariable "fibo"), (ExpLambda ((PatVariable "n"), [], (ExpBranch ( - (ExpBinOper ((Custom "<"), (ExpIdent "n"), (ExpConst (ConstInt 2)) - )), + (ExpBinOper (LowerThan, (ExpIdent "n"), (ExpConst (ConstInt 2)))), (ExpConst (ConstInt 1)), - (Some (ExpBinOper ((Custom "+"), + (Some (ExpBinOper (Plus, (ExpApply ((ExpIdent "fibo"), - (ExpBinOper ((Custom "-"), (ExpIdent "n"), + (ExpBinOper (Minus, (ExpIdent "n"), (ExpConst (ConstInt 1)))) )), (ExpApply ((ExpIdent "fibo"), - (ExpBinOper ((Custom "-"), (ExpIdent "n"), + (ExpBinOper (Minus, (ExpIdent "n"), (ExpConst (ConstInt 2)))) )) ))) @@ -114,7 +112,7 @@ let%expect_test "lambda_test" = ((PatVariable "add"), (ExpLambda ((PatVariable "x"), [], (ExpLambda ((PatVariable "y"), [], - (ExpBinOper ((Custom "+"), (ExpIdent "x"), (ExpIdent "y"))))) + (ExpBinOper (Plus, (ExpIdent "x"), (ExpIdent "y"))))) ))), [])) ] @@ -174,7 +172,7 @@ let%expect_test "test_sum_two_args" = [(SValue (NonRec, ((PatVariable "sum"), (ExpLambda ((PatVariable "x"), [(PatVariable "y")], - (ExpBinOper ((Custom "+"), (ExpIdent "x"), (ExpIdent "y")))))), + (ExpBinOper (Plus, (ExpIdent "x"), (ExpIdent "y")))))), [])) ] |}] @@ -188,7 +186,7 @@ let%expect_test "test_annotate_type_1" = ((PatVariable "sum"), (ExpLambda ((PatType ((PatVariable "x"), (TyPrim "int"))), [(PatType ((PatVariable "y"), (TyPrim "int")))], - (ExpBinOper ((Custom "+"), (ExpIdent "x"), (ExpIdent "y")))))), + (ExpBinOper (Plus, (ExpIdent "x"), (ExpIdent "y")))))), [])) ] |}] @@ -211,9 +209,9 @@ let%expect_test "test_minus" = [%expect {| [(SEval - (ExpBinOper ((Custom "-"), - (ExpBinOper ((Custom "-"), - (ExpBinOper ((Custom "-"), + (ExpBinOper (Minus, + (ExpBinOper (Minus, + (ExpBinOper (Minus, (ExpUnarOper (Negative, (ExpConst (ConstInt 1)))), (ExpConst (ConstInt 2)))), (ExpUnarOper (Negative, (ExpConst (ConstInt 1)))))), @@ -243,11 +241,30 @@ let%expect_test "custom_infix_operator" = (ExpLet (NonRec, ((PatVariable "**"), (ExpLambda ((PatVariable "x"), [(PatVariable "y")], - (ExpBinOper ((Custom "*"), (ExpIdent "x"), (ExpIdent "y")))))), + (ExpBinOper (Multiply, (ExpIdent "x"), (ExpIdent "y")))))), [], (ExpBinOper ((Custom "**"), (ExpConst (ConstInt 2)), (ExpConst (ConstInt 3)))) ))) ] |}] +;; + +let%expect_test "custom_power_operator_is_right_associative" = + parse_test {| let ( ** ) x y = x * y in 2 ** 3 ** 4 |}; + [%expect + {| +[(SEval + (ExpLet (NonRec, + ((PatVariable "**"), + (ExpLambda ((PatVariable "x"), [(PatVariable "y")], + (ExpBinOper (Multiply, (ExpIdent "x"), (ExpIdent "y")))))), + [], + (ExpBinOper ((Custom "**"), (ExpConst (ConstInt 2)), + (ExpBinOper ((Custom "**"), (ExpConst (ConstInt 3)), + (ExpConst (ConstInt 4)))) + )) + ))) + ] +|}] ;; \ No newline at end of file From 7da0ee4aa161d2a682662f1bb434d6c7d9ade3db Mon Sep 17 00:00:00 2001 From: Danil Usoltsev Date: Thu, 12 Mar 2026 22:50:15 +0300 Subject: [PATCH 3/4] add test for right associative --- .../additional_tests/custom_op_right_assoc_diff.ml | 12 ++++++++++++ EML/tests/infer.t | 4 ++++ EML/tests/llvm.t | 3 +++ EML/tests/riscv.t | 3 +++ 4 files changed, 22 insertions(+) create mode 100644 EML/tests/additional_tests/custom_op_right_assoc_diff.ml diff --git a/EML/tests/additional_tests/custom_op_right_assoc_diff.ml b/EML/tests/additional_tests/custom_op_right_assoc_diff.ml new file mode 100644 index 00000000..476ff9d2 --- /dev/null +++ b/EML/tests/additional_tests/custom_op_right_assoc_diff.ml @@ -0,0 +1,12 @@ +let ( ** ) x y = x - y + +let main = + let () = print_int (10 ** 3 ** 1) in + 0 +;; +let ( ** ) x y = x - y + +let main = + let () = print_int (10 ** 3 ** 1) in + 0 +;; diff --git a/EML/tests/infer.t b/EML/tests/infer.t index 4afeba3d..9a7ce7d3 100644 --- a/EML/tests/infer.t +++ b/EML/tests/infer.t @@ -119,6 +119,10 @@ SPDX-License-Identifier: LGPL-3.0-or-later val +++: int -> int -> int val main: int + $ make infer additional_tests/custom_op_right_assoc_diff.ml + val **: int -> int -> int + val main: int + $ make infer additional_tests/custom_op_pipe.ml val main: int val succ: int -> int diff --git a/EML/tests/llvm.t b/EML/tests/llvm.t index 09a657fc..75c986dc 100644 --- a/EML/tests/llvm.t +++ b/EML/tests/llvm.t @@ -82,6 +82,9 @@ SPDX-License-Identifier: LGPL-3.0-or-later $ make compile_llvm additional_tests/custom_op_cat.ml 34 + $ make compile_llvm additional_tests/custom_op_right_assoc_diff.ml + 8 + $ make compile_llvm additional_tests/custom_op_via_op.ml 13 diff --git a/EML/tests/riscv.t b/EML/tests/riscv.t index c472fa75..9a2abd6a 100644 --- a/EML/tests/riscv.t +++ b/EML/tests/riscv.t @@ -84,6 +84,9 @@ SPDX-License-Identifier: LGPL-3.0-or-later $ make compile_riscv additional_tests/custom_op_cat.ml 34 + $ make compile_riscv additional_tests/custom_op_right_assoc_diff.ml + 8 + $ make compile_llvm additional_tests/custom_op_via_op.ml 13 From 340a0339458f5f86a9efd505eb26c34f64334b3e Mon Sep 17 00:00:00 2001 From: Danil Usoltsev Date: Thu, 12 Mar 2026 23:01:21 +0300 Subject: [PATCH 4/4] foramt & zanuda fix --- EML/lib/backend/ricsv/peephole.ml | 61 ++++++++++--------- EML/lib/frontend/parser.ml | 12 ++-- EML/lib/middleend/inferencer.ml | 4 +- EML/lib/middleend/resolve_builtins.ml | 13 ++-- .../custom_op_right_assoc_diff.ml | 6 -- EML/tests/anf_tests.ml | 3 +- EML/tests/parser_tests.ml | 3 +- 7 files changed, 47 insertions(+), 55 deletions(-) diff --git a/EML/lib/backend/ricsv/peephole.ml b/EML/lib/backend/ricsv/peephole.ml index 7c87435f..c9d9e155 100644 --- a/EML/lib/backend/ricsv/peephole.ml +++ b/EML/lib/backend/ricsv/peephole.ml @@ -248,12 +248,11 @@ let same_memory_key (base1, offset1) (base2, offset2) = equal_reg base1 base2 && offset1 = offset2 ;; -let rec find_cached_load key = function - | [] -> None - | (cached_key, cached_register) :: rest -> - if same_memory_key cached_key key - then Some cached_register - else find_cached_load key rest +let find_cached_load key cache = + List.find_map + (fun (cached_key, cached_register) -> + if same_memory_key cached_key key then Some cached_register else None) + cache ;; let remove_cached_key key cache = @@ -326,13 +325,15 @@ let can_prove_store_dead ~allow_drop_at_block_end slot following_instructions = let rec walk = function | [] -> allow_drop_at_block_end | instruction :: rest -> - if reads_slot slot instruction - then false - else if stores_slot slot instruction - then true - else if writes_slot_base slot instruction - then false - else walk rest + (match + ( reads_slot slot instruction + , stores_slot slot instruction + , writes_slot_base slot instruction ) + with + | true, _, _ -> false + | _, true, _ -> true + | _, _, true -> false + | _ -> walk rest) in walk following_instructions ;; @@ -340,10 +341,10 @@ let can_prove_store_dead ~allow_drop_at_block_end slot following_instructions = let eliminate_dead_stores_in_block ~allow_drop_at_block_end block = let rec loop changed acc = function | [] -> List.rev acc, changed - | (Sd (_, slot) as store_instruction) :: rest -> - if can_prove_store_dead ~allow_drop_at_block_end slot rest - then loop true acc rest - else loop changed (store_instruction :: acc) rest + | Sd (_, slot) :: rest when can_prove_store_dead ~allow_drop_at_block_end slot rest -> + loop true acc rest + | (Sd (_, _) as store_instruction) :: rest -> + loop changed (store_instruction :: acc) rest | instruction :: rest -> loop changed (instruction :: acc) rest in loop false [] block @@ -389,20 +390,20 @@ let find_redundant_restore_store loaded_register loaded_slot following_instructi in let rec search prefix = function | [] -> List.rev_append prefix [], false + | instruction :: rest + when is_barrier instruction || writes_slot_base loaded_slot instruction -> + List.rev_append prefix (instruction :: rest), false + | Sd (stored_register, store_slot) :: rest + when same_memory_key loaded_slot store_slot + && equal_reg stored_register loaded_register -> + List.rev_append prefix rest, true + | Sd (stored_register, store_slot) :: rest when same_memory_key loaded_slot store_slot + -> List.rev_append prefix (Sd (stored_register, store_slot) :: rest), false | instruction :: rest -> - if is_barrier instruction || writes_slot_base loaded_slot instruction - then List.rev_append prefix (instruction :: rest), false - else ( - match instruction with - | Sd (stored_register, store_slot) when same_memory_key loaded_slot store_slot -> - if equal_reg stored_register loaded_register - then List.rev_append prefix rest, true - else List.rev_append prefix (instruction :: rest), false - | _ -> - (match write_reg instruction with - | Some written_register when equal_reg written_register loaded_register -> - List.rev_append prefix (instruction :: rest), false - | _ -> search (instruction :: prefix) rest)) + (match write_reg instruction with + | Some written_register when equal_reg written_register loaded_register -> + List.rev_append prefix (instruction :: rest), false + | _ -> search (instruction :: prefix) rest) in search [] following_instructions ;; diff --git a/EML/lib/frontend/parser.ml b/EML/lib/frontend/parser.ml index 52c86255..73dcd33c 100644 --- a/EML/lib/frontend/parser.ml +++ b/EML/lib/frontend/parser.ml @@ -89,7 +89,7 @@ let is_custom_power_op op = let first_char op = String.get op 0 let is_custom_mul_op op = - not (is_custom_power_op op) + (not (is_custom_power_op op)) && match first_char op with | '*' | '/' | '%' -> true @@ -343,8 +343,9 @@ let parse_expr_bin_oper parse_bin_op tkn = let parse_right_associative expr oper = let rec parse () = - expr >>= fun left -> - (oper >>= fun combine -> parse () >>| fun right -> combine left right) <|> return left + expr + >>= fun left -> + oper >>= (fun combine -> parse () >>| fun right -> combine left right) <|> return left in parse () ;; @@ -577,7 +578,6 @@ let parse_top_expr parse_expr = ] ;; - let parse_exp_apply e right = let app = parse_expr_apply e right in let app = parse_expr_unar_oper app <|> app in @@ -600,7 +600,9 @@ let parse_exp_apply e right = let cmp = parse_left_associative concat - (parse_custom_infix_when is_custom_cmp_op <|> parse_custom_infix_when is_custom_lowest_op <|> compare) + (parse_custom_infix_when is_custom_cmp_op + <|> parse_custom_infix_when is_custom_lowest_op + <|> compare) concat in let bool_and = parse_right_associative cmp and_op in diff --git a/EML/lib/middleend/inferencer.ml b/EML/lib/middleend/inferencer.ml index c1490d69..3cda300a 100644 --- a/EML/lib/middleend/inferencer.ml +++ b/EML/lib/middleend/inferencer.ml @@ -284,7 +284,7 @@ module TypeEnv = struct let apply subst env = Map.map env ~f:(Scheme.apply subst) let find = Map.find - let keys t = Map.keys t + let keys = Map.keys let initial_env = let open Base.Map in @@ -481,7 +481,7 @@ let get_binop_arg_res env op = , Substitution.apply subst arg_ty2 , Substitution.apply subst res_ty , subst ) - | op -> + | _ -> let* ty1, ty2, ty_res = infer_binop_type op in return (ty1, ty2, ty_res, Substitution.empty) ;; diff --git a/EML/lib/middleend/resolve_builtins.ml b/EML/lib/middleend/resolve_builtins.ml index a9f821df..7375494b 100644 --- a/EML/lib/middleend/resolve_builtins.ml +++ b/EML/lib/middleend/resolve_builtins.ml @@ -22,17 +22,14 @@ let names_of_pattern p = let names_of_bind (pat, _) = names_of_pattern pat -let rec resolve_expr scope e = - match e with +let rec resolve_expr scope = function | ExpBinOper (Custom op, e1, e2) -> let e1' = resolve_expr scope e1 in let e2' = resolve_expr scope e2 in - (match List.mem scope op ~equal:String.equal with - | true -> ExpBinOper (Custom op, e1', e2') - | false -> - (match builtin_op_of_string op with - | Some b -> ExpBinOper (b, e1', e2') - | None -> ExpBinOper (Custom op, e1', e2'))) + (match List.mem scope op ~equal:String.equal, builtin_op_of_string op with + | true, _ -> ExpBinOper (Custom op, e1', e2') + | false, Some b -> ExpBinOper (b, e1', e2') + | false, None -> ExpBinOper (Custom op, e1', e2')) | ExpIdent x -> ExpIdent x | ExpConst c -> ExpConst c | ExpBranch (c, t, o) -> diff --git a/EML/tests/additional_tests/custom_op_right_assoc_diff.ml b/EML/tests/additional_tests/custom_op_right_assoc_diff.ml index 476ff9d2..b3c1af28 100644 --- a/EML/tests/additional_tests/custom_op_right_assoc_diff.ml +++ b/EML/tests/additional_tests/custom_op_right_assoc_diff.ml @@ -4,9 +4,3 @@ let main = let () = print_int (10 ** 3 ** 1) in 0 ;; -let ( ** ) x y = x - y - -let main = - let () = print_int (10 ** 3 ** 1) in - 0 -;; diff --git a/EML/tests/anf_tests.ml b/EML/tests/anf_tests.ml index 54f797cd..30354196 100644 --- a/EML/tests/anf_tests.ml +++ b/EML/tests/anf_tests.ml @@ -305,7 +305,6 @@ let%expect_test "anf_roundtrip_types_partial" = [%expect {| OK: types preserved after ANF round-trip |}] ;; - let%expect_test "custom_infix_operator_lowers_to_app" = parse_and_anf "let ( =^.^= ) x y = (x * 10) + y"; [%expect @@ -327,4 +326,4 @@ let%expect_test "custom_infix_operator_lowers_to_app" = )))), [])) ]|}] -;; \ No newline at end of file +;; diff --git a/EML/tests/parser_tests.ml b/EML/tests/parser_tests.ml index d11dfc8f..c922b30d 100644 --- a/EML/tests/parser_tests.ml +++ b/EML/tests/parser_tests.ml @@ -232,7 +232,6 @@ let%expect_test "test_unit" = |}] ;; - let%expect_test "custom_infix_operator" = parse_test {| let ( ** ) x y = x * y in 2 ** 3 |}; [%expect @@ -267,4 +266,4 @@ let%expect_test "custom_power_operator_is_right_associative" = ))) ] |}] -;; \ No newline at end of file +;;