From d7acd29b58ec63422a61b365360c529864bf474a Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Thu, 25 Sep 2025 15:46:54 +0200 Subject: [PATCH 1/2] No local var option --- .github/workflows/binary-releases.yml | 2 +- makefiles/c_backend.mk | 7 ++++- makefiles/variables.mk | 27 ++++++++++++++------ src/mlang/backend_compilers/decoupledExpr.ml | 14 ++++++---- src/mlang/driver.ml | 4 +-- src/mlang/utils/cli.ml | 15 +++++++++-- src/mlang/utils/cli.mli | 4 +++ 7 files changed, 54 insertions(+), 19 deletions(-) diff --git a/.github/workflows/binary-releases.yml b/.github/workflows/binary-releases.yml index 773935862..34eee6812 100644 --- a/.github/workflows/binary-releases.yml +++ b/.github/workflows/binary-releases.yml @@ -49,7 +49,7 @@ jobs: uses: ocaml/setup-ocaml@v2 with: # Version of the OCaml compiler to initialise - ocaml-compiler: 4.11.2 + ocaml-compiler: 4.13.1 - name: Install dependencies run: | diff --git a/makefiles/c_backend.mk b/makefiles/c_backend.mk index e14bd388d..249611477 100644 --- a/makefiles/c_backend.mk +++ b/makefiles/c_backend.mk @@ -21,7 +21,7 @@ DGFIP_TARGET_FLAGS?=-g,-O,-k4 # bouclant sur la table des variables restituables (IN_init_extraction). DGFIP_COMMON_FLAGS=-m$(YEAR),-X -MLANG_DGFIP=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(MLANG_DGFIP_C_OPTS) +MLANG_DGFIP=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(MLANG_DGFIP_C_OPTS) $(NO_LOCAL_VAR_FLAG) QUIET=>/dev/null # Uncomment to suppress output @@ -56,6 +56,7 @@ calc/mlang.h: $(SOURCE_FILES) $(SOURCE_EXT_FILES) | calc_dir @echo " MPP_FUNCTION=$(MPP_FUNCTION_BACKEND)" @echo " DGFIP_TARGET_FLAGS=$(DGFIP_TARGET_FLAGS)" @echo " DGFIP_COMMON_FLAGS=$(DGFIP_COMMON_FLAGS)" + @echo " NO_LOCAL_VAR_FLAG=$(NO_LOCAL_VAR_FLAG)" @$(MLANG_DGFIP) \ --income-year=$(YEAR) \ --comparison_error_margin=$(COMPARISON_ERROR_MARGIN) \ @@ -137,7 +138,11 @@ endif ifeq ($(call is_in,$(DGFIP_DIR)),1) backend_tests: compile_dgfip_c_backend + ifdef OUTPUT_TEST_TIME_IN_DIR + time -f "%U" --append -o $(OUTPUT_TEST_TIME_IN_DIR)/$(CC)$(OV)_time ./cal -mode primitif -recursif ${TEST_FILES} + else ./cal -mode primitif -recursif ${TEST_FILES} + endif endif ifeq ($(call is_in,$(DGFIP_DIR)),1) diff --git a/makefiles/variables.mk b/makefiles/variables.mk index f67fd4338..7a522557d 100644 --- a/makefiles/variables.mk +++ b/makefiles/variables.mk @@ -68,15 +68,20 @@ ifeq ($(origin CC),default) CC=clang endif +ifndef OV + ifeq ($(CC), clang) + OV=2 + else ifeq ($(CC), gcc) + OV=1 + endif +endif + +COMMON_CFLAGS?=-std=c89 -pedantic + # Options pour le compilateur C # Attention, très long à compiler avec GCC en O2/O3 -COMMON_CFLAGS?=-std=c89 -pedantic -ifeq ($(CC), clang) - COMPILER_SPECIFIC_CFLAGS=-O2 -# COMPILER_SPECIFIC_CFLAGS= -else ifeq ($(CC), gcc) - COMPILER_SPECIFIC_CFLAGS=-O1 -endif +COMPILER_SPECIFIC_CFLAGS=-O$(OV) + BACKEND_CFLAGS?=$(COMMON_CFLAGS) $(COMPILER_SPECIFIC_CFLAGS) # Directory of the driver sources for tax calculator @@ -107,6 +112,12 @@ else TEST_FILES=$(TESTS_DIR)/* endif +ifeq ($(NO_LOCAL_VAR), 1) + NO_LOCAL_VAR_FLAG=--no-local-var +else + NO_LOCAL_VAR_FLAG= +endif + # Précision des comparaisons entre flottants pendant les calculs COMPARISON_ERROR_MARGIN?=0.000001 @@ -115,7 +126,7 @@ MLANG_INTERPRETER_OPTS=\ --comparison_error_margin=$(COMPARISON_ERROR_MARGIN) \ --mpp_function=$(MPP_FUNCTION) -MLANG_TEST=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(MLANG_INTERPRETER_OPTS) $(CODE_COVERAGE_FLAG) +MLANG_TEST=$(MLANG_BIN) $(MLANG_DEFAULT_OPTS) $(MLANG_INTERPRETER_OPTS) $(CODE_COVERAGE_FLAG) $(NO_LOCAL_VAR_FLAG) DGFIP_DIR?=examples/dgfip_c/ml_primitif diff --git a/src/mlang/backend_compilers/decoupledExpr.ml b/src/mlang/backend_compilers/decoupledExpr.ml index 7cbcfaa9c..56e612ad6 100644 --- a/src/mlang/backend_compilers/decoupledExpr.ml +++ b/src/mlang/backend_compilers/decoupledExpr.ml @@ -149,15 +149,19 @@ let collapse_constr (stacks : local_stacks) (ctx : local_vars) (constr : constr) let push_with_kind (stacks : local_stacks) (ctx : local_vars) (kind : dflag) (constr : constr) = let expr, ekind, lv = constr stacks ctx in - let expr = if kind = ekind then expr else cast kind expr in - let stacks, lv, expr = store_local stacks lv Anon kind expr in - (stacks, lv, expr) + if !Cli.no_local_var then (stacks, lv, expr) + else + let expr = if kind = ekind then expr else cast kind expr in + let stacks, lv, expr = store_local stacks lv Anon kind expr in + (stacks, lv, expr) (* eval and store without enforcing kind *) let push (stacks : local_stacks) (ctx : local_vars) (constr : constr) = let expr, kind, lv = constr stacks ctx in - let stacks, lv, expr = store_local stacks lv Anon kind expr in - (stacks, lv, expr, kind) + if !Cli.no_local_var then (stacks, lv, expr, kind) + else + let stacks, lv, expr = store_local stacks lv Anon kind expr in + (stacks, lv, expr, kind) (** smart constructors *) diff --git a/src/mlang/driver.ml b/src/mlang/driver.ml index 04f6709b4..4df5bf8ec 100644 --- a/src/mlang/driver.ml +++ b/src/mlang/driver.ml @@ -163,7 +163,7 @@ let set_opts (files : string list) (application_names : string list) (optimize_unsafe_float : bool) (precision : string option) (roundops : string option) (comparison_error_margin : float option) (income_year : int option) (m_clean_calls : bool) - (dgfip_options : string list option) = + (dgfip_options : string list option) (no_local_var : bool) = let value_sort = let precision = Option.get precision in if precision = "double" then Cli.RegularFloat @@ -229,7 +229,7 @@ let set_opts (files : string list) (application_names : string list) var_info_debug display_time dep_graph_file print_cycles output optimize_unsafe_float m_clean_calls comparison_error_margin income_year value_sort round_ops backend dgfip_test_filter mpp_function dgfip_flags - execution_mode + execution_mode no_local_var let run_single_test m_program test = Mir_interpreter.repl_debug := true; diff --git a/src/mlang/utils/cli.ml b/src/mlang/utils/cli.ml index eba6c3f47..6a0e8bcaf 100644 --- a/src/mlang/utils/cli.ml +++ b/src/mlang/utils/cli.ml @@ -182,13 +182,21 @@ let dgfip_options = "Specify DGFiP options (use --dgfip_options=--help to display DGFiP \ specific options)") +let no_local_vars = + Arg.( + value & flag + & info [ "no-local-vars" ] + ~doc: + "(experimental) Does not generate local vars for definitions and \ + evaluation.") + let mlang_t f = Term.( const f $ files $ applications $ without_dgfip_m $ debug $ var_info_debug $ display_time $ dep_graph_file $ no_print_cycles $ backend $ output $ run_all_tests $ dgfip_test_filter $ run_test $ mpp_function $ optimize_unsafe_float $ precision $ roundops $ comparison_error_margin_cli - $ income_year_cli $ m_clean_calls $ dgfip_options) + $ income_year_cli $ m_clean_calls $ dgfip_options $ no_local_vars) let info = let doc = @@ -296,6 +304,8 @@ let dgfip_flags = ref Dgfip_options.default_flags let execution_mode = ref Extraction +let no_local_var = ref false + (* Default value for the epsilon slack when comparing things in the interpreter *) let comparison_error_margin = ref 0.000001 @@ -310,7 +320,7 @@ let set_all_arg_refs (files_ : files) applications_ (without_dgfip_m_ : bool) (income_year_ : int option) (value_sort_ : value_sort) (round_ops_ : round_ops) (backend_ : backend) (dgfip_test_filter_ : bool) (mpp_function_ : string) (dgfip_flags_ : Dgfip_options.flags) - (execution_mode_ : execution_mode) = + (execution_mode_ : execution_mode) (no_local_var_ : bool) = source_files := files_; application_names := applications_; without_dgfip_m := without_dgfip_m_; @@ -333,6 +343,7 @@ let set_all_arg_refs (files_ : files) applications_ (without_dgfip_m_ : bool) dgfip_test_filter := dgfip_test_filter_; mpp_function := mpp_function_; dgfip_flags := dgfip_flags_; + no_local_var := no_local_var_; match output_file_ with | None -> () | Some o -> ( diff --git a/src/mlang/utils/cli.mli b/src/mlang/utils/cli.mli index 2ca786c71..17acf1c42 100644 --- a/src/mlang/utils/cli.mli +++ b/src/mlang/utils/cli.mli @@ -40,6 +40,7 @@ val mlang_t : int option -> bool -> string list option -> + bool -> 'a) -> 'a Cmdliner.Term.t (** Mlang binary command-line arguments parsing function *) @@ -140,6 +141,8 @@ val dgfip_flags : Dgfip_options.flags ref val execution_mode : execution_mode ref +val no_local_var : bool ref + val set_all_arg_refs : (* files *) files -> (* applications *) string list -> @@ -161,6 +164,7 @@ val set_all_arg_refs : (* mpp_function *) string -> (* dgfip_flags *) Dgfip_options.flags -> (* execution_mode *) execution_mode -> + (* no_local_var *) bool -> unit val add_prefix_to_each_line : string -> (int -> string) -> string From fd456ece7cd890b832cf45c98fcaef470a058efa Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Wed, 26 Nov 2025 15:27:46 +0100 Subject: [PATCH 2/2] Simplify binops to reduce parentheses --- src/mlang/backend_compilers/bir_to_dgfip_c.ml | 9 +- src/mlang/backend_compilers/decoupledExpr.ml | 213 ++++++++++++------ src/mlang/m_frontend/expander.ml | 9 +- src/mlang/m_frontend/mast_to_mir.ml | 14 +- src/mlang/m_frontend/mparser.mly | 15 +- src/mlang/m_frontend/validator.ml | 87 +++---- src/mlang/m_ir/com.ml | 21 +- src/mlang/m_ir/com.mli | 2 +- src/mlang/m_ir/mir.ml | 14 +- src/mlang/m_ir/mir_interpreter.ml | 12 +- 10 files changed, 244 insertions(+), 152 deletions(-) diff --git a/src/mlang/backend_compilers/bir_to_dgfip_c.ml b/src/mlang/backend_compilers/bir_to_dgfip_c.ml index ee9aed24e..3b6e6285d 100644 --- a/src/mlang/backend_compilers/bir_to_dgfip_c.ml +++ b/src/mlang/backend_compilers/bir_to_dgfip_c.ml @@ -317,10 +317,11 @@ and generate_c_expr (p : Mir.program) (e : Mir.expression Pos.marked) : let se1 = generate_c_expr p e1 in let se2 = generate_c_expr p e2 in comparison op se1 se2 - | Binop (op, e1, e2) -> - let se1 = generate_c_expr p e1 in - let se2 = generate_c_expr p e2 in - binop op se1 se2 + | Binop (op, l) -> ( + let sl = List.map (generate_c_expr p) l in + match sl with + | [] -> assert false (* Cannot have a binop with no arguments *) + | hd :: tl -> List.fold_left (binop op) hd tl) | Unop (op, e) -> unop op @@ generate_c_expr p e | Conditional (c, t, f_opt) -> let cond = generate_c_expr p c in diff --git a/src/mlang/backend_compilers/decoupledExpr.ml b/src/mlang/backend_compilers/decoupledExpr.ml index 56e612ad6..3e2089822 100644 --- a/src/mlang/backend_compilers/decoupledExpr.ml +++ b/src/mlang/backend_compilers/decoupledExpr.ml @@ -43,10 +43,10 @@ and expr = | Dfalse | Dlit of float | Dvar of expr_var - | Dand of expr * expr - | Dor of expr * expr + | Dand of expr list + | Dor of expr list | Dunop of string * expr - | Dbinop of string * expr * expr + | Dbinop of string * expr list | Dfun of string * expr list | Dite of expr * expr * expr | Dinstr of string @@ -74,7 +74,7 @@ let cast (kind : dflag) (expr : expr) = | Dfalse, Val -> Dlit 0. | Dlit 0., Def -> Dfalse | Dlit _, Def -> Dtrue - | _, Def -> Dbinop ("!=", expr, Dlit 0.) + | _, Def -> Dbinop ("!=", [ expr; Dlit 0. ]) | _, Val -> expr (** local stacks operations *) @@ -106,7 +106,7 @@ let rec expr_position (expr : expr) (st : local_stacks) = if is_in_stack_scope slot st then Not_to_stack else if is_on_top slot st then On_top slot.kind else Must_be_pushed - | Dbinop ("/", e1, e2) -> begin + | Dbinop ("/", [ e1; e2 ]) -> begin (* avoid storage of division by zero. It assumes all division are guarded *) match (expr_position e1 st, expr_position e2 st) with @@ -115,6 +115,9 @@ let rec expr_position (expr : expr) (st : local_stacks) = (* Needed to bumb the stack to avoid erasing subexpressions *) | _, _ -> Not_to_stack (* Either already stored, or duplicatable *) end + | Dbinop ("/", l) -> + Format.ksprintf Errors.raise_error "Invalid arity for division (%i)" + (List.length l) | Ddirect _ -> Not_to_stack | _ -> Must_be_pushed @@ -217,42 +220,111 @@ let local_var (lvar : local_var) (stacks : local_stacks) (ctx : local_vars) : t the point at which the constructed expression is expected to be allocated (if needed). *) +let dand' (e1, lv1) (e2, lv2) = + match (e1, e2) with + | Dtrue, _ -> (e2, lv2) + | _, Dtrue -> (e1, lv1) + | Dfalse, _ | _, Dfalse -> (Dfalse, []) + | Dvar v1, Dvar v2 when v1 = v2 -> (e1, lv1) + | Dand l, Dand l' -> (Dand (l @ l'), lv2 @ lv1) + | Dand l, _ -> (Dand (l @ [ e2 ]), lv2 @ lv1) + | _, Dand l -> (Dand (e1 :: l), lv2 @ lv1) + | _ -> (Dand [ e1; e2 ], lv2 @ lv1) + +let dor' (e1, lv1) (e2, lv2) = + match (e1, e2) with + | Dtrue, _ | _, Dtrue -> (Dtrue, []) + | Dfalse, _ -> (e2, lv2) + | _, Dfalse -> (e1, lv1) + | Dvar v1, Dvar v2 when v1 = v2 -> (e1, lv1) + | Dor l, Dor l' -> (Dor (l @ l'), lv2 @ lv1) + | Dor l, _ -> (Dor (l @ [ e2 ]), lv2 @ lv1) + | _, Dor l -> (Dor (e1 :: l), lv2 @ lv1) + | _ -> (Dor [ e1; e2 ], lv2 @ lv1) + +let dnot' (e, lv) = + match e with + | Dtrue -> (Dfalse, []) + | Dfalse -> (Dtrue, []) + | Dunop ("!", e) -> (e, lv) + | _ -> (Dunop ("!", e), lv) + +let minus' (e, lv) = + match e with + | Dlit f -> (Dlit (-.f), []) + | Dunop ("-", e) -> (e, lv) + | _ -> (Dunop ("-", e), lv) + +let plus' ?(reduce_zero_add = false) (e1, lv1) (e2, lv2) = + match (e1, e2) with + | Dlit 0., _ when reduce_zero_add -> (e2, lv2) + | _, Dlit 0. when reduce_zero_add -> (e1, lv1) + | Dlit f1, Dlit f2 -> (Dlit (f1 +. f2), []) + | Dbinop ("+", l), Dbinop ("+", l') -> (Dbinop ("+", l @ l'), lv2 @ lv1) + | Dbinop ("+", l), _ -> (Dbinop ("+", l @ [ e2 ]), lv2 @ lv1) + | _, Dbinop ("+", l) -> (Dbinop ("+", e1 :: l), lv2 @ lv1) + | _ -> (Dbinop ("+", [ e1; e2 ]), lv2 @ lv1) + +let sub' (e1, lv1) (e2, lv2) = + match (e1, e2) with + | Dlit 0., _ -> (Dunop ("-", e2), lv2) + | _, Dlit 0. -> (e1, lv1) + | Dlit f1, Dlit f2 -> (Dlit (f1 -. f2), []) + | _, Dunop ("-", e2) -> plus' (e1, lv1) (e2, lv2) + | Dbinop ("-", l), Dbinop ("+", l') -> (Dbinop ("-", l @ l'), lv2 @ lv1) + | Dbinop ("-", l), e -> (Dbinop ("-", l @ [ e ]), lv2 @ lv1) + | _ -> (Dbinop ("-", [ e1; e2 ]), lv2 @ lv1) + +let mult' (e1, lv1) (e2, lv2) = + match (e1, e2) with + | Dlit 1., _ -> (e2, lv2) + | _, Dlit 1. -> (e1, lv1) + | Dlit 0., _ | _, Dlit 0. -> (Dlit 0., []) + | Dlit f1, Dlit f2 -> (Dlit (f1 *. f2), []) + | Dbinop ("*", l), Dbinop ("*", l') -> (Dbinop ("*", l @ l'), lv2 @ lv1) + | Dbinop ("*", l), _ -> (Dbinop ("*", l @ [ e2 ]), lv2 @ lv1) + | _, Dbinop ("*", l) -> (Dbinop ("*", e1 :: l), lv2 @ lv1) + | _ -> (Dbinop ("*", [ e1; e2 ]), lv2 @ lv1) + +let div' (e1, lv1) (e2, lv2) = + match (e1, e2) with + | _, Dlit 1. -> (e1, lv1) + | Dlit f1, Dlit f2 -> + let f = f1 /. f2 in + (Dlit f, []) + | _ -> (Dbinop ("/", [ e1; e2 ]), lv2 @ lv1) + +let modulo' (e1, lv1) (e2, lv2) = + match (e1, e2) with + | _, Dlit 1. -> (e1, lv1) + | Dlit f1, Dlit f2 -> + let f = mod_float f1 f2 in + (Dlit f, []) + | _ -> (Dfun ("fmod", [ e1; e2 ]), lv2 @ lv1) + let dand (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) : t = let stacks', lv1, e1 = push_with_kind stacks ctx Def e1 in let _, lv2, e2 = push_with_kind stacks' ctx Def e2 in - match (e1, e2) with - | Dtrue, _ -> (e2, Def, lv2) - | _, Dtrue -> (e1, Def, lv1) - | Dfalse, _ | _, Dfalse -> (Dfalse, Def, []) - | Dvar v1, Dvar v2 when v1 = v2 -> (e1, Def, lv1) - | _ -> (Dand (e1, e2), Def, lv2 @ lv1) + let e, l = dand' (e1, lv1) (e2, lv2) in + (e, Def, l) let dor (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) : t = let stacks', lv1, e1 = push_with_kind stacks ctx Def e1 in let _, lv2, e2 = push_with_kind stacks' ctx Def e2 in - match (e1, e2) with - | Dtrue, _ | _, Dtrue -> (Dtrue, Def, []) - | Dfalse, _ -> (e2, Def, lv2) - | _, Dfalse -> (e1, Def, lv1) - | Dvar v1, Dvar v2 when v1 = v2 -> (e1, Def, lv1) - | _ -> (Dor (e1, e2), Def, lv2 @ lv1) + let e, l = dor' (e1, lv1) (e2, lv2) in + (e, Def, l) let dnot (e : constr) (stacks : local_stacks) (ctx : local_vars) : t = let _, lv, e = push_with_kind stacks ctx Def e in - match e with - | Dtrue -> (Dfalse, Def, []) - | Dfalse -> (Dtrue, Def, []) - | Dunop ("!", e) -> (e, Def, lv) - | _ -> (Dunop ("!", e), Def, lv) + let e, lv = dnot' (e, lv) in + (e, Def, lv) let minus (e : constr) (stacks : local_stacks) (ctx : local_vars) : t = let _, lv, e = push_with_kind stacks ctx Val e in - match e with - | Dlit f -> (Dlit (-.f), Val, []) - | Dunop ("-", e) -> (e, Val, lv) - | _ -> (Dunop ("-", e), Val, lv) + let e, lv = minus' (e, lv) in + (e, Val, lv) let plus (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) : t = @@ -261,54 +333,36 @@ let plus (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) let reduce_zero_add = false in let stacks', lv1, e1 = push_with_kind stacks ctx Val e1 in let _, lv2, e2 = push_with_kind stacks' ctx Val e2 in - match (e1, e2) with - | Dlit 0., _ when reduce_zero_add -> (e2, Val, lv2) - | _, Dlit 0. when reduce_zero_add -> (e1, Val, lv1) - | Dlit f1, Dlit f2 -> (Dlit (f1 +. f2), Val, []) - | _ -> (Dbinop ("+", e1, e2), Val, lv2 @ lv1) + let e, lv = plus' ~reduce_zero_add (e1, lv1) (e2, lv2) in + (e, Val, lv) let sub (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) : t = let stacks', lv1, e1 = push_with_kind stacks ctx Val e1 in let _, lv2, e2 = push_with_kind stacks' ctx Val e2 in - match (e1, e2) with - | Dlit 0., _ -> (Dunop ("-", e2), Val, lv2) - | _, Dlit 0. -> (e1, Val, lv1) - | Dlit f1, Dlit f2 -> (Dlit (f1 -. f2), Val, []) - | _ -> (Dbinop ("-", e1, e2), Val, lv2 @ lv1) + let e, lv = sub' (e1, lv1) (e2, lv2) in + (e, Val, lv) let mult (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) : t = let stacks', lv1, e1 = push_with_kind stacks ctx Val e1 in let _, lv2, e2 = push_with_kind stacks' ctx Val e2 in - match (e1, e2) with - | Dlit 1., _ -> (e2, Val, lv2) - | _, Dlit 1. -> (e1, Val, lv1) - | Dlit 0., _ | _, Dlit 0. -> (Dlit 0., Val, []) - | Dlit f1, Dlit f2 -> (Dlit (f1 *. f2), Val, []) - | _ -> (Dbinop ("*", e1, e2), Val, lv2 @ lv1) + let e, lv = mult' (e1, lv1) (e2, lv2) in + (e, Val, lv) let div (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) : t = let stacks', lv1, e1 = push_with_kind stacks ctx Val e1 in let _, lv2, e2 = push_with_kind stacks' ctx Val e2 in - match (e1, e2) with - | _, Dlit 1. -> (e1, Val, lv1) - | Dlit f1, Dlit f2 -> - let f = f1 /. f2 in - (Dlit f, Val, []) - | _ -> (Dbinop ("/", e1, e2), Val, lv2 @ lv1) + let e, lv = div' (e1, lv1) (e2, lv2) in + (e, Val, lv) let modulo (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) : t = let stacks', lv1, e1 = push_with_kind stacks ctx Val e1 in let _, lv2, e2 = push_with_kind stacks' ctx Val e2 in - match (e1, e2) with - | _, Dlit 1. -> (e1, Val, lv1) - | Dlit f1, Dlit f2 -> - let f = mod_float f1 f2 in - (Dlit f, Val, []) - | _ -> (Dfun ("fmod", [ e1; e2 ]), Val, lv2 @ lv1) + let e, lv = modulo' (e1, lv1) (e2, lv2) in + (e, Val, lv) let comp op (e1 : constr) (e2 : constr) (stacks : local_stacks) (ctx : local_vars) : t = @@ -324,8 +378,9 @@ let comp op (e1 : constr) (e2 : constr) (stacks : local_stacks) then Dtrue else Dfalse | Dvar v1, Dvar v2 -> - if String.equal op "==" && v1 = v2 then Dtrue else Dbinop (op, e1, e2) - | _ -> Dbinop (op, e1, e2) + if String.equal op "==" && v1 = v2 then Dtrue + else Dbinop (op, [ e1; e2 ]) + | _ -> Dbinop (op, [ e1; e2 ]) in let e = match op with @@ -368,8 +423,8 @@ let ite (c : constr) (t : constr) (e : constr) (stacks : local_stacks) else (* this will happen. Staying on the safe side *) Val in match (c, t, e) with - | Dtrue, _, _ -> (t, tkind, lvt) - | Dfalse, _, _ -> (e, ekind, lve) + | (Dfalse | Dlit 0.), _, _ -> (e, ekind, lve) + | (Dtrue | Dlit _), _, _ -> (t, tkind, lvt) | _, Dtrue, Dtrue | _, Dfalse, Dfalse -> (t, tkind, lvt) | _, Dlit 1., Dlit 0. -> (c, Def, lvc) | _, Dlit f, Dlit f' when f = f' -> (Dlit f, ite_kind, []) @@ -449,7 +504,12 @@ let format_expr_var (dgfip_flags : Dgfip_options.flags) fmt (ev : expr_var) = (generate_variable ~trace_flag:dgfip_flags.flg_trace ~def_flag m_sp_opt var) -let rec format_dexpr (dgfip_flags : Dgfip_options.flags) fmt (de : expr) = +let rec format_dexpr_list (dgfip_flags : Dgfip_options.flags) ~sep = + Format.pp_print_list + ~pp_sep:(fun fmt _ -> Format.fprintf fmt " %s " sep) + (format_dexpr dgfip_flags) + +and format_dexpr (dgfip_flags : Dgfip_options.flags) fmt (de : expr) = let format_dexpr = format_dexpr dgfip_flags in match de with | Dtrue -> Format.fprintf fmt "1" @@ -463,36 +523,39 @@ let rec format_dexpr (dgfip_flags : Dgfip_options.flags) fmt (de : expr) = (* Print literal floats as precisely as possible *) Format.fprintf fmt "%#.19g" f) | Dvar evar -> format_expr_var dgfip_flags fmt evar - | Dand (de1, de2) -> - Format.fprintf fmt "@[(%a@ && %a@])" format_dexpr de1 format_dexpr - de2 - | Dor (de1, de2) -> - Format.fprintf fmt "@[(%a@ || %a@])" format_dexpr de1 format_dexpr - de2 + | Dand l -> + Format.fprintf fmt "@[(%a@])" + (format_dexpr_list dgfip_flags ~sep:"&&") + l + | Dor l -> + Format.fprintf fmt "@[(%a@])" + (format_dexpr_list dgfip_flags ~sep:"||") + l | Dunop (op, de) -> Format.fprintf fmt "@[(%s%a@])" op format_dexpr de - | Dbinop (op, de1, de2) -> begin - match op with - | ">" -> + | Dbinop (op, l) -> begin + match (op, l) with + | ">", [ de1; de2 ] -> Format.fprintf fmt "@[(GT_E((%a),(%a))@])" format_dexpr de1 format_dexpr de2 - | "<" -> + | "<", [ de1; de2 ] -> Format.fprintf fmt "@[(LT_E((%a),(%a))@])" format_dexpr de1 format_dexpr de2 - | ">=" -> + | ">=", [ de1; de2 ] -> Format.fprintf fmt "@[(GE_E((%a),(%a))@])" format_dexpr de1 format_dexpr de2 - | "<=" -> + | "<=", [ de1; de2 ] -> Format.fprintf fmt "@[(LE_E((%a),(%a))@])" format_dexpr de1 format_dexpr de2 - | "==" -> + | "==", [ de1; de2 ] -> Format.fprintf fmt "@[(EQ_E((%a),(%a))@])" format_dexpr de1 format_dexpr de2 - | "!=" -> + | "!=", [ de1; de2 ] -> Format.fprintf fmt "@[(NEQ_E((%a),(%a))@])" format_dexpr de1 format_dexpr de2 | _ -> - Format.fprintf fmt "@[((%a)@ %s (%a)@])" format_dexpr de1 op - format_dexpr de2 + Format.fprintf fmt "@[(%a@])" + (format_dexpr_list dgfip_flags ~sep:op) + l end | Dfun (funname, des) -> Format.fprintf fmt "@[%s(%a@])" funname diff --git a/src/mlang/m_frontend/expander.ml b/src/mlang/m_frontend/expander.ml index c3a3adda8..6ddae3766 100644 --- a/src/mlang/m_frontend/expander.ml +++ b/src/mlang/m_frontend/expander.ml @@ -635,10 +635,9 @@ and expand_expression (const_map : const_context) (loop_map : loop_context) let e1' = expand_expression const_map loop_map e1 in let e2' = expand_expression const_map loop_map e2 in Pos.same (Comparison (op, e1', e2')) m_expr - | Binop (op, e1, e2) -> - let e1' = expand_expression const_map loop_map e1 in - let e2' = expand_expression const_map loop_map e2 in - Pos.same (Binop (op, e1', e2')) m_expr + | Binop (op, l) -> + let l' = List.map (expand_expression const_map loop_map) l in + Pos.same (Binop (op, l')) m_expr | Unop (op, e) -> let e' = expand_expression const_map loop_map e in Pos.same (Unop (op, e')) m_expr @@ -678,7 +677,7 @@ and expand_expression (const_map : const_context) (loop_map : loop_context) let loop_exprs = loop_context_provider translator in List.fold_left (fun res loop_expr -> - Pos.same (Binop (Pos.same Or m_expr, res, loop_expr)) m_expr) + Pos.same (Binop (Pos.same Or m_expr, [ res; loop_expr ])) m_expr) (Pos.same (Literal (Float 0.0)) m_expr) loop_exprs | Attribut (Pos.Mark (a, a_pos), attr) -> ( diff --git a/src/mlang/m_frontend/mast_to_mir.ml b/src/mlang/m_frontend/mast_to_mir.ml index ea2b26b90..109da597a 100644 --- a/src/mlang/m_frontend/mast_to_mir.ml +++ b/src/mlang/m_frontend/mast_to_mir.ml @@ -553,7 +553,6 @@ let complete_stats ((prog : Validator.program), (stats : Mir.stats)) : | Com.Attribut (Pos.Mark (FieldAccess (_, me, _, _), _), _) -> aux_expr tdata me | Com.Comparison (_, me0, me1) - | Com.Binop (_, me0, me1) | Com.SameVariable ( Pos.Mark (TabAccess (_, _, me0), _), Pos.Mark (TabAccess (_, _, me1), _) ) @@ -569,6 +568,12 @@ let complete_stats ((prog : Validator.program), (stats : Mir.stats)) : let nb0, sz0, nbRef0, tdata = aux_expr tdata me0 in let nb1, sz1, nbRef1, tdata = aux_expr tdata me1 in (max nb0 nb1, max sz0 sz1, max nbRef0 nbRef1, tdata) + | Com.Binop (_, l) -> + let fold (nb, sz, nbRef, tdata) me = + let nb', sz', nbRef', tdata = aux_expr tdata me in + (max nb nb', max sz sz', max nbRef nbRef', tdata) + in + List.fold_left fold (0, 0, 0, tdata) l | Com.Conditional (meI, meT, meEOpt) -> let nbI, szI, nbRefI, tdata = aux_expr tdata meI in let nbT, szT, nbRefT, tdata = aux_expr tdata meT in @@ -647,7 +652,7 @@ let rec translate_expression (p : Validator.program) (dict : Com.Var.t IntMap.t) let new_e1 = translate_expression p dict e1 in let new_e2 = translate_expression p dict e2 in Comparison (op, new_e1, new_e2) - | Binop (op, e1, e2) -> + | Binop (op, l) -> (* if Pos.unmark op = Mast.Mul && (Pos.unmark e1 = Mast.Literal (Float 0.) @@ -657,9 +662,8 @@ let rec translate_expression (p : Validator.program) (dict : Com.Var.t IntMap.t) constant substitutions that could wrongly trigger the warning *) Errors.print_spanned_warning "Nullifying constant multiplication found." (Pos.get f);*) - let new_e1 = translate_expression p dict e1 in - let new_e2 = translate_expression p dict e2 in - Binop (op, new_e1, new_e2) + let new_l = List.map (translate_expression p dict) l in + Binop (op, new_l) | Unop (op, e) -> let new_e = translate_expression p dict e in Unop (op, new_e) diff --git a/src/mlang/m_frontend/mparser.mly b/src/mlang/m_frontend/mparser.mly index 51f38dbe8..023518401 100644 --- a/src/mlang/m_frontend/mparser.mly +++ b/src/mlang/m_frontend/mparser.mly @@ -25,6 +25,15 @@ along with this program. If not, see . | CompSubTyp of string Pos.marked | Attr of variable_attribute + let binop op e e' = + match Pos.unmark op with + | Com.Add | Com.Mul | Com.And | Com.Or -> ( + match Pos.unmark e, Pos.unmark e' with + | _, Com.Binop (op', l) when op = op' -> Com.Binop (op, l @ [e]) + | Com.Binop (op', l), _ when op = op' -> Com.Binop (op, l @ [e']) + | _ -> Com.Binop (op, [e; e']) + ) + | _ -> Com.Binop (op, [e; e']) (** Module generated automaticcaly by Menhir, the parser generator *) %} @@ -1385,7 +1394,7 @@ expression: | e1 = with_pos(expression) op = with_pos(logical_binop) e2 = with_pos(expression) { - Binop (op, e1, e2) + binop op e1 e2 } | FOR le = loop_expression { let l1, l2 = le in Loop (l1, l2) } | NOT e = with_pos(expression) { Unop (Not, e) } @@ -1399,7 +1408,7 @@ sum_expression: | e1 = with_pos(sum_expression) op = with_pos(sum_operator) e2 = with_pos(product_expression) { - Com.Binop (op, e1, e2) + binop op e1 e2 } %inline sum_operator: @@ -1411,7 +1420,7 @@ product_expression: | e1 = with_pos(product_expression) op = with_pos(product_operator) e2 = with_pos(factor) { - Com.Binop (op, e1, e2) + binop op e1 e2 } %inline product_operator: diff --git a/src/mlang/m_frontend/validator.ml b/src/mlang/m_frontend/validator.ml index 11d88823b..4b21ddef3 100644 --- a/src/mlang/m_frontend/validator.ml +++ b/src/mlang/m_frontend/validator.ml @@ -1276,9 +1276,7 @@ let rec fold_var_expr (get_var : 'v -> string Pos.marked) | Comparison (_op, e1, e2) -> let acc = fold_aux acc e1 env in fold_aux acc e2 env - | Binop (_op, e1, e2) -> - let acc = fold_aux acc e1 env in - fold_aux acc e2 env + | Binop (_op, l) -> List.fold_left (fun acc e -> fold_aux acc e env) acc l | Unop (_op, e) -> fold_aux acc e env | Conditional (e1, e2, e3_opt) -> ( let acc = fold_aux acc e1 env in @@ -3149,41 +3147,54 @@ let eval_expr_verif (prog : program) (verif : verif) | Lte -> Some (if f0 <= f1 then 1.0 else 0.0) | Eq -> Some (if f0 = f1 then 1.0 else 0.0) | Neq -> Some (if f0 <> f1 then 1.0 else 0.0))) - | Binop (op, e0, e1) -> ( - let r0 = aux e0 in - let r1 = aux e1 in - match Pos.unmark op with - | Com.And -> ( - match r0 with - | None -> None - | Some f0 -> if f0 = 0.0 then r0 else r1) - | Com.Or -> ( - match r0 with None -> r1 | Some f0 -> if f0 = 0.0 then r1 else r0) - | Com.Add -> ( - match (r0, r1) with - | None, None -> None - | None, Some _ -> r1 - | Some _, None -> r0 - | Some f0, Some f1 -> Some (f0 +. f1)) - | Com.Sub -> ( - match (r0, r1) with - | None, None -> None - | None, Some _ -> r1 - | Some _, None -> r0 - | Some f0, Some f1 -> Some (f0 +. f1)) - | Com.Mul -> ( - match (r0, r1) with - | None, _ | _, None -> None - | Some f0, Some f1 -> Some (f0 *. f1)) - | Com.Div -> ( - match (r0, r1) with - | None, _ | _, None -> None - | Some f0, Some f1 -> if f1 = 0.0 then r1 else Some (f0 /. f1)) - | Com.Mod -> ( - match (r0, r1) with - | None, _ | _, None -> None - | Some f0, Some f1 -> - if f1 = 0.0 then r1 else Some (mod_float f0 f1))) + | Binop (op, l) -> ( + let simp_pair = + match Pos.unmark op with + | Com.And -> ( + fun r0 r1 -> + match r0 with + | None -> None + | Some f0 -> if f0 = 0.0 then r0 else r1) + | Com.Or -> ( + fun r0 r1 -> + match r0 with + | None -> r1 + | Some f0 -> if f0 = 0.0 then r1 else r0) + | Com.Add -> ( + fun r0 r1 -> + match (r0, r1) with + | None, None -> None + | None, Some _ -> r1 + | Some _, None -> r0 + | Some f0, Some f1 -> Some (f0 +. f1)) + | Com.Sub -> ( + fun r0 r1 -> + match (r0, r1) with + | None, None -> None + | None, Some _ -> r1 + | Some _, None -> r0 + | Some f0, Some f1 -> Some (f0 +. f1)) + | Com.Mul -> ( + fun r0 r1 -> + match (r0, r1) with + | None, _ | _, None -> None + | Some f0, Some f1 -> Some (f0 *. f1)) + | Com.Div -> ( + fun r0 r1 -> + match (r0, r1) with + | None, _ | _, None -> None + | Some f0, Some f1 -> if f1 = 0.0 then r1 else Some (f0 /. f1)) + | Com.Mod -> ( + fun r0 r1 -> + match (r0, r1) with + | None, _ | _, None -> None + | Some f0, Some f1 -> + if f1 = 0.0 then r1 else Some (mod_float f0 f1)) + in + match l with + | [] -> None + | hd :: tl -> + List.fold_left (fun r e -> simp_pair r (aux e)) (aux hd) tl) | Conditional (e0, e1, e2) -> ( let r0 = aux e0 in let r1 = aux e1 in diff --git a/src/mlang/m_ir/com.ml b/src/mlang/m_ir/com.ml index 5e3db3e24..14efdc654 100644 --- a/src/mlang/m_ir/com.ml +++ b/src/mlang/m_ir/com.ml @@ -508,7 +508,7 @@ and 'v expression = flag is set to [false]) *) | Unop of unop * 'v m_expression | Comparison of comp_op Pos.marked * 'v m_expression * 'v m_expression - | Binop of binop Pos.marked * 'v m_expression * 'v m_expression + | Binop of binop Pos.marked * 'v m_expression list | Conditional of 'v m_expression * 'v m_expression * 'v m_expression option | FuncCall of func Pos.marked * 'v m_expression list | FuncCallLoop of @@ -735,10 +735,9 @@ and expr_map_var f = function let m_e0' = m_expr_map_var f m_e0 in let m_e1' = m_expr_map_var f m_e1 in Comparison (op, m_e0', m_e1') - | Binop (op, m_e0, m_e1) -> - let m_e0' = m_expr_map_var f m_e0 in - let m_e1' = m_expr_map_var f m_e1 in - Binop (op, m_e0', m_e1') + | Binop (op, l) -> + let l' = List.map (m_expr_map_var f) l in + Binop (op, l') | Conditional (m_e0, m_e1, m_e2_opt) -> let m_e0' = m_expr_map_var f m_e0 in let m_e1' = m_expr_map_var f m_e1 in @@ -964,8 +963,7 @@ and expr_fold_var f e acc = | Unop (_, m_e0) -> m_expr_fold_var f m_e0 acc | Comparison (_, m_e0, m_e1) -> acc |> m_expr_fold_var f m_e0 |> m_expr_fold_var f m_e1 - | Binop (_, m_e0, m_e1) -> - acc |> m_expr_fold_var f m_e0 |> m_expr_fold_var f m_e1 + | Binop (_, l) -> List.fold_left (fun acc e -> m_expr_fold_var f e acc) acc l | Conditional (m_e0, m_e1, m_e2_opt) -> acc |> m_expr_fold_var f m_e0 |> m_expr_fold_var f m_e1 |> fold_opt (m_expr_fold_var f) m_e2_opt @@ -1242,9 +1240,12 @@ let rec format_expression form_var fmt = | Comparison (op, e1, e2) -> Format.fprintf fmt "(%a %a %a)" form_expr (Pos.unmark e1) format_comp_op (Pos.unmark op) form_expr (Pos.unmark e2) - | Binop (op, e1, e2) -> - Format.fprintf fmt "(%a %a %a)" form_expr (Pos.unmark e1) format_binop - (Pos.unmark op) form_expr (Pos.unmark e2) + | Binop (op, l) -> + Format.pp_print_list + ~pp_sep:(fun fmt _ -> + Format.fprintf fmt "%a" format_binop (Pos.unmark op)) + (fun fmt e -> Format.fprintf fmt "%a" form_expr (Pos.unmark e)) + fmt l | Unop (op, e) -> Format.fprintf fmt "%a %a" format_unop op form_expr (Pos.unmark e) | Conditional (e1, e2, e3) -> diff --git a/src/mlang/m_ir/com.mli b/src/mlang/m_ir/com.mli index 25ba1f587..1fe04ce60 100644 --- a/src/mlang/m_ir/com.mli +++ b/src/mlang/m_ir/com.mli @@ -304,7 +304,7 @@ and 'v expression = flag is set to [false]) *) | Unop of unop * 'v m_expression | Comparison of comp_op Pos.marked * 'v m_expression * 'v m_expression - | Binop of binop Pos.marked * 'v m_expression * 'v m_expression + | Binop of binop Pos.marked * 'v m_expression list | Conditional of 'v m_expression * 'v m_expression * 'v m_expression option | FuncCall of func Pos.marked * 'v m_expression list | FuncCallLoop of diff --git a/src/mlang/m_ir/mir.ml b/src/mlang/m_ir/mir.ml index d1c6c5049..745f542b8 100644 --- a/src/mlang/m_ir/mir.ml +++ b/src/mlang/m_ir/mir.ml @@ -133,10 +133,9 @@ let rec expand_functions_expr (p : program) (e : 'var Com.expression Pos.marked) let new_e1 = expand_functions_expr p e1 in let new_e2 = expand_functions_expr p e2 in Pos.same (Comparison (op, new_e1, new_e2)) e - | Binop (op, e1, e2) -> - let new_e1 = expand_functions_expr p e1 in - let new_e2 = expand_functions_expr p e2 in - Pos.same (Binop (op, new_e1, new_e2)) e + | Binop (op, l) -> + let l' = List.map (expand_functions_expr p) l in + Pos.same (Binop (op, l')) e | Unop (op, e1) -> let new_e1 = expand_functions_expr p e1 in Pos.same (Unop (op, new_e1)) e @@ -159,8 +158,7 @@ let rec expand_functions_expr (p : program) (e : 'var Com.expression Pos.marked) Some (Binop ( Pos.same Com.Add e, - Pos.same acc e, - expand_functions_expr p arg ))) + [ Pos.same acc e; expand_functions_expr p arg ] ))) None args in let expr = @@ -229,7 +227,9 @@ let rec expand_functions_expr (p : program) (e : 'var Com.expression Pos.marked) | None -> Some (Pos.same e'' e) | Some m_e' -> Some - (Pos.same (Binop (Pos.same Com.Or e, m_e', Pos.same e'' e)) e) + (Pos.same + (Binop (Pos.same Com.Or e, [ m_e'; Pos.same e'' e ])) + e) in Option.get @@ Com.CatVar.Map.fold fold cvm None | NbAnomalies | NbDiscordances | NbInformatives | NbBloquantes diff --git a/src/mlang/m_ir/mir_interpreter.ml b/src/mlang/m_ir/mir_interpreter.ml index 26aa03eb5..04f22809c 100644 --- a/src/mlang/m_ir/mir_interpreter.ml +++ b/src/mlang/m_ir/mir_interpreter.ml @@ -568,6 +568,11 @@ struct | Or, Number i1, Number i2 -> Number (real_of_bool (bool_of_real i1 || bool_of_real i2)) in + let binop_list op l = + match l with + | [] -> assert false + | e :: tl -> List.fold_left (fun acc e' -> binop op acc e') e tl + in let out = try match Pos.unmark e with @@ -603,10 +608,9 @@ struct let value1 = evaluate_expr ctx e1 in let value2 = evaluate_expr ctx e2 in comparison (Pos.unmark op) value1 value2 - | Binop (op, e1, e2) -> - let value1 = evaluate_expr ctx e1 in - let value2 = evaluate_expr ctx e2 in - binop (Pos.unmark op) value1 value2 + | Binop (op, l) -> + let values = List.map (evaluate_expr ctx) l in + binop_list (Pos.unmark op) values | Unop (op, e1) -> unop op @@ evaluate_expr ctx e1 | Conditional (e1, e2, e3_opt) -> ( match evaluate_expr ctx e1 with