The unpac monorepo manager self-hosting as a monorepo using unpac
fix for a row-arity mismatch in pattern-matching compilation (#10295)
authored by
Gabriel Scherer
and committed by
GitHub
3fb3bd7f
4c484b2b
+56
-3
+3
Changes
+3
Changes
···
268
268
(Xavier Leroy, report by Github user quakerquickoats, review by
269
269
Jeremie Dimino)
270
270
271
+
- #10294, #10295: fix an assert-failure in pattern-matching compilation
272
+
(Gabriel Scherer, report by Nicolás Ojeda Bär)
273
+
271
274
- #10147, #10148: Fix building runtime with GCC on macOS.
272
275
(David Allsopp, report by John Skaller)
273
276
+45
testsuite/tests/basic-more/pr10294.ml
+45
testsuite/tests/basic-more/pr10294.ml
···
1
+
(* TEST *)
2
+
3
+
type import_error = Node of string
4
+
type export_error = Variant of string * string
5
+
6
+
exception Import of import_error
7
+
exception Export of export_error
8
+
(* Pattern-matching analysis and compilation considers that two
9
+
exceptions constructors may be equal (one may be a rebinding of
10
+
the other) as long as they have the same arity, as is the case
11
+
here.
12
+
13
+
The result of splitting on these two exception constructors is what
14
+
we call an "incoherent row", a pattern matrix whose rows have
15
+
incompatible types (one matching on [import_error], the other on
16
+
[export_error]).
17
+
18
+
In the case of the code below, the incoherent row is as follows:
19
+
20
+
(Node _)
21
+
(Variant (_, _))
22
+
23
+
Note that the two constructors [Node] and [Variant] have different
24
+
arities, but the same tag (0).
25
+
26
+
In bug #10924, this causes an assertion-failure in the
27
+
pattern-matching compiler, because a matrix-decomposition
28
+
computation in Default_environment ends up considering that Node
29
+
and Variant are equal, creating a sub-matrix with one wildcard
30
+
pattern in the first row, and two in the second.
31
+
32
+
This is fixed by comparing constructors by more than their tags
33
+
(which is insufficient for incoherent rows).
34
+
*)
35
+
let f = function
36
+
| Import (Node _) ->
37
+
1
38
+
| Export (Variant (_, _)) ->
39
+
2
40
+
| _ ->
41
+
3
42
+
43
+
let () =
44
+
assert (f (Import (Node "foo")) = 1);
45
+
assert (f (Export (Variant ("foo", "bar"))) = 2);
testsuite/tests/basic-more/pr10294.reference
testsuite/tests/basic-more/pr10294.reference
This is a binary file and will not be displayed.
+8
-3
typing/types.ml
+8
-3
typing/types.ml
···
440
440
Path.same path1 path2 && b1 = b2
441
441
| (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false
442
442
443
-
let may_equal_constr c1 c2 = match c1.cstr_tag,c2.cstr_tag with
444
-
| Cstr_extension _,Cstr_extension _ -> c1.cstr_arity = c2.cstr_arity
445
-
| tag1,tag2 -> equal_tag tag1 tag2
443
+
let may_equal_constr c1 c2 =
444
+
c1.cstr_arity = c2.cstr_arity
445
+
&& (match c1.cstr_tag,c2.cstr_tag with
446
+
| Cstr_extension _,Cstr_extension _ ->
447
+
(* extension constructors may be rebindings of each other *)
448
+
true
449
+
| tag1, tag2 ->
450
+
equal_tag tag1 tag2)
446
451
447
452
type label_description =
448
453
{ lbl_name: string; (* Short name *)