[m-rev.] diff: fix obscure MLDS back-end bug

[Fergus Henderson]

Estimated hours taken: 8
Branches: main

Fix a bug where the MLDS back-end was generating incorrect code when you
pass an argument of type `float' to procedure expecting a polymorphically
typed parameter with mode `unused'.

This bug broke the test cases that used `--trace rep' in
tests/debugger/declarative, if you built the compiler with `--target asm',
because the stage 1 compiler got miscompiled.

compiler/ml_call_gen.m:
	Don't unbox arguments that whose mode is top_unused.

tests/hard_coded/Mmakefile:
tests/hard_coded/unused_float_box_test.m:
tests/hard_coded/unused_float_box_test.exp:
	A regression test.

Workspace: /home/mars/fjh/ws1/mercury
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.21
diff -u -d -r1.21 ml_call_gen.m
--- compiler/ml_call_gen.m	2001/05/02 11:36:35	1.21
+++ compiler/ml_call_gen.m	2001/05/26 15:22:51
@@ -637,16 +637,23 @@
 			{ ConvOutputStatements = ConvOutputStatements1 }
 		;
 			%
-			% it's an output argument
+			% it's an output argument, or an unused argument
 			%
 			ml_gen_box_or_unbox_lval(CallerType, CalleeType,
 				VarLval, VarName, Context, ArgLval,
 				ThisArgConvDecls, _ThisArgConvInput,
 				ThisArgConvOutput),
