[DGFiP] Update my_arr function

examples/dgfip_c/const.h

@@ -95,7 +95,8 @@ extern void free_erreur();
 #ifdef FLG_OPTIM_MIN_MAX
 
 #define my_floor(a)	(floor_g((a) + 0.000001))
-#define my_arr(a)	(floor_g((a) + 0.50005))
+/*#define my_arr(a)	(floor_g((a) + 0.50005)) *//* Ancienne version (2021) */
+#define my_arr(a)	(((a) < 0.0) ? ceil_g((a) - .50005) : floor_g((a) + .50005))
 
 #else
 
@@ -117,6 +118,7 @@ extern void free_erreur();
 #endif /* FLG_OPTIM_MIN_MAX */
 
 extern double floor_g(double);
+extern double ceil_g(double);
 extern int multimax_def(int, char *);
 extern double multimax(double, double *);
 extern int modulo_def(int, int);

examples/dgfip_c/enchain_static.c.inc

@@ -313,6 +313,15 @@ double floor_g(double a)
   }
 }
 
+double ceil_g(double a)
+{
+  if (fabs(a) <= LONG_MAX) {
+    return ceil(a);
+  } else {
+    return a;
+  }
+}
+
 int multimax_def(int nbopd, char *var)
 {
   int i = 0;

src/mlang/backend_ir/bir_interpreter.ml

@@ -76,6 +76,8 @@ module type S = sig
 
   val var_value_to_var_literal : var_value -> var_literal
 
+  val update_ctx_with_inputs : ctx -> Mir.literal Bir.VariableMap.t -> ctx
+
   type run_error =
     | ErrorValue of string * Pos.t
     | FloatIndex of string * Pos.t
@@ -95,24 +97,27 @@ module type S = sig
   val replace_undefined_with_input_variables :
     Mir.program -> Mir.VariableDict.t -> Mir.program
 
+  val print_output : Bir_interface.bir_function -> ctx -> unit
+
   val raise_runtime_as_structured : run_error -> ctx -> Mir.program -> 'a
+
+  val evaluate_expr : ctx -> Mir.program -> Bir.expression Pos.marked -> value
+
+  val evaluate_program : Bir.program -> ctx -> int -> ctx
 end
 
-module Make (N : Bir_number.NumberInterface) = struct
+module Make (N : Bir_number.NumberInterface) (RF : Bir_roundops.RoundOpsFunctor) =
+struct
   (* Careful : this behavior mimics the one imposed by the original Mlang
      compiler... *)
 
+  module R = RF (N)
+
   type custom_float = N.t
 
-  let truncatef (x : N.t) : N.t = N.floor N.(x +. N.of_float 0.000001)
+  let truncatef (x : N.t) : N.t = R.truncatef x
 
-  (* Careful : rounding in M is done with this arbitrary behavior. We can't use
-     copysign here because [x < zero] is critical to have the correct behavior
-     on -0 *)
-  let roundf (x : N.t) =
-    N.of_int
-      (N.to_int
-         N.(x +. N.of_float (if N.(x < zero ()) then -0.50005 else 0.50005)))
+  let roundf (x : N.t) = R.roundf x
 
   type value = Number of N.t | Undefined
 
@@ -760,95 +765,109 @@ module Make (N : Bir_number.NumberInterface) = struct
       else raise (RuntimeError (e, ctx))
 end
 
-module RegularFloatInterpreter = Make (Bir_number.RegularFloatNumber)
-module MPFRInterpreter = Make (Bir_number.MPFRNumber)
-
 module BigIntPrecision = struct
   let scaling_factor_bits = ref 64
 end
 
-module BigIntInterpreter =
-  Make (Bir_number.BigIntFixedPointNumber (BigIntPrecision))
-module IntervalInterpreter = Make (Bir_number.IntervalNumber)
-module RationalInterpreter = Make (Bir_number.RationalNumber)
+module MainframeLongSize = struct
+  let max_long = ref Int64.max_int
+end
 
-type value_sort =
-  | RegularFloat
-  | MPFR of int
-  | BigInt of int
-  | Interval
-  | Rational
+module FloatDefInterp =
+  Make (Bir_number.RegularFloatNumber) (Bir_roundops.DefaultRoundOps)
+module FloatMultInterp =
+  Make (Bir_number.RegularFloatNumber) (Bir_roundops.MultiRoundOps)
+module FloatMfInterp =
+  Make
+    (Bir_number.RegularFloatNumber)
+    (Bir_roundops.MainframeRoundOps (MainframeLongSize))
+module MPFRDefInterp =
+  Make (Bir_number.MPFRNumber) (Bir_roundops.DefaultRoundOps)
+module MPFRMultInterp =
+  Make (Bir_number.MPFRNumber) (Bir_roundops.MultiRoundOps)
+module MPFRMfInterp =
+  Make
+    (Bir_number.MPFRNumber)
+    (Bir_roundops.MainframeRoundOps (MainframeLongSize))
+module BigIntDefInterp =
+  Make
+    (Bir_number.BigIntFixedPointNumber
+       (BigIntPrecision))
+       (Bir_roundops.DefaultRoundOps)
+module BigIntMultInterp =
+  Make
+    (Bir_number.BigIntFixedPointNumber
+       (BigIntPrecision))
+       (Bir_roundops.MultiRoundOps)
+module BigIntMfInterp =
+  Make
+    (Bir_number.BigIntFixedPointNumber
+       (BigIntPrecision))
+       (Bir_roundops.MainframeRoundOps (MainframeLongSize))
+module IntvDefInterp =
+  Make (Bir_number.IntervalNumber) (Bir_roundops.DefaultRoundOps)
+module IntvMultInterp =
+  Make (Bir_number.IntervalNumber) (Bir_roundops.MultiRoundOps)
+module IntvMfInterp =
+  Make
+    (Bir_number.IntervalNumber)
+    (Bir_roundops.MainframeRoundOps (MainframeLongSize))
+module RatDefInterp =
+  Make (Bir_number.RationalNumber) (Bir_roundops.DefaultRoundOps)
+module RatMultInterp =
+  Make (Bir_number.RationalNumber) (Bir_roundops.MultiRoundOps)
+module RatMfInterp =
+  Make
+    (Bir_number.RationalNumber)
+    (Bir_roundops.MainframeRoundOps (MainframeLongSize))
+
+let get_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : (module S) =
+  match (sort, roundops) with
+  | RegularFloat, RODefault -> (module FloatDefInterp)
+  | RegularFloat, ROMulti -> (module FloatMultInterp)
+  | RegularFloat, ROMainframe _ -> (module FloatMfInterp)
+  | MPFR _, RODefault -> (module MPFRDefInterp)
+  | MPFR _, ROMulti -> (module MPFRMultInterp)
+  | MPFR _, ROMainframe _ -> (module MPFRMfInterp)
+  | BigInt _, RODefault -> (module BigIntDefInterp)
+  | BigInt _, ROMulti -> (module BigIntMultInterp)
+  | BigInt _, ROMainframe _ -> (module BigIntMfInterp)
+  | Interval, RODefault -> (module IntvDefInterp)
+  | Interval, ROMulti -> (module IntvMultInterp)
+  | Interval, ROMainframe _ -> (module IntvMfInterp)
+  | Rational, RODefault -> (module RatDefInterp)
+  | Rational, ROMulti -> (module RatMultInterp)
+  | Rational, ROMainframe _ -> (module RatMfInterp)
+
+let prepare_interp (sort : Cli.value_sort) (roundops : Cli.round_ops) : unit =
+  begin
+    match sort with
+    | MPFR prec -> Mpfr.set_default_prec prec
+    | BigInt prec -> BigIntPrecision.scaling_factor_bits := prec
+    | Interval -> Mpfr.set_default_prec 64
+    | _ -> ()
+  end;
+  match roundops with
+  | ROMainframe long_size ->
+      let max_long =
+        if long_size = 32 then Int64.of_int32 Int32.max_int
+        else if long_size = 64 then Int64.max_int
+        else assert false
+        (* checked when parsing command line *)
+      in
+      MainframeLongSize.max_long := max_long
+  | _ -> ()
 
 let evaluate_program (bir_func : Bir_interface.bir_function) (p : Bir.program)
     (inputs : Mir.literal Bir.VariableMap.t) (code_loc_start_value : int)
-    (sort : value_sort) : unit -> unit =
-  match sort with
-  | RegularFloat ->
-      let ctx =
-        RegularFloatInterpreter.update_ctx_with_inputs
-          RegularFloatInterpreter.empty_ctx inputs
-      in
-      let ctx =
-        RegularFloatInterpreter.evaluate_program p ctx code_loc_start_value
-      in
-      fun () -> RegularFloatInterpreter.print_output bir_func ctx
-  | MPFR prec ->
-      Mpfr.set_default_prec prec;
-      let ctx =
-        MPFRInterpreter.update_ctx_with_inputs MPFRInterpreter.empty_ctx inputs
-      in
-      let ctx = MPFRInterpreter.evaluate_program p ctx code_loc_start_value in
-      fun () -> MPFRInterpreter.print_output bir_func ctx
-  | BigInt prec ->
-      BigIntPrecision.scaling_factor_bits := prec;
-      let ctx =
-        BigIntInterpreter.update_ctx_with_inputs BigIntInterpreter.empty_ctx
-          inputs
-      in
-      let ctx = BigIntInterpreter.evaluate_program p ctx code_loc_start_value in
-      fun () -> BigIntInterpreter.print_output bir_func ctx
-  | Interval ->
-      Mpfr.set_default_prec 64;
-      let ctx =
-        IntervalInterpreter.update_ctx_with_inputs IntervalInterpreter.empty_ctx
-          inputs
-      in
-      let ctx =
-        IntervalInterpreter.evaluate_program p ctx code_loc_start_value
-      in
-      fun () -> IntervalInterpreter.print_output bir_func ctx
-  | Rational ->
-      let ctx =
-        RationalInterpreter.update_ctx_with_inputs RationalInterpreter.empty_ctx
-          inputs
-      in
-      let ctx =
-        RationalInterpreter.evaluate_program p ctx code_loc_start_value
-      in
-      fun () -> RationalInterpreter.print_output bir_func ctx
+    (sort : Cli.value_sort) (roundops : Cli.round_ops) : unit -> unit =
+  prepare_interp sort roundops;
+  let module Interp = (val get_interp sort roundops : S) in
+  let ctx = Interp.update_ctx_with_inputs Interp.empty_ctx inputs in
+  let ctx = Interp.evaluate_program p ctx code_loc_start_value in
+  fun () -> Interp.print_output bir_func ctx
 
 let evaluate_expr (p : Mir.program) (e : Bir.expression Pos.marked)
-    (sort : value_sort) : Mir.literal =
-  let f p e =
-    match sort with
-    | RegularFloat ->
-        RegularFloatInterpreter.value_to_literal
-          (RegularFloatInterpreter.evaluate_expr
-             RegularFloatInterpreter.empty_ctx p e)
-    | MPFR prec ->
-        Mpfr.set_default_prec prec;
-        MPFRInterpreter.value_to_literal
-          (MPFRInterpreter.evaluate_expr MPFRInterpreter.empty_ctx p e)
-    | BigInt prec ->
-        BigIntPrecision.scaling_factor_bits := prec;
-        BigIntInterpreter.value_to_literal
-          (BigIntInterpreter.evaluate_expr BigIntInterpreter.empty_ctx p e)
-    | Interval ->
-        Mpfr.set_default_prec 64;
-        IntervalInterpreter.value_to_literal
-          (IntervalInterpreter.evaluate_expr IntervalInterpreter.empty_ctx p e)
-    | Rational ->
-        RationalInterpreter.value_to_literal
-          (RationalInterpreter.evaluate_expr RationalInterpreter.empty_ctx p e)
-  in
-  f p e
+    (sort : Cli.value_sort) (roundops : Cli.round_ops) : Mir.literal =
+  let module Interp = (val get_interp sort roundops : S) in
+  Interp.value_to_literal (Interp.evaluate_expr Interp.empty_ctx p e)

src/mlang/backend_ir/bir_interpreter.mli

@@ -23,7 +23,7 @@ type var_literal =
   | SimpleVar of Mir.literal
   | TableVar of int * Mir.literal array
 
-(**{1 Instrumentation of he interpreter}*)
+(**{1 Instrumentation of the interpreter}*)
 
 (** The BIR interpreter can be instrumented to record which program locations
     have been executed. *)
@@ -96,6 +96,8 @@ module type S = sig
 
   val var_value_to_var_literal : var_value -> var_literal
 
+  val update_ctx_with_inputs : ctx -> Mir.literal Bir.VariableMap.t -> ctx
+
   (** Interpreter runtime errors *)
   type run_error =
     | ErrorValue of string * Pos.t
@@ -118,41 +120,82 @@ module type S = sig
   (** Before execution of the program, replaces the [undefined] stubs for input
       variables by their true input value *)
 
+  val print_output : Bir_interface.bir_function -> ctx -> unit
+
   val raise_runtime_as_structured : run_error -> ctx -> Mir.program -> 'a
   (** Raises a runtime error with a formatted error message and context *)
+
+  val evaluate_expr : ctx -> Mir.program -> Bir.expression Pos.marked -> value
+
+  val evaluate_program : Bir.program -> ctx -> int -> ctx
 end
 
-module RegularFloatInterpreter : S
+module FloatDefInterp : S
+(** The different interpreters, which combine a representation of numbers and
+    rounding operations. The first part of the name corresponds to the
+    representation of numbers, and is one of the following:
+
+    - Float: "regular" IEE754 floating point numbers
+    - MPFR: arbitrary precision floating-point numbers using MPFR
+    - BigInt: fixed-point numbers
+    - Intv: intervals of two IEEE754 floating-point numbers
+    - Rat: rationals
+
+    The second part indicates the rounding operations to use, and is one of the
+    following:
+
+    - Def: use the default rounding operations, those of the PC/single-thread
+      context
+    - Multi: use the rouding operations of the PC/multi-thread context
+    - Mf: use the rounding operations of the mainframe context *)
+
+module FloatMultInterp : S
+
+module FloatMfInterp : S
+
+module MPFRDefInterp : S
+
+module MPFRMultInterp : S
+
+module MPFRMfInterp : S
+
+module BigIntDefInterp : S
+
+module BigIntMultInterp : S
+
+module BigIntMfInterp : S
+
+module IntvDefInterp : S
+
+module IntvMultInterp : S
 
-module MPFRInterpreter : S
+module IntvMfInterp : S
 
-module BigIntInterpreter : S
+module RatDefInterp : S
 
-module IntervalInterpreter : S
+module RatMultInterp : S
 
-module RationalInterpreter : S
+module RatMfInterp : S
 
 (** {1 Generic interpretation API}*)
 
-(** According on the [value_sort], a specific interpreter will be called with
-    the right kind of floating-point value *)
-type value_sort =
-  | RegularFloat
-  | MPFR of int  (** bitsize of the floats *)
-  | BigInt of int  (** precision of the fixed point *)
-  | Interval
-  | Rational
+val get_interp : Cli.value_sort -> Cli.round_ops -> (module S)
 
 val evaluate_program :
   Bir_interface.bir_function ->
   Bir.program ->
   Mir.literal Bir.VariableMap.t ->
   int ->
-  value_sort ->
+  Cli.value_sort ->
+  Cli.round_ops ->
   unit ->
   unit
 (** Main interpreter function *)
 
 val evaluate_expr :
-  Mir.program -> Bir.expression Pos.marked -> value_sort -> Mir.literal
+  Mir.program ->
+  Bir.expression Pos.marked ->
+  Cli.value_sort ->
+  Cli.round_ops ->
+  Mir.literal
 (** Interprets only an expression *)