[m-rev.] diff: fix direct_arg tag assignment

[Peter Wang]

Branches: main, 11.07

When a d.u. type has exactly the same number of direct argument functors as
primary tags (minus one if one tag is used for constants), the last direct
argument functor would be assigned the last primary tag.  If there is another
functor in the type, it would be assigned an invalid primary tag (exceeding the
primary tag bits), leading to abnormal behaviour.

compiler/make_tags.m:
	Fix the bug.

tests/hard_coded/Mmakefile:
tests/hard_coded/direct_arg_tags.exp:
tests/hard_coded/direct_arg_tags.m:
	Add test case.

diff --git a/compiler/make_tags.m b/compiler/make_tags.m
index 2c05d78..6b1b1a3 100644
--- a/compiler/make_tags.m
+++ b/compiler/make_tags.m
@@ -340,6 +340,8 @@ assign_unshared_tags(TypeCtor, [Ctor | Ctors], Val, MaxTag, ReservedAddresses,
         assign_shared_remote_tags(TypeCtor, [Ctor | Ctors], MaxTag, 0,
             ReservedAddresses, !CtorTags)
     ;
+        Val =< MaxTag
+    ->
         Tag = maybe_add_reserved_addresses(ReservedAddresses,
             unshared_tag(Val)),
         % We call set instead of det_insert because we don't want types
@@ -348,6 +350,8 @@ assign_unshared_tags(TypeCtor, [Ctor | Ctors], Val, MaxTag, ReservedAddresses,
         map.set(ConsId, Tag, !CtorTags),
         assign_unshared_tags(TypeCtor, Ctors, Val + 1, MaxTag,
             ReservedAddresses, !CtorTags)
+    ;
+        unexpected($module, $pred, "exceeded max tag")
     ).
 
 :- pred assign_shared_remote_tags(type_ctor::in, list(constructor)::in,
@@ -519,8 +523,16 @@ convert_direct_arg_functors_if_suitable(MaxTag, TypeCtor, TypeDefn,
                         !NextTag, !CtorTags),
                     % We prefer to allocate primary tags to direct argument
                     % functors.
+                    (
+                        NonDirectArgFunctors = [],
+                        MaxTagForDirect = MaxTag
+                    ;
+                        NonDirectArgFunctors = [_ | _],
+                        MaxTagForDirect = MaxTag - 1
+                    ),
                     assign_direct_arg_tags(TypeCtor, DirectArgFunctors,
-                        !NextTag, MaxTag, LeftOverDirectArgFunctors, !CtorTags),
+                        !NextTag, MaxTagForDirect, LeftOverDirectArgFunctors,
+                        !CtorTags),
                     assign_unshared_tags(TypeCtor,
                         LeftOverDirectArgFunctors ++ NonDirectArgFunctors,
                         !.NextTag, MaxTag, [], !CtorTags),
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index 2819c4e..3189866 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -64,6 +64,7 @@ ORDINARY_PROGS=	\
 	direct_arg_cyclic1 \
 	direct_arg_intermod1 \
 	direct_arg_parent \
+	direct_arg_tags \
 	disjs_in_switch \
 	division_test \
 	dos \
diff --git a/tests/hard_coded/direct_arg_tags.exp b/tests/hard_coded/direct_arg_tags.exp
new file mode 100644
index 0000000..785005c
--- /dev/null
+++ b/tests/hard_coded/direct_arg_tags.exp
@@ -0,0 +1,15 @@
+direct_arg0(struct(1, 2))
+direct_arg1(struct(1, 2))
+direct_arg2(struct(1, 2))
+direct_arg3(struct(1, 2))
+non_direct_arg(3, 4)
+
+direct_arg0(struct(1, 2))
+direct_arg1(struct(1, 2))
+direct_arg2(struct(1, 2))
+direct_arg3(struct(1, 2))
+direct_arg4(struct(1, 2))
+direct_arg5(struct(1, 2))
+direct_arg6(struct(1, 2))
+direct_arg7(struct(1, 2))
+non_direct_arg(3, 4)
diff --git a/tests/hard_coded/direct_arg_tags.m b/tests/hard_coded/direct_arg_tags.m
new file mode 100644
index 0000000..bac2528
--- /dev/null
+++ b/tests/hard_coded/direct_arg_tags.m
@@ -0,0 +1,73 @@
+%-----------------------------------------------------------------------------%
+% Regression test. The compiler incorrectly assigned all primary tags to direct
+% argument functors, leaving none for other functors remaining in the type.
+
+:- module direct_arg_tags.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module list.
+
+:- type test_2_tag_bits
+    --->    direct_arg0(struct)
+    ;       direct_arg1(struct)
+    ;       direct_arg2(struct)
+    ;       direct_arg3(struct) % should share last primary tag
+    ;       non_direct_arg(int, int).
+
+:- type test_3_tag_bits
+    --->    direct_arg0(struct)
+    ;       direct_arg1(struct)
+    ;       direct_arg2(struct)
+    ;       direct_arg3(struct)
+    ;       direct_arg4(struct)
+    ;       direct_arg5(struct)
+    ;       direct_arg6(struct)
+    ;       direct_arg7(struct) % should share last primary tag
+    ;       non_direct_arg(int, int).
+
+:- type struct
+    --->    struct(int, int).
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+    S = struct(1, 2),
+    L1 = [
+        direct_arg0(S) : test_2_tag_bits,
+        direct_arg1(S),
+        direct_arg2(S),
+        direct_arg3(S),
+        non_direct_arg(3, 4)
+    ],
+    L2 = [
+        direct_arg0(S) : test_3_tag_bits,
+        direct_arg1(S),
+        direct_arg2(S),
+        direct_arg3(S),
+        direct_arg4(S),
+        direct_arg5(S),
+        direct_arg6(S),
+        direct_arg7(S),
+        non_direct_arg(3, 4)
+    ],
+    list.foldl(write_nl, L1, !IO),
+    io.nl(!IO),
+    list.foldl(write_nl, L2, !IO).
+
+:- pred write_nl(T::in, io::di, io::uo) is det.
+
+write_nl(X, !IO) :-
+    io.write(X, !IO),
+    io.nl(!IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et

--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to:       mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions:          mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------