-			{ ConvDecls = list__append(ThisArgConvDecls,
-				ConvDecls1) },
-			{ ConvOutputStatements = list__append(
-				ThisArgConvOutput, ConvOutputStatements1) },
+			{ ConvDecls = ThisArgConvDecls ++ ConvDecls1 },
+			{ ConvOutputStatements =
+				(if ArgMode = top_out then
+					ThisArgConvOutput
+				else
+					% don't unbox arguments
+					% with mode `top_unused'
+					[]
+				)
+				++ ConvOutputStatements1 },
+
 			ml_gen_info_get_globals(Globals),
 			{ CopyOut = get_copy_out_option(Globals, CodeModel) },
 			(
@@ -654,6 +661,10 @@
 					%
 					% if the target language allows
 					% multiple return values, then use them
+					%
+					% XXX for top_unused argument modes,
+					% the generated code will copy an
+					% uninitialized value
 					%
 					{ CopyOut = yes }
 				;
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.116
diff -u -d -r1.116 Mmakefile
--- tests/hard_coded/Mmakefile	2001/05/16 17:28:40	1.116
+++ tests/hard_coded/Mmakefile	2001/05/26 17:02:57
@@ -118,6 +118,7 @@
 	type_qual \
 	type_spec_modes \
 	type_to_term_bug \
+	unused_float_box_test \
 	user_defined_equality \
 	user_defined_equality2 \
 	write \
@@ -191,6 +192,7 @@
 MCFLAGS-existential_float = --infer-all
 MCFLAGS-user_defined_equality	= --infer-all
 MCFLAGS-parse		=	--trace deep
+MCFLAGS-unused_float_box_test =	--infer-all
 
 # In grade `none' with options `-O1 --opt-space' on kryten
 # (a sparc-sun-solaris2.5 system), mode_choice needs to be linked
Index: tests/hard_coded/unused_float_box_test.exp
===================================================================
RCS file: unused_float_box_test.exp
diff -N unused_float_box_test.exp
--- /dev/null	Wed Apr 11 00:52:25 2001
+++ unused_float_box_test.exp	Sun May 27 03:03:31 2001
@@ -0,0 +1 @@
+my_functor_float(42.0000000000000)
Index: tests/hard_coded/unused_float_box_test.m
===================================================================
RCS file: unused_float_box_test.m
diff -N unused_float_box_test.m
--- /dev/null	Wed Apr 11 00:52:25 2001
+++ unused_float_box_test.m	Sun May 27 02:58:50 2001
@@ -0,0 +1,132 @@
+% This is a regression test (extracted from some code in std_util.m).
+% The MLDS back-end in Mercury 0.10.1 generated incorrect code
+% for this test case.  In particular when the float argument is
+% passed to private_builtin__var(T::unused), it generated code
+% which passes a pointer and then tries to unbox the float value returned,
+% even though no value was actually returned, so it ends up dereferencing
+% an uninitialized pointer.
+
+:- module unused_float_box_test.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- import_module std_util.
+
+:- type my_functor_tag_info
+        --->    my_functor_integer(int)
+        ;       my_functor_float(float)
+        ;       my_functor_string(string)
+        ;       my_functor_enum(int)
+        ;       my_functor_local(int, int)
+        ;       my_functor_remote(int, int, list(univ))
+        ;       my_functor_unshared(int, list(univ))
+        ;       my_functor_notag(univ)
+        ;       my_functor_equiv(univ).
+
+:- pred my_get_functor_info(my_univ::in, my_functor_tag_info::out) is semidet.
+
+:- implementation.
+:- import_module list, int.
+
+main -->
+	wipe_stack(200),
+	( { my_get_functor_info('new my_univ_cons'(42.0), R) } ->
+		print(R), nl
+	;
+		print("failed"), nl
+	).
+
+:- pred wipe_stack(int, io__state, io__state).
+wipe_stack(N) -->
+	( if { N =< 0 } then []
+	else wipe_stack(N - 1), wipe_stack(N // 10 - 1)
+	).
+
+:- pragma no_inline(my_get_functor_info/2).
+my_get_functor_info(Univ, FunctorInfo) :-
+    ( my_univ_to_type(Univ, Int) ->
+        FunctorInfo = my_functor_integer(Int)
+    ; my_univ_to_type(Univ, Float) ->
+        FunctorInfo = my_functor_float(Float)
+    ; my_univ_to_type(Univ, String) ->
+        FunctorInfo = my_functor_string(String)
+    ; get_enum_functor_info(Univ, Enum) ->
+        FunctorInfo = my_functor_enum(Enum)
+    ; get_du_functor_info(Univ, Where, Ptag, Sectag, Args) ->
+        ( Where = 0 ->
+            FunctorInfo = my_functor_unshared(Ptag, Args)
+        ; Where > 0 ->
+            FunctorInfo = my_functor_remote(Ptag, Sectag, Args)
+        ;
+            FunctorInfo = my_functor_local(Ptag, Sectag)
+        )
+    ; get_notag_functor_info(Univ, ExpUniv) ->
+        FunctorInfo = my_functor_notag(ExpUniv)
+    ; get_equiv_functor_info(Univ, ExpUniv) ->
+        FunctorInfo = my_functor_equiv(ExpUniv)
+    ;
+        fail
+    ).
+
+:- pred get_notag_functor_info(Univ::in, ExpUniv::out) is semidet.
+
+:- pragma foreign_proc("C", 
+	get_notag_functor_info(_Univ::in, _ExpUniv::out),
+	will_not_call_mercury, "
+{
+	abort();
+}").
+
+    % from the type stored in the univ.)
+:- pred get_equiv_functor_info(Univ::in, ExpUniv::out) is semidet.
+
+:- pragma foreign_proc("C",
+	get_equiv_functor_info(_Univ::in, _ExpUniv::out),
+    will_not_call_mercury, "
+{
+	abort();
+}").
+
+:- pred get_enum_functor_info(Univ::in, Int::out) is semidet.
+
+:- pragma foreign_proc("C",
+	get_enum_functor_info(_Univ::in, _Enum::out),
+	will_not_call_mercury, "
+{
+	abort();
+}").
+
+:- pred get_du_functor_info(my_univ::in, int::out, int::out, int::out,
+    list(univ)::out) is semidet.
+
+:- pragma foreign_proc("C", get_du_functor_info(_Univ::in, _Where::out,
+    _Ptag::out, _Sectag::out, _Args::out), will_not_call_mercury, "
+{
+	abort();
+}").
+
+%------------------------------------------------------------------------------%
+
+:- type my_univ --->
+	some [T] my_univ_cons(T).
+
+my_univ_to_type(Univ, X) :- my_type_to_univ(X, Univ).
+
+:- pred my_type_to_univ(T, my_univ).
+:- pragma promise_pure(my_type_to_univ/2).
+my_type_to_univ(T, Univ) :-
+	(
+		impure private_builtin__var(T),
+		Univ = my_univ_cons(T0),
+		private_builtin__typed_unify(T0, T)
+	;
+		impure private_builtin__var(Univ),
+		Univ0 = 'new my_univ_cons'(T),
+		unsafe_promise_unique(Univ0, Univ)
+	).
+
+%------------------------------------------------------------------------------%
+%------------------------------------------------------------------------------%

-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "I have always known that the pursuit
                                    |  of excellence is a lethal habit"
WWW: <http://www.cs.mu.oz.au/~fjh>  |     -- the last words of T. S. Garp.
--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------