Skip to content

Commit a4cd586

Browse files
riaqnriaqn
authored
flambda-backend: Fix Mode.zap_to_floor BUG (#2392)
1 parent 37d03a9 commit a4cd586

File tree

8 files changed

+87
-128
lines changed

8 files changed

+87
-128
lines changed

‎lambda/translmode.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -24,8 +24,8 @@ let transl_locality_mode_l locality =
2424

2525
let transl_locality_mode_r locality =
2626
(* r mode are for allocations; [optimise_allocations] should have pushed it
27-
to ceil and determined. *)
28-
Locality.check_const locality |> Option.get |> transl_locality_mode
27+
to ceil and determined; here we push it again just to get the constant. *)
28+
Locality.zap_to_ceil locality |> transl_locality_mode
2929

3030
let transl_alloc_mode_l mode =
3131
(* we only take the locality axis *)

‎testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -88,14 +88,14 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
8888
<def>
8989
pattern (test_locations.ml[17,534+8]..test_locations.ml[17,534+11])
9090
Tpat_var "fib"
91-
value_mode global,many,shared
91+
value_mode meet_local,once(0[global,many,global,many]),join_shared(1[shared,shared])
9292
expression (test_locations.ml[17,534+14]..test_locations.ml[19,572+34])
9393
Texp_function
9494
region true
95-
alloc_mode global,many,shared
95+
alloc_mode map_comonadic(regional_to_global)(6[global,many,global,many]),id(7[shared,shared])
9696
[]
9797
Tfunction_cases (test_locations.ml[17,534+14]..test_locations.ml[19,572+34])
98-
alloc_mode global,many,shared
98+
alloc_mode id(2[global,many,global,many]),id(3[shared,shared])
9999
value
100100
[
101101
<case>
@@ -110,11 +110,11 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
110110
<case>
111111
pattern (test_locations.ml[19,572+4]..test_locations.ml[19,572+5])
112112
Tpat_var "n"
113-
value_mode global,many,unique
113+
value_mode meet_global,many ∘ map_comonadic(local_to_regional)(2[global,many,global,many]),join_unique(3[shared,shared])
114114
expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+34])
115115
Texp_apply
116116
apply_mode Tail
117-
locality_mode global
117+
locality_mode proj_areality(10[global,many,global,many])
118118
expression (test_locations.ml[19,572+21]..test_locations.ml[19,572+22])
119119
Texp_ident "Stdlib!.+"
120120
[
@@ -123,7 +123,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
123123
expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+20])
124124
Texp_apply
125125
apply_mode Default
126-
locality_mode global
126+
locality_mode proj_areality(4[global,many,global,many])
127127
expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+12])
128128
Texp_ident "fib"
129129
[
@@ -132,7 +132,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
132132
expression (test_locations.ml[19,572+13]..test_locations.ml[19,572+20])
133133
Texp_apply
134134
apply_mode Default
135-
locality_mode global
135+
locality_mode proj_areality(20[global,many,global,many])
136136
expression (test_locations.ml[19,572+16]..test_locations.ml[19,572+17])
137137
Texp_ident "Stdlib!.-"
138138
[
@@ -151,7 +151,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
151151
expression (test_locations.ml[19,572+23]..test_locations.ml[19,572+34])
152152
Texp_apply
153153
apply_mode Default
154-
locality_mode global
154+
locality_mode proj_areality(4[global,many,global,many])
155155
expression (test_locations.ml[19,572+23]..test_locations.ml[19,572+26])
156156
Texp_ident "fib"
157157
[
@@ -160,7 +160,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
160160
expression (test_locations.ml[19,572+27]..test_locations.ml[19,572+34])
161161
Texp_apply
162162
apply_mode Default
163-
locality_mode global
163+
locality_mode proj_areality(34[global,many,global,many])
164164
expression (test_locations.ml[19,572+30]..test_locations.ml[19,572+31])
165165
Texp_ident "Stdlib!.-"
166166
[

‎testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -88,14 +88,14 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
8888
<def>
8989
pattern
9090
Tpat_var "fib"
91-
value_mode global,many,shared
91+
value_mode meet_local,once(0[global,many,global,many]),join_shared(1[shared,shared])
9292
expression
9393
Texp_function
9494
region true
95-
alloc_mode global,many,shared
95+
alloc_mode map_comonadic(regional_to_global)(6[global,many,global,many]),id(7[shared,shared])
9696
[]
9797
Tfunction_cases
98-
alloc_mode global,many,shared
98+
alloc_mode id(2[global,many,global,many]),id(3[shared,shared])
9999
value
100100
[
101101
<case>
@@ -110,11 +110,11 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
110110
<case>
111111
pattern
112112
Tpat_var "n"
113-
value_mode global,many,unique
113+
value_mode meet_global,many ∘ map_comonadic(local_to_regional)(2[global,many,global,many]),join_unique(3[shared,shared])
114114
expression
115115
Texp_apply
116116
apply_mode Tail
117-
locality_mode global
117+
locality_mode proj_areality(10[global,many,global,many])
118118
expression
119119
Texp_ident "Stdlib!.+"
120120
[
@@ -123,7 +123,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
123123
expression
124124
Texp_apply
125125
apply_mode Default
126-
locality_mode global
126+
locality_mode proj_areality(4[global,many,global,many])
127127
expression
128128
Texp_ident "fib"
129129
[
@@ -132,7 +132,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
132132
expression
133133
Texp_apply
134134
apply_mode Default
135-
locality_mode global
135+
locality_mode proj_areality(20[global,many,global,many])
136136
expression
137137
Texp_ident "Stdlib!.-"
138138
[
@@ -151,7 +151,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
151151
expression
152152
Texp_apply
153153
apply_mode Default
154-
locality_mode global
154+
locality_mode proj_areality(4[global,many,global,many])
155155
expression
156156
Texp_ident "fib"
157157
[
@@ -160,7 +160,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
160160
expression
161161
Texp_apply
162162
apply_mode Default
163-
locality_mode global
163+
locality_mode proj_areality(34[global,many,global,many])
164164
expression
165165
Texp_ident "Stdlib!.-"
166166
[

‎typing/mode.ml

Lines changed: 25 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -1196,10 +1196,9 @@ module Common (Obj : Obj) = struct
11961196

11971197
let equate_exn m0 m1 = assert (equate m0 m1 |> Result.is_ok)
11981198

1199-
let print ?(raw = false) ?verbose () ppf m =
1200-
if raw
1201-
then Solver.print_raw ?verbose obj ppf m
1202-
else Solver.print ?verbose obj ppf m
1199+
let print ?verbose () ppf m = Solver.print ?verbose obj ppf m
1200+
1201+
let print_raw ?verbose () ppf m = Solver.print_raw ?verbose obj ppf m
12031202

12041203
let zap_to_ceil m = with_log (Solver.zap_to_ceil obj m)
12051204

@@ -1401,12 +1400,6 @@ module Comonadic_with_regionality = struct
14011400

14021401
(* override to report the offending axis *)
14031402
let equate a b = try_with_log (equate_from_submode submode_log a b)
1404-
1405-
(** overriding to check per-axis *)
1406-
let check_const m =
1407-
let regionality = Regionality.check_const (regionality m) in
1408-
let linearity = Linearity.check_const (linearity m) in
1409-
regionality, linearity
14101403
end
14111404

14121405
module Comonadic_with_locality = struct
@@ -1692,11 +1685,18 @@ module Value = struct
16921685
let equate_exn m0 m1 =
16931686
match equate m0 m1 with Ok () -> () | Error _ -> invalid_arg "equate_exn"
16941687

1695-
let print ?raw ?verbose () ppf { monadic; comonadic } =
1688+
let print_raw ?verbose () ppf { monadic; comonadic } =
16961689
Format.fprintf ppf "%a,%a"
1697-
(Comonadic.print ?raw ?verbose ())
1690+
(Comonadic.print_raw ?verbose ())
16981691
comonadic
1699-
(Monadic.print ?raw ?verbose ())
1692+
(Monadic.print_raw ?verbose ())
1693+
monadic
1694+
1695+
let print ?verbose () ppf { monadic; comonadic } =
1696+
Format.fprintf ppf "%a,%a"
1697+
(Comonadic.print ?verbose ())
1698+
comonadic
1699+
(Monadic.print ?verbose ())
17001700
monadic
17011701

17021702
let zap_to_floor { comonadic; monadic } =
@@ -1714,11 +1714,6 @@ module Value = struct
17141714
| (uniqueness, ()), (regionality, linearity) ->
17151715
{ regionality; linearity; uniqueness }
17161716

1717-
let check_const { comonadic; monadic } =
1718-
let regionality, linearity = Comonadic.check_const comonadic in
1719-
let uniqueness = Monadic.check_const monadic in
1720-
{ regionality; linearity; uniqueness }
1721-
17221717
let of_const { regionality; linearity; uniqueness } =
17231718
let comonadic = Comonadic.of_const (regionality, linearity) in
17241719
let monadic = Monadic.of_const (uniqueness, ()) in
@@ -1849,7 +1844,7 @@ module Value = struct
18491844
&& Uniqueness.Const.le m0.uniqueness m1.uniqueness
18501845
&& Linearity.Const.le m0.linearity m1.linearity
18511846

1852-
let print ppf m = print () ppf (of_const m)
1847+
let print ppf m = print_raw () ppf (of_const m)
18531848

18541849
let legacy =
18551850
{ regionality = Regionality.Const.legacy;
@@ -1994,11 +1989,18 @@ module Alloc = struct
19941989
let equate_exn m0 m1 =
19951990
match equate m0 m1 with Ok () -> () | Error _ -> invalid_arg "equate_exn"
19961991

1997-
let print ?raw ?verbose () ppf { monadic; comonadic } =
1992+
let print_raw ?verbose () ppf { monadic; comonadic } =
1993+
Format.fprintf ppf "%a,%a"
1994+
(Comonadic.print_raw ?verbose ())
1995+
comonadic
1996+
(Monadic.print_raw ?verbose ())
1997+
monadic
1998+
1999+
let print ?verbose () ppf { monadic; comonadic } =
19982000
Format.fprintf ppf "%a,%a"
1999-
(Comonadic.print ?raw ?verbose ())
2001+
(Comonadic.print ?verbose ())
20002002
comonadic
2001-
(Monadic.print ?raw ?verbose ())
2003+
(Monadic.print ?verbose ())
20022004
monadic
20032005

20042006
let legacy =
@@ -2126,7 +2128,7 @@ module Alloc = struct
21262128
&& Uniqueness.Const.le m0.uniqueness m1.uniqueness
21272129
&& Linearity.Const.le m0.linearity m1.linearity
21282130

2129-
let print ppf m = print () ppf (of_const m)
2131+
let print ppf m = print_raw () ppf (of_const m)
21302132

21312133
let legacy =
21322134
let locality = Locality.Const.legacy in

‎typing/mode_intf.mli

Lines changed: 6 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -83,13 +83,11 @@ module type Common = sig
8383

8484
val newvar_below : ('l * allowed) t -> ('l_ * 'r) t * bool
8585

86+
val print_raw :
87+
?verbose:bool -> unit -> Format.formatter -> ('l * 'r) t -> unit
88+
8689
val print :
87-
?raw:bool ->
88-
?verbose:bool ->
89-
unit ->
90-
Format.formatter ->
91-
('l * 'r) t ->
92-
unit
90+
?verbose:bool -> unit -> Format.formatter -> (allowed * allowed) t -> unit
9391

9492
val zap_to_floor : (allowed * 'r) t -> Const.t
9593

@@ -153,7 +151,7 @@ module type S = sig
153151

154152
val zap_to_legacy : (allowed * 'r) t -> Const.t
155153

156-
val check_const : ('l * 'r) t -> Const.t option
154+
val check_const : (allowed * allowed) t -> Const.t option
157155
end
158156

159157
module Regionality : sig
@@ -259,22 +257,6 @@ module type S = sig
259257
include Allow_disallow with type (_, _, 'd) sided = 'd t list
260258
end
261259

262-
(* some overriding *)
263-
val print :
264-
?raw:bool ->
265-
?verbose:bool ->
266-
unit ->
267-
Format.formatter ->
268-
('l * 'r) t ->
269-
unit
270-
271-
val check_const :
272-
('l * 'r) t ->
273-
( Regionality.Const.t option,
274-
Linearity.Const.t option,
275-
Uniqueness.Const.t option )
276-
modes
277-
278260
val regionality : ('l * 'r) t -> ('l * 'r) Regionality.t
279261

280262
val uniqueness : ('l * 'r) t -> ('l * 'r) Uniqueness.t
@@ -397,16 +379,7 @@ module type S = sig
397379
and type error := error
398380
and type 'd t := 'd t
399381

400-
(* some overriding *)
401-
val print :
402-
?raw:bool ->
403-
?verbose:bool ->
404-
unit ->
405-
Format.formatter ->
406-
('l * 'r) t ->
407-
unit
408-
409-
val check_const : ('l * 'r) t -> Const.Option.t
382+
val check_const : (allowed * allowed) t -> Const.Option.t
410383

411384
val locality : ('l * 'r) t -> ('l * 'r) Locality.t
412385

‎typing/printtyped.ml

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -396,16 +396,16 @@ and expression_extra i ppf x attrs =
396396
attributes i ppf attrs;
397397

398398
and alloc_mode: type l r. _ -> _ -> (l * r) Mode.Alloc.t -> _
399-
= fun i ppf m -> line i ppf "alloc_mode %a\n" (Mode.Alloc.print ()) m
399+
= fun i ppf m -> line i ppf "alloc_mode %a\n" (Mode.Alloc.print_raw ()) m
400400

401401
and alloc_mode_option i ppf m = Option.iter (alloc_mode i ppf) m
402402

403403
and locality_mode i ppf m =
404404
line i ppf "locality_mode %a\n"
405-
(Mode.Locality.print ()) m
405+
(Mode.Locality.print_raw ()) m
406406

407407
and value_mode i ppf m =
408-
line i ppf "value_mode %a\n" (Mode.Value.print ()) m
408+
line i ppf "value_mode %a\n" (Mode.Value.print_raw ()) m
409409

410410
and expression_alloc_mode i ppf (expr, am) =
411411
alloc_mode i ppf am;

0 commit comments

Comments
 (0)