Skip to content
This repository was archived by the owner on Jan 30, 2026. It is now read-only.

Commit 4cc9a97

Browse files
StevendeoStevendeo
committed
Séparation de la création du contexte
1 parent 4fa1fca commit 4cc9a97

6 files changed

Lines changed: 246 additions & 15 deletions

File tree

‎dune-project‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@
22

33
(name mlang)
44

5-
(version 186-81-gd54b08dc-dirty)
5+
(version %%VERSION%%)
66

77
(generate_opam_files true)
88

‎src/mlang/mir_interpreter/context.ml‎

Lines changed: 138 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,138 @@
1+
open Types
2+
3+
let update_ctx_with_inputs (ctx : 'a ctx)
4+
(value_inputs : 'a value Com.Var.Map.t) : unit =
5+
(* let value_inputs = *)
6+
(* Com.Var.Map.mapi *)
7+
(* (fun v l -> *)
8+
(* match l with *)
9+
(* | Com.Undefined -> Undefined *)
10+
(* | Com.Float f -> Number (N.of_float_input v f)) *)
11+
(* inputs *)
12+
(* in *)
13+
let default_space =
14+
ctx.ctx_var_spaces.(ctx.ctx_prog.program_var_space_def.vs_id)
15+
in
16+
Com.Var.Map.iter
17+
(fun (var : Com.Var.t) value ->
18+
match Com.Var.cat_var_loc var with
19+
| LocInput -> default_space.input.(Com.Var.loc_idx var) <- value
20+
| LocComputed -> default_space.computed.(Com.Var.loc_idx var) <- value
21+
| LocBase -> default_space.base.(Com.Var.loc_idx var) <- value)
22+
value_inputs
23+
24+
let update_ctx_with_events (ctx : 'a ctx)
25+
(events : ('a value, Com.Var.t) Com.event_value StrMap.t list) : unit =
26+
let nbEvt = List.length events in
27+
let ctx_event_tab = Array.make nbEvt [||] in
28+
let fold idx (evt : ('a value, Com.Var.t) Com.event_value StrMap.t) =
29+
let nbProgFields = StrMap.cardinal ctx.ctx_prog.program_event_fields in
30+
let map = Array.make nbProgFields (Com.Numeric Undefined) in
31+
for id = 0 to nbProgFields - 1 do
32+
let fname = IntMap.find id ctx.ctx_prog.program_event_field_idxs in
33+
let ef = StrMap.find fname ctx.ctx_prog.program_event_fields in
34+
if ef.is_var then
35+
map.(id) <-
36+
Com.RefVar (snd (StrMap.min_binding ctx.ctx_prog.program_vars))
37+
done;
38+
let iter' fname ev =
39+
match StrMap.find_opt fname ctx.ctx_prog.program_event_fields with
40+
| Some ef -> (
41+
match (ev, ef.is_var) with
42+
| Com.Numeric _, false | Com.RefVar _, true -> map.(ef.index) <- ev
43+
| _ -> Errors.raise_error "wrong event field type")
44+
| None -> Errors.raise_error "unknown event field"
45+
in
46+
StrMap.iter iter' evt;
47+
ctx_event_tab.(idx) <- map;
48+
idx + 1
49+
in
50+
ignore (List.fold_left fold 0 events);
51+
(* let max_field_length =
52+
StrMap.fold
53+
(fun s _ r -> max r (String.length s))
54+
ctx.ctx_prog.program_event_fields 0
55+
in
56+
let pp_field fmt s =
57+
let l = String.length s in
58+
Format.fprintf fmt "%s%s" s (String.make (max_field_length - l + 1) ' ')
59+
in
60+
let pp_ev fmt = function
61+
| Com.Numeric Undefined -> Pp.string fmt "indefini"
62+
| Com.Numeric (Number v) -> N.format_t fmt v
63+
| Com.RefVar v -> Pp.string fmt (Com.Var.name_str v)
64+
in
65+
for i = 0 to Array.length ctx_event_tab - 1 do
66+
Format.eprintf "%d@." i;
67+
let map = ctx_event_tab.(i) in
68+
for j = 0 to Array.length map - 1 do
69+
let s = IntMap.find j ctx.ctx_prog.program_event_field_idxs in
70+
Format.eprintf " %a%a@." pp_field s pp_ev map.(j)
71+
done
72+
done;*)
73+
ctx.ctx_events <- [ ctx_event_tab ]
74+
75+
let empty_ctx ?inputs ?events (p : M_ir.Mir.program) : 'a ctx =
76+
let dummy_var = Com.Var.new_ref ~name:(Pos.without "") in
77+
let init_tmp_var _i = { var = dummy_var; value = Undefined } in
78+
let init_ref _i =
79+
{
80+
var = dummy_var;
81+
var_space = p.program_var_space_def;
82+
ref_var = dummy_var;
83+
org = -1;
84+
}
85+
in
86+
let ctx_tab_map =
87+
let init i = IntMap.find i p.program_stats.table_map in
88+
Array.init (IntMap.cardinal p.program_stats.table_map) init
89+
in
90+
let ctx_var_spaces =
91+
let init i =
92+
let vsd = IntMap.find i p.program_var_spaces_idx in
93+
let input =
94+
if Com.CatVar.LocMap.mem Com.CatVar.LocInput vsd.vs_cats then
95+
Array.make p.program_stats.sz_input Undefined
96+
else Array.make 0 Undefined
97+
in
98+
let computed =
99+
if Com.CatVar.LocMap.mem Com.CatVar.LocComputed vsd.vs_cats then
100+
Array.make p.program_stats.sz_computed Undefined
101+
else Array.make 0 Undefined
102+
in
103+
let base =
104+
if Com.CatVar.LocMap.mem Com.CatVar.LocBase vsd.vs_cats then
105+
Array.make p.program_stats.sz_base Undefined
106+
else Array.make 0 Undefined
107+
in
108+
{ input; computed; base }
109+
in
110+
Array.init (IntMap.cardinal p.program_var_spaces_idx) init
111+
in
112+
let res =
113+
{
114+
ctx_prog = p;
115+
ctx_target = snd (StrMap.min_binding p.program_targets);
116+
ctx_var_space = p.program_var_space_def.vs_id;
117+
ctx_var_spaces;
118+
ctx_tmps = Array.init p.program_stats.sz_all_tmps init_tmp_var;
119+
ctx_tmps_org = 0;
120+
ctx_ref = Array.init p.program_stats.nb_all_refs init_ref;
121+
ctx_ref_org = 0;
122+
ctx_tab_map;
123+
ctx_pr_out = { indent = 0; is_newline = true };
124+
ctx_pr_err = { indent = 0; is_newline = true };
125+
ctx_anos = [];
126+
ctx_nb_anos = 0;
127+
ctx_nb_discos = 0;
128+
ctx_nb_infos = 0;
129+
ctx_nb_bloquantes = 0;
130+
ctx_archived_anos = StrSet.empty;
131+
ctx_finalized_anos = [];
132+
ctx_exported_anos = [];
133+
ctx_events = [];
134+
}
135+
in
136+
Option.iter (update_ctx_with_inputs res) inputs;
137+
Option.iter (update_ctx_with_events res) events;
138+
res

‎src/mlang/mir_interpreter/context.mli‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
2+
(** [empty_ctx ?inputs ?events p]
3+
4+
Creates a fresh context for executing the program [p] or expressions within
5+
the context of [p] (for example, with variables declared in [p].
6+
Parameters [inputs] and [events] are required for interpreting the whole
7+
program. *)
8+
val empty_ctx :
9+
?inputs:('a Types.value M_ir.Com.Var.Map.t) ->
10+
?events:('a Types.value, M_ir.Com.Var.t) M_ir.Com.event_value StrMap.t list ->
11+
M_ir.Mir.program -> 'a Types.ctx

‎src/mlang/mir_interpreter/eval.ml‎

Lines changed: 17 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -62,6 +62,11 @@ module Make (N : Mir_number.NumberInterface) (RF : Mir_roundops.RoundOpsFunctor)
6262
| Undefined -> Com.Undefined
6363
| Number f -> Com.Float (N.to_float f)
6464

65+
let literal_event_to_value_event = function
66+
| Com.Numeric Com.Undefined -> Com.Numeric Undefined
67+
| Com.Numeric (Com.Float f) -> Com.Numeric (Number (N.of_float f))
68+
| Com.RefVar v -> Com.RefVar v
69+
6570
let raise_runtime_as_structured (e : run_error) =
6671
match e with
6772
| NanOrInf (v, e) ->
@@ -1006,12 +1011,7 @@ module Make (N : Mir_number.NumberInterface) (RF : Mir_roundops.RoundOpsFunctor)
10061011
in
10071012
ctx.ctx_target <- sav_target
10081013

1009-
let evaluate_program ~inputs ~events (ctx : ctx) : unit =
1010-
let () =
1011-
let value_inputs = Com.Var.Map.map literal_to_value inputs in
1012-
Context.update_ctx_with_inputs ctx value_inputs
1013-
in
1014-
Context.update_ctx_with_events ctx events;
1014+
let evaluate_program (ctx : ctx) : unit =
10151015
try
10161016
let main_target =
10171017
match
@@ -1136,9 +1136,15 @@ let evaluate_program ~(p : Mir.program) ~(inputs : Com.literal Com.Var.Map.t)
11361136
Com.literal Com.Var.Map.t * Com.Error.Set.t =
11371137
prepare_interp sort round_ops;
11381138
let module Interp = (val get_interp sort round_ops : S) in
1139-
let ctx = empty_ctx p in
1139+
let ctx =
1140+
let inputs = Com.Var.Map.map Interp.literal_to_value inputs in
1141+
let events =
1142+
List.map (StrMap.map Interp.literal_event_to_value_event) events
1143+
in
1144+
Context.empty_ctx ~inputs ~events p
1145+
in
11401146
let () =
1141-
try Interp.evaluate_program ~inputs ~events ctx
1147+
try Interp.evaluate_program ctx
11421148
with Interp.InternalRuntimeError (r, _) -> raise (RuntimeError r)
11431149
in
11441150
Format.pp_print_flush Format.std_formatter ();
@@ -1170,6 +1176,8 @@ let evaluate_program ~(p : Mir.program) ~(inputs : Com.literal Com.Var.Map.t)
11701176
let evaluate_expr ~(p : Mir.program) ~(e : Mir.expression Pos.marked)
11711177
~(sort : Config.value_sort) ~(round_ops : Config.round_ops) : Com.literal =
11721178
let module Interp = (val get_interp sort round_ops : S) in
1173-
try Interp.value_to_literal (Interp.evaluate_expr (empty_ctx p) e) with
1179+
try
1180+
Interp.value_to_literal (Interp.evaluate_expr (Context.empty_ctx p) e)
1181+
with
11741182
| Stop_instruction _ -> Undefined
11751183
| Interp.InternalRuntimeError (r, _) -> raise (RuntimeError r)

‎src/mlang/mir_interpreter/eval.mli‎

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
(** Interpretation engine. *)
2+
3+
val exit_on_rte : bool ref
4+
5+
(** {2 Engine builder} *)
6+
7+
(** Builds an intepretation engine from a number interface
8+
({!module: M_ir.Mir_number}) and a rounding strategy
9+
({!module: M_ir.Mir_roundops}). *)
10+
module Make
11+
(N : M_ir.Mir_number.NumberInterface)
12+
(RF : M_ir.Mir_roundops.RoundOpsFunctor) :
13+
Types.S with type custom_float = N.t
14+
15+
(** {2 Engines} *)
16+
17+
(** These modules are instanes of Make with modules defined in
18+
{!module: M_ir.Mir_number} and {!module: M_ir.Mir_roundops}. *)
19+
20+
module FloatDefInterp : Types.S
21+
22+
module FloatMultInterp : Types.S
23+
24+
module FloatMfInterp : Types.S
25+
26+
module MPFRDefInterp : Types.S
27+
28+
module MPFRMultInterp : Types.S
29+
30+
module MPFRMfInterp : Types.S
31+
32+
module BigIntDefInterp : Types.S
33+
34+
module BigIntMultInterp : Types.S
35+
36+
module BigIntMfInterp : Types.S
37+
38+
module IntvDefInterp : Types.S
39+
40+
module IntvMultInterp : Types.S
41+
42+
module IntvMfInterp : Types.S
43+
44+
module RatDefInterp : Types.S
45+
46+
module RatMultInterp : Types.S
47+
48+
module RatMfInterp : Types.S
49+
50+
val evaluate_program :
51+
p:M_ir.Mir.program ->
52+
inputs:M_ir.Com.literal M_ir.Com.Var.Map.t ->
53+
events:(M_ir.Com.literal, M_ir.Com.Var.t) M_ir.Com.event_value StrMap.t list ->
54+
sort:Config.value_sort ->
55+
round_ops:Config.round_ops ->
56+
M_ir.Com.literal M_ir.Com.Var.Map.t * M_ir.Com.Error.Set.t
57+
(** Evaluates a whole program and returns the given back variables, as
58+
well as the set of anomalies.
59+
The evaluation engine is selected from [sort] and [roundops]. *)
60+
61+
val evaluate_expr :
62+
p:M_ir.Mir.program ->
63+
e:M_ir.Mir.expression Pos.marked ->
64+
sort:Config.value_sort ->
65+
round_ops:Config.round_ops ->
66+
M_ir.Com.literal
67+
(** Evaluates a single expression.
68+
The evaluation engine is selected from [sort] and [roundops]. *)

‎src/mlang/mir_interpreter/types.ml‎

Lines changed: 11 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -68,20 +68,26 @@ module type S = sig
6868

6969
exception InternalRuntimeError of run_error * ctx
7070

71+
(** {2 M Evaluation} *)
72+
7173
val evaluate_expr :
7274
ctx -> M_ir.Mir.expression Pos.marked -> custom_float value
7375
(** Evaluates an expression. *)
7476

75-
val evaluate_program :
76-
inputs:Com.literal Com.Var.Map.t ->
77-
events:(Com.literal, Com.Var.t) Com.event_value StrMap.t list ->
78-
ctx ->
79-
unit
77+
val evaluate_program : ctx -> unit
8078
(** Evaluates a whole program. Proper initialisation of inputs and events
8179
is required before calling this function (through [update_ctx_with_inputs]
8280
and [update_ctx_with_events]. *)
8381

82+
(** {2 Helpers} *)
83+
84+
(** These helpers are here for compatibility with {!module: Context}. *)
85+
8486
val literal_to_value : Com.literal -> custom_float value
8587

8688
val value_to_literal : custom_float value -> Com.literal
89+
90+
val literal_event_to_value_event :
91+
(Com.literal, Com.Var.t) Com.event_value ->
92+
(custom_float value, Com.Var.t) Com.event_value
8793
end

0 commit comments

Comments
 (0)