The unpac monorepo manager self-hosting as a monorepo using unpac
Merge pull request #13878 from lthls/fix-clambda-eval-order
Track mutability of Cmm variables
authored by
Vincent Laviron
and committed by
GitHub
63328807
8f7c58f8
+200
-59
+5
.depend
+5
.depend
···
2995
2995
asmcomp/cmm_invariants.cmo : \
2996
2996
utils/numbers.cmi \
2997
2997
asmcomp/cmm.cmi \
2998
+
middle_end/backend_var.cmi \
2998
2999
asmcomp/cmm_invariants.cmi
2999
3000
asmcomp/cmm_invariants.cmx : \
3000
3001
utils/numbers.cmx \
3001
3002
asmcomp/cmm.cmx \
3003
+
middle_end/backend_var.cmx \
3002
3004
asmcomp/cmm_invariants.cmi
3003
3005
asmcomp/cmm_invariants.cmi : \
3004
3006
asmcomp/cmm.cmi
···
10595
10597
parsing/location.cmi \
10596
10598
lambda/lambda.cmi \
10597
10599
lambda/debuginfo.cmi \
10600
+
asmcomp/cmm.cmi \
10598
10601
middle_end/backend_var.cmi \
10599
10602
testsuite/tools/parsecmmaux.cmi
10600
10603
testsuite/tools/parsecmmaux.cmx : \
10601
10604
parsing/location.cmx \
10602
10605
lambda/lambda.cmx \
10603
10606
lambda/debuginfo.cmx \
10607
+
asmcomp/cmm.cmx \
10604
10608
middle_end/backend_var.cmx \
10605
10609
testsuite/tools/parsecmmaux.cmi
10606
10610
testsuite/tools/parsecmmaux.cmi : \
10607
10611
parsing/location.cmi \
10608
10612
lambda/debuginfo.cmi \
10613
+
asmcomp/cmm.cmi \
10609
10614
middle_end/backend_var.cmi
10610
10615
otherlibs/dynlink/byte/dynlink.cmo : \
10611
10616
otherlibs/dynlink/dynlink_types.cmi \
+4
Changes
+4
Changes
···
484
484
type annotations.
485
485
(Chris Casinghino, review by Florian Angeletti and Gabriel Scherer)
486
486
487
+
- #13875, #13878: Add dedicated constructor for mutable variable access in
488
+
Cmm to prevent bugs linked to incorrect handling of coeffects.
489
+
(Vincent Laviron, review by Gabriel Scherer)
490
+
487
491
OCaml 5.3.0 (8 January 2025)
488
492
----------------------------
489
493
+1
-1
asmcomp/afl_instrument.ml
+1
-1
asmcomp/afl_instrument.ml
+4
asmcomp/cmm.ml
+4
asmcomp/cmm.ml
···
177
177
| Cconst_float of float * Debuginfo.t
178
178
| Cconst_symbol of string * Debuginfo.t
179
179
| Cvar of Backend_var.t
180
+
| Cvar_mut of Backend_var.t
180
181
| Clet of Backend_var.With_provenance.t * expression * expression
181
182
| Clet_mut of Backend_var.With_provenance.t * machtype
182
183
* expression * expression
···
266
267
| Cconst_float _
267
268
| Cconst_symbol _
268
269
| Cvar _
270
+
| Cvar_mut _
269
271
| Cassign _
270
272
| Ctuple _
271
273
| Cop _
···
303
305
| Cconst_float _
304
306
| Cconst_symbol _
305
307
| Cvar _
308
+
| Cvar_mut _
306
309
| Cassign _
307
310
| Ctuple _
308
311
| Creturn_addr
···
340
343
| Cconst_float _
341
344
| Cconst_symbol _
342
345
| Cvar _
346
+
| Cvar_mut _
343
347
| Creturn_addr
344
348
as c ->
345
349
c
+1
asmcomp/cmm.mli
+1
asmcomp/cmm.mli
···
178
178
| Cconst_float of float * Debuginfo.t
179
179
| Cconst_symbol of string * Debuginfo.t
180
180
| Cvar of Backend_var.t
181
+
| Cvar_mut of Backend_var.t
181
182
| Clet of Backend_var.With_provenance.t * expression * expression
182
183
| Clet_mut of Backend_var.With_provenance.t * machtype
183
184
* expression * expression
+4
-8
asmcomp/cmm_helpers.ml
+4
-8
asmcomp/cmm_helpers.ml
···
32
32
| Cop(Cload _, [Cvar _], _) -> fn arg
33
33
| _ -> bind name arg fn
34
34
35
-
let bind_nonvar name arg fn =
36
-
match arg with
37
-
Cconst_int _ | Cconst_natint _ | Cconst_symbol _ -> fn arg
38
-
| _ -> let id = V.create_local name in Clet(VP.create id, arg, fn (Cvar id))
39
-
40
35
let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8
41
36
(* cf. runtime/caml/gc.h *)
42
37
···
1800
1795
(Clet(
1801
1796
VP.create mi,
1802
1797
Cop(Cor,
1803
-
[Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi], dbg); cconst_int 1],
1798
+
[Cop(Clsr, [Cop(Caddi, [Cvar_mut li; Cvar_mut hi], dbg);
1799
+
cconst_int 1],
1804
1800
dbg);
1805
1801
cconst_int 1],
1806
1802
dbg),
···
1817
1813
dbg, Cassign(li, Cvar mi),
1818
1814
dbg),
1819
1815
Cifthenelse
1820
-
(Cop(Ccmpi Cge, [Cvar li; Cvar hi], dbg),
1816
+
(Cop(Ccmpi Cge, [Cvar_mut li; Cvar_mut hi], dbg),
1821
1817
dbg, Cexit (raise_num, []),
1822
1818
dbg, Ctuple [],
1823
1819
dbg))))
···
1826
1822
dbg),
1827
1823
Clet (
1828
1824
VP.create tagged,
1829
-
Cop(Caddi, [lsl_const (Cvar li) log2_size_addr dbg;
1825
+
Cop(Caddi, [lsl_const (Cvar_mut li) log2_size_addr dbg;
1830
1826
cconst_int(1 - 3 * size_addr)], dbg),
1831
1827
Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg),
1832
1828
Cvar tagged)))))
-4
asmcomp/cmm_helpers.mli
-4
asmcomp/cmm_helpers.mli
···
24
24
val bind_load :
25
25
string -> expression -> (expression -> expression) -> expression
26
26
27
-
(** Same as [bind], but does not treat variables as simple *)
28
-
val bind_nonvar :
29
-
string -> expression -> (expression -> expression) -> expression
30
-
31
27
(** Headers *)
32
28
33
29
(** A null header with GC bits set to black *)
+77
-11
asmcomp/cmm_invariants.ml
+77
-11
asmcomp/cmm_invariants.ml
···
14
14
15
15
[@@@ocaml.warning "-40"]
16
16
17
+
module V = Backend_var
18
+
module VP = Backend_var.With_provenance
17
19
module Int = Numbers.Int
18
20
19
-
(* Check a number of continuation-related invariants *)
21
+
(* Check a number of invariants around continuation and variable uses *)
22
+
23
+
type mutability = Mutable | Immutable
24
+
25
+
let equal_mutability m1 m2 =
26
+
match m1, m2 with
27
+
| Mutable, Mutable | Immutable, Immutable -> true
28
+
| Mutable, Immutable | Immutable, Mutable -> false
29
+
30
+
let mutability_to_string m =
31
+
match m with
32
+
| Mutable -> "mutable"
33
+
| Immutable -> "immutable"
20
34
21
35
module Env : sig
22
36
type t
···
26
40
val handler : t -> cont:int -> arg_num:int -> t
27
41
28
42
val jump : t -> cont:int -> arg_num:int -> unit
43
+
44
+
val bind_var : t -> V.t -> mutability -> t
45
+
46
+
val bind_params : t -> (VP.t * _) list -> t
47
+
48
+
val use_var : t -> V.t -> mutability -> unit
29
49
30
50
val report : Format.formatter -> bool
31
51
end = struct
32
52
type t = {
33
53
bound_handlers : int Int.Map.t;
54
+
bound_variables : mutability V.Map.t;
34
55
}
35
56
36
57
type error =
···
38
59
| Multiple_handlers of { cont: int; }
39
60
| Wrong_arguments_number of
40
61
{ cont: int; handler_args: int; jump_args: int; }
62
+
| Unbound_variable of { var : V.t; mut : mutability }
63
+
| Wrong_mutability of
64
+
{ var : V.t; binding_mut : mutability; use_mut : mutability }
41
65
42
66
module Error = struct
43
67
type t = error
···
74
98
state.errors <- ErrorSet.empty;
75
99
{
76
100
bound_handlers = Int.Map.empty;
101
+
bound_variables = V.Map.empty;
77
102
}
78
103
79
104
let handler t ~cont ~arg_num =
80
105
if Int.Set.mem cont state.all_handlers then multiple_handler cont;
81
106
state.all_handlers <- Int.Set.add cont state.all_handlers;
82
107
let bound_handlers = Int.Map.add cont arg_num t.bound_handlers in
83
-
{ bound_handlers; }
108
+
{ t with bound_handlers; }
84
109
85
110
let jump t ~cont ~arg_num =
86
111
match Int.Map.find cont t.bound_handlers with
···
89
114
wrong_arguments cont handler_args arg_num
90
115
| exception Not_found -> unbound_handler cont
91
116
117
+
let bind_var t var mut =
118
+
let bound_variables = V.Map.add var mut t.bound_variables in
119
+
{ t with bound_variables }
120
+
121
+
let bind_params t params =
122
+
let bound_variables =
123
+
List.fold_left (fun bound_vars (var, _) ->
124
+
V.Map.add (VP.var var) Immutable bound_vars)
125
+
t.bound_variables params
126
+
in
127
+
{ t with bound_variables }
128
+
129
+
let use_var t var use_mut =
130
+
match V.Map.find_opt var t.bound_variables with
131
+
| Some binding_mut ->
132
+
if equal_mutability use_mut binding_mut
133
+
then ()
134
+
else record_error (Wrong_mutability { var; binding_mut; use_mut })
135
+
| None ->
136
+
record_error (Unbound_variable { var; mut = use_mut })
137
+
92
138
let print_error ppf error =
93
139
match error with
94
140
| Unbound_handler { cont } ->
···
110
156
cont
111
157
handler_args
112
158
jump_args
159
+
| Unbound_variable { var; mut } ->
160
+
Format.fprintf ppf
161
+
"Variable %a (%s) was unbound or used outside the scope of its binder"
162
+
V.print var (mutability_to_string mut)
163
+
| Wrong_mutability { var; binding_mut; use_mut } ->
164
+
Format.fprintf ppf
165
+
"Variable %a was bound as %s but used as %s"
166
+
V.print var
167
+
(mutability_to_string binding_mut)
168
+
(mutability_to_string use_mut)
113
169
114
170
let print_error_newline ppf error =
115
171
Format.fprintf ppf "%a@." print_error error
···
125
181
let rec check env (expr : Cmm.expression) =
126
182
match expr with
127
183
| Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _
128
-
| Cvar _ | Creturn_addr ->
184
+
| Creturn_addr ->
129
185
()
130
-
| Clet (_, expr, body)
131
-
| Clet_mut (_, _, expr, body) ->
186
+
| Cvar id ->
187
+
Env.use_var env id Immutable
188
+
| Cvar_mut id ->
189
+
Env.use_var env id Mutable
190
+
| Clet (id, expr, body) ->
191
+
check env expr;
192
+
check (Env.bind_var env (VP.var id) Immutable) body
193
+
| Clet_mut (id, _, expr, body) ->
132
194
check env expr;
133
-
check env body
195
+
check (Env.bind_var env (VP.var id) Mutable) body
134
196
| Cphantom_let (_, _, expr) ->
135
197
check env expr
136
-
| Cassign (_, expr) ->
198
+
| Cassign (id, expr) ->
199
+
Env.use_var env id Mutable;
137
200
check env expr
138
201
| Ctuple exprs ->
139
202
List.iter (check env) exprs
···
163
226
| Recursive -> env_extended
164
227
| Nonrecursive -> env
165
228
in
166
-
List.iter (fun (_, _, handler, _) -> check env_handler handler) handlers
229
+
List.iter (fun (_, args, handler, _) ->
230
+
let env_handler = Env.bind_params env_handler args in
231
+
check env_handler handler)
232
+
handlers
167
233
| Cexit (cont, args) ->
168
234
Env.jump env ~cont ~arg_num:(List.length args)
169
-
| Ctrywith (body, _, handler, _) ->
235
+
| Ctrywith (body, id, handler, _) ->
170
236
(* Jumping from inside a trywith body to outside isn't very nice,
171
237
but it's handled correctly by Linearize, as it happens
172
238
when compiling match ... with exception ..., for instance, so it is
173
239
not reported as an error. *)
174
240
check env body;
175
-
check env handler
241
+
check (Env.bind_var env (VP.var id) Immutable) handler
176
242
177
243
let run ppf (fundecl : Cmm.fundecl) =
178
-
let env = Env.init () in
244
+
let env = Env.bind_params (Env.init ()) fundecl.fun_args in
179
245
check env fundecl.fun_body;
180
246
Env.report ppf
+41
-12
asmcomp/cmmgen.ml
+41
-12
asmcomp/cmmgen.ml
···
39
39
40
40
type env = {
41
41
unboxed_ids : (V.t * boxed_number) V.tbl;
42
+
mutable_ids : V.Set.t;
42
43
notify_catch : (Cmm.expression list -> unit) IntMap.t;
43
44
environment_param : V.t option;
44
45
}
···
61
62
let empty_env =
62
63
{
63
64
unboxed_ids = V.empty;
65
+
mutable_ids = V.Set.empty;
64
66
notify_catch = IntMap.empty;
65
67
environment_param = None;
66
68
}
···
77
79
let add_unboxed_id id unboxed_id bn env =
78
80
{ env with
79
81
unboxed_ids = V.add id (unboxed_id, bn) env.unboxed_ids;
82
+
}
83
+
84
+
let is_mutable_id id env =
85
+
V.Set.mem id env.mutable_ids
86
+
87
+
let add_mutable_id id env =
88
+
{ env with
89
+
mutable_ids = V.Set.add id env.mutable_ids;
80
90
}
81
91
82
92
let add_notify_catch n f env =
···
354
364
match e with
355
365
Uvar id ->
356
366
begin match is_unboxed_id id env with
357
-
| None -> Cvar id
358
-
| Some (unboxed_id, bn) -> box_number bn (Cvar unboxed_id)
367
+
| None ->
368
+
if is_mutable_id id env
369
+
then Cvar_mut id
370
+
else Cvar id
371
+
| Some (unboxed_id, bn) ->
372
+
let var =
373
+
if is_mutable_id unboxed_id env
374
+
then Cvar_mut unboxed_id
375
+
else Cvar unboxed_id
376
+
in
377
+
box_number bn var
359
378
end
360
379
| Uconst sc ->
361
380
transl_constant Debuginfo.none sc
···
654
673
let inc = match dir with Upto -> Caddi | Downto -> Csubi in
655
674
let raise_num = next_raise_count () in
656
675
let id_prev = VP.create (V.create_local "*id_prev*") in
676
+
let env = add_mutable_id (VP.var id) env in
657
677
return_unit dbg
658
678
(Clet_mut
659
679
(id, typ_int, transl env low,
660
-
bind_nonvar "bound" (transl env high) (fun high ->
680
+
bind "bound" (transl env high) (fun high ->
661
681
ccatch
662
682
(raise_num, [],
663
683
Cifthenelse
664
-
(Cop(Ccmpi tst, [Cvar (VP.var id); high], dbg),
684
+
(Cop(Ccmpi tst, [Cvar_mut (VP.var id); high], dbg),
665
685
dbg,
666
686
Cexit (raise_num, []),
667
687
dbg,
668
688
create_loop
669
689
(Csequence
670
690
(remove_unit(transl env body),
671
-
Clet(id_prev, Cvar (VP.var id),
691
+
Clet(id_prev, Cvar_mut (VP.var id),
672
692
Csequence
673
693
(Cassign(VP.var id,
674
-
Cop(inc, [Cvar (VP.var id); Cconst_int (2, dbg)],
694
+
Cop(inc, [Cvar_mut (VP.var id);
695
+
Cconst_int (2, dbg)],
675
696
dbg)),
676
697
Cifthenelse
677
698
(Cop(Ccmpi Ceq, [Cvar (VP.var id_prev); high],
···
1238
1259
(* N.B. [body] must still be traversed even if [exp] will never return:
1239
1260
there may be constant closures inside that need lifting out. *)
1240
1261
begin match str, kind with
1241
-
| Immutable, _ -> Clet(id, cexp, transl_body env)
1242
-
| Mutable, Pintval -> Clet_mut(id, typ_int, cexp, transl_body env)
1243
-
| Mutable, _ -> Clet_mut(id, typ_val, cexp, transl_body env)
1262
+
| Immutable, _ ->
1263
+
Clet(id, cexp, transl_body env)
1264
+
| Mutable, Pintval ->
1265
+
Clet_mut(id, typ_int, cexp,
1266
+
transl_body (add_mutable_id (VP.var id) env))
1267
+
| Mutable, _ ->
1268
+
Clet_mut(id, typ_val, cexp,
1269
+
transl_body (add_mutable_id (VP.var id) env))
1244
1270
end
1245
1271
| Boxed (boxed_number, false) ->
1246
1272
let unboxed_id = V.create_local (VP.name id) in
1247
1273
let v = VP.create unboxed_id in
1248
1274
let cexp = unbox_number dbg boxed_number cexp in
1249
-
let body =
1275
+
let body env =
1250
1276
transl_body (add_unboxed_id (VP.var id) unboxed_id boxed_number env) in
1251
1277
begin match str, boxed_number with
1252
-
| Immutable, _ -> Clet (v, cexp, body)
1253
-
| Mutable, bn -> Clet_mut (v, typ_of_boxed_number bn, cexp, body)
1278
+
| Immutable, _ ->
1279
+
Clet (v, cexp, body env)
1280
+
| Mutable, bn ->
1281
+
Clet_mut (v, typ_of_boxed_number bn, cexp,
1282
+
body (add_mutable_id unboxed_id env))
1254
1283
end
1255
1284
1256
1285
and make_catch ncatch body handler dbg = match body with
+1
asmcomp/printcmm.ml
+1
asmcomp/printcmm.ml
···
168
168
| Cconst_float (n, _dbg) -> fprintf ppf "%F" n
169
169
| Cconst_symbol (s, _dbg) -> fprintf ppf "\"%s\"" s
170
170
| Cvar id -> V.print ppf id
171
+
| Cvar_mut id -> fprintf ppf "!%a" V.print id
171
172
| Creturn_addr -> fprintf ppf "return_addr"
172
173
| Clet(id, def, (Clet(_, _, _) as body)) ->
173
174
let print_binding id ppf def =
+5
-4
asmcomp/selectgen.ml
+5
-4
asmcomp/selectgen.ml
···
110
110
| Cconst_symbol _ ->
111
111
Arch.size_addr
112
112
| Cconst_float _ -> Arch.size_float
113
-
| Cvar id ->
113
+
| Cvar id | Cvar_mut id ->
114
114
begin try
115
115
V.Map.find id localenv
116
116
with Not_found ->
···
336
336
List.for_all self#is_simple_expr args
337
337
end
338
338
| Cassign _ | Cifthenelse _ | Cswitch _ | Ccatch _ | Cexit _
339
-
| Ctrywith _ -> false
339
+
| Ctrywith _ | Cvar_mut _ -> false
340
340
341
341
(* Analyses the effects and coeffects of an expression. This is used across
342
342
a whole list of expressions with a view to determining which expressions
···
355
355
match exp with
356
356
| Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _
357
357
| Cvar _ | Creturn_addr -> EC.none
358
+
| Cvar_mut _ -> EC.coeffect_only Coeffect.Read_mutable
358
359
| Ctuple el -> EC.join_list_map el self#effects_of
359
360
| Clet (_id, arg, body) | Clet_mut (_id, _, arg, body) ->
360
361
EC.join (self#effects_of arg) (self#effects_of body)
···
605
606
| Creturn_addr ->
606
607
let r = self#regs_for typ_int in
607
608
Some(self#insert_op env Ireturn_addr [||] r)
608
-
| Cvar v ->
609
+
| Cvar v | Cvar_mut v ->
609
610
begin try
610
611
Some(env_find v env)
611
612
with Not_found ->
···
1122
1123
end
1123
1124
| Cop _
1124
1125
| Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _
1125
-
| Cvar _
1126
+
| Cvar _ | Cvar_mut _
1126
1127
| Creturn_addr
1127
1128
| Cassign _
1128
1129
| Ctuple _
+2
-2
asmcomp/thread_sanitizer.ml
+2
-2
asmcomp/thread_sanitizer.ml
···
154
154
| Cconst_natint (_, _)
155
155
| Cconst_float (_, _)
156
156
| Cconst_symbol (_, _)
157
-
| Cvar _ | Ctuple _ | Creturn_addr ) as expr ->
157
+
| Cvar _ | Cvar_mut _ | Ctuple _ | Creturn_addr ) as expr ->
158
158
let id = VP.create (V.create_local "res") in
159
159
Clet (id, expr, Csequence (call_exit, Cvar (VP.var id)))
160
160
in
···
285
285
Cswitch (aux e, cases, handlers, dbg_none)
286
286
(* no instrumentation *)
287
287
| ( Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _
288
-
| Cvar _ | Creturn_addr ) as c ->
288
+
| Cvar _ | Cvar_mut _ | Creturn_addr ) as c ->
289
289
c
290
290
in
291
291
body |> aux |> wrap_entry_exit
+10
testsuite/tests/asmcomp/issue13875.ml
+10
testsuite/tests/asmcomp/issue13875.ml
···
1
+
(* TEST *)
2
+
3
+
let () =
4
+
let o1 = object val x = 123 method get () = x end in
5
+
let o2 = object method get () = 456 end in
6
+
let r = ref o1 in
7
+
let n = (!r)#get (r := o2) in
8
+
(* Order of evaluation here is not really specified or consistent,
9
+
but we want to get either 123 or 456 *)
10
+
assert (n = 123 || n = 456)
+8
testsuite/tests/basic/eval_order_9.ml
+8
testsuite/tests/basic/eval_order_9.ml
+1
testsuite/tests/basic/eval_order_9.reference
+1
testsuite/tests/basic/eval_order_9.reference
···
1
+
Ok
+6
-6
testsuite/tools/parsecmm.mly
+6
-6
testsuite/tools/parsecmm.mly
···
191
191
| /**/ { [] }
192
192
;
193
193
oneparam:
194
-
IDENT COLON machtype { (bind_ident $1, $3) }
194
+
IDENT COLON machtype { (bind_ident $1 Immutable, $3) }
195
195
;
196
196
machtype:
197
197
UNIT { [||] }
···
211
211
INTCONST { Cconst_int ($1, debuginfo ()) }
212
212
| FLOATCONST { Cconst_float (float_of_string $1, debuginfo ()) }
213
213
| STRING { Cconst_symbol ($1, debuginfo ()) }
214
-
| IDENT { Cvar(find_ident $1) }
214
+
| IDENT { find_ident $1 }
215
215
| LBRACKET RBRACKET { Ctuple [] }
216
216
| LPAREN LET letdef sequence RPAREN { make_letdef $3 $4 }
217
217
| LPAREN LETMUT letmutdef sequence RPAREN { make_letmutdef $3 $4 }
218
-
| LPAREN ASSIGN IDENT expr RPAREN { Cassign(find_ident $3, $4) }
218
+
| LPAREN ASSIGN IDENT expr RPAREN { Cassign(find_mut_ident $3, $4) }
219
219
| LPAREN APPLY location expr exprlist machtype RPAREN
220
220
{ Cop(Capply $6, $4 :: List.rev $5, debuginfo ?loc:$3 ()) }
221
221
| LPAREN EXTCALL STRING exprlist machtype RPAREN
···
304
304
| oneletdef letdefmult { $1 :: $2 }
305
305
;
306
306
oneletdef:
307
-
IDENT expr { (bind_ident $1, $2) }
307
+
IDENT expr { (bind_ident $1 Immutable, $2) }
308
308
;
309
309
letmutdef:
310
310
oneletmutdef { [$1] }
···
315
315
| oneletmutdef letmutdefmult { $1 :: $2 }
316
316
;
317
317
oneletmutdef:
318
-
IDENT machtype expr { (bind_ident $1, $2, $3) }
318
+
IDENT machtype expr { (bind_ident $1 Mutable, $2, $3) }
319
319
;
320
320
chunk:
321
321
UNSIGNED BYTE { Byte_unsigned }
···
396
396
| CASE INTCONST COLON { [$2] }
397
397
;
398
398
bind_ident:
399
-
IDENT { bind_ident $1 }
399
+
IDENT { bind_ident $1 Immutable }
400
400
;
401
401
datadecl:
402
402
LPAREN datalist RPAREN { List.rev $2 }
+23
-8
testsuite/tools/parsecmmaux.ml
+23
-8
testsuite/tools/parsecmmaux.ml
···
16
16
(* Auxiliary functions for parsing *)
17
17
18
18
type error =
19
-
Unbound of string
19
+
| Unbound of string
20
+
| Immutable_used_as_mutable of string
20
21
21
22
exception Error of error
22
23
23
-
let tbl_ident = (Hashtbl.create 57 : (string, Backend_var.t) Hashtbl.t)
24
+
type mutability = Immutable | Mutable
25
+
26
+
let tbl_ident : (string, (Backend_var.t * mutability)) Hashtbl.t =
27
+
Hashtbl.create 57
24
28
let tbl_label = (Hashtbl.create 57 : (string, int) Hashtbl.t)
25
29
26
30
let ident_name s =
···
28
32
| exception Not_found -> s
29
33
| n -> String.sub s 0 n
30
34
31
-
let bind_ident s =
35
+
let bind_ident s mut =
32
36
let id = Backend_var.create_local (ident_name s) in
33
-
Hashtbl.add tbl_ident s id;
37
+
Hashtbl.add tbl_ident s (id, mut);
34
38
Backend_var.With_provenance.create id
35
39
36
40
let find_ident s =
37
-
try
38
-
Hashtbl.find tbl_ident s
39
-
with Not_found ->
41
+
match Hashtbl.find tbl_ident s with
42
+
| exception Not_found ->
43
+
raise(Error(Unbound s))
44
+
| id, Immutable -> Cmm.Cvar id
45
+
| id, Mutable -> Cmm.Cvar_mut id
46
+
47
+
let find_mut_ident s =
48
+
match Hashtbl.find tbl_ident s with
49
+
| exception Not_found ->
40
50
raise(Error(Unbound s))
51
+
| _, Immutable -> raise(Error(Immutable_used_as_mutable s))
52
+
| id, Mutable -> id
41
53
42
54
let unbind_ident id =
43
55
Hashtbl.remove tbl_ident (Backend_var.With_provenance.name id)
···
51
63
lbl
52
64
53
65
let report_error = function
54
-
Unbound s ->
66
+
| Unbound s ->
55
67
prerr_string "Unbound identifier "; prerr_string s; prerr_endline "."
68
+
| Immutable_used_as_mutable s ->
69
+
prerr_string "Identifier bound as immutable used as mutable: ";
70
+
prerr_string s; prerr_endline "."
56
71
57
72
let debuginfo ?(loc=Location.symbol_rloc ()) () =
58
73
Debuginfo.(from_location
+7
-3
testsuite/tools/parsecmmaux.mli
+7
-3
testsuite/tools/parsecmmaux.mli
···
15
15
16
16
(* Auxiliary functions for parsing *)
17
17
18
-
val bind_ident: string -> Backend_var.With_provenance.t
19
-
val find_ident: string -> Backend_var.t
18
+
type mutability = Immutable | Mutable
19
+
20
+
val bind_ident: string -> mutability -> Backend_var.With_provenance.t
21
+
val find_ident: string -> Cmm.expression
22
+
val find_mut_ident: string -> Backend_var.t
20
23
val unbind_ident: Backend_var.With_provenance.t -> unit
21
24
22
25
val find_label: string -> int
···
24
27
val debuginfo: ?loc:Location.t -> unit -> Debuginfo.t
25
28
26
29
type error =
27
-
Unbound of string
30
+
| Unbound of string
31
+
| Immutable_used_as_mutable of string
28
32
29
33
exception Error of error
30
34