[m-dev.] for review: MLDS tag switches

[Fergus Henderson]

On 15-Nov-2000, Fergus Henderson <fjh at cs.mu.OZ.AU> wrote:
> compiler/ml_code_util.m:
> 	Split the code for generating secondary tags out into a new
> 	function ml_gen_secondary_tag_rval and export that, for use
> 	by ml_tag_switch.m.

That should have been ml_unify_gen.m.
I enclose below the diff for that file.

Also there was a bug in my code in ml_tag_switch.m (it was got an
internal error for switches which were det only because of the use of
`bound(...)' insts).  I enclose below a relative diff that fixes
that.

I'll commit this change now.

Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.23
diff -u -d -r1.23 ml_unify_gen.m
--- compiler/ml_unify_gen.m	2000/11/09 04:08:27	1.23
+++ compiler/ml_unify_gen.m	2000/11/14 14:40:24
@@ -16,7 +16,7 @@
 :- interface.
 
 :- import_module prog_data.
-:- import_module hlds_pred, hlds_data, hlds_goal.
+:- import_module hlds_module, hlds_pred, hlds_data, hlds_goal.
 :- import_module mlds, ml_code_util.
 :- import_module llds. % XXX for `code_model'
 
@@ -47,6 +47,12 @@
 		mlds__rval, ml_gen_info, ml_gen_info).
 :- mode ml_gen_tag_test(in, in, out, out, out, in, out) is det.
 
+	% ml_gen_secondary_tag_rval(PrimaryTag, VarType, ModuleInfo, VarRval):
+	%	Return the rval for the secondary tag field of VarRval,
+	%	assuming that VarRval has the specified VarType and PrimaryTag.
+:- func ml_gen_secondary_tag_rval(tag_bits, prog_type, module_info, mlds__rval)
+	= mlds__rval.
+
 	%
 	% ml_gen_closure_wrapper(PredId, ProcId, Offset, NumClosureArgs,
 	%	Context, WrapperFuncRval, WrapperFuncType):
@@ -74,7 +80,7 @@
 
 :- implementation.
 
-:- import_module hlds_module, hlds_out, builtin_ops.
+:- import_module hlds_out, builtin_ops.
 :- import_module ml_call_gen, ml_type_gen, prog_util, type_util, mode_util.
 :- import_module rtti, error_util.
 :- import_module code_util. % XXX needed for `code_util__cons_id_to_tag'.
@@ -1708,27 +1714,11 @@
 		  unop(std_unop(mktag), const(int_const(UnsharedTag)))).
 ml_gen_tag_test_rval(shared_remote_tag(PrimaryTagVal, SecondaryTagVal),
 		VarType, ModuleInfo, Rval) = TagTest :-
-	MLDS_VarType = mercury_type_to_mlds_type(ModuleInfo, VarType),
-	module_info_globals(ModuleInfo, Globals),
-	globals__lookup_bool_option(Globals, highlevel_data, HighLevelData),
-	( HighLevelData = no ->
-		% Note: with the low-level data representation,
-		% all fields -- even the secondary tag -- are boxed,
-		% and so we need to unbox (i.e. cast) it back to the
-		% right type here.
-		SecondaryTagField = 
-			unop(unbox(mlds__native_int_type),
-				lval(field(yes(PrimaryTagVal), Rval,
-				offset(const(int_const(0))),
-				mlds__generic_type, MLDS_VarType)))
-	;
-		FieldId = ml_gen_field_id(VarType, "tag_type", 0,
-			"data_tag"),
-		SecondaryTagField = lval(field(yes(PrimaryTagVal), Rval,
-			FieldId, mlds__native_int_type, MLDS_VarType))
-	),
+	SecondaryTagField = ml_gen_secondary_tag_rval(PrimaryTagVal,
+		VarType, ModuleInfo, Rval),
 	SecondaryTagTest = binop(eq, SecondaryTagField,
 		const(int_const(SecondaryTagVal))),
+	module_info_globals(ModuleInfo, Globals),
 	globals__lookup_int_option(Globals, num_tag_bits, NumTagBits),
 	( NumTagBits = 0 ->
 		% no need to test the primary tag
@@ -1746,6 +1736,31 @@
 	TestRval = binop(eq, Rval,
 		  unop(cast(MLDS_VarType), mkword(Bits,
 		  	unop(std_unop(mkbody), const(int_const(Num)))))).
+
+	% ml_gen_secondary_tag_rval(PrimaryTag, VarType, ModuleInfo, VarRval):
+	%	Return the rval for the secondary tag field of VarRval,
+	%	assuming that VarRval has the specified VarType and PrimaryTag.
+ml_gen_secondary_tag_rval(PrimaryTagVal, VarType, ModuleInfo, Rval) =
+		SecondaryTagField :-
+	MLDS_VarType = mercury_type_to_mlds_type(ModuleInfo, VarType),
+	module_info_globals(ModuleInfo, Globals),
+	globals__lookup_bool_option(Globals, highlevel_data, HighLevelData),
+	( HighLevelData = no ->
+		% Note: with the low-level data representation,
+		% all fields -- even the secondary tag -- are boxed,
+		% and so we need to unbox (i.e. cast) it back to the
+		% right type here.
+		SecondaryTagField = 
+			unop(unbox(mlds__native_int_type),
+				lval(field(yes(PrimaryTagVal), Rval,
+				offset(const(int_const(0))),
+				mlds__generic_type, MLDS_VarType)))
+	;
+		FieldId = ml_gen_field_id(VarType, "tag_type", 0,
+			"data_tag"),
+		SecondaryTagField = lval(field(yes(PrimaryTagVal), Rval,
+			FieldId, mlds__native_int_type, MLDS_VarType))
+	).
 
 :- func ml_gen_field_id(prog_type, mlds__class_name, arity, mlds__field_name) =
 	mlds__field_id.
--- ml_tag_switch.m.old	Wed Nov 15 03:13:06 2000
+++ ml_tag_switch.m	Wed Nov 15 03:15:30 2000
@@ -84,7 +84,7 @@
 
 	% generate the switch on the primary tag
 
-	ml_tag_switch__gen_ptag_cases(PtagCaseList, Var, CodeModel,
+	ml_tag_switch__gen_ptag_cases(PtagCaseList, Var, CanFail, CodeModel,
 		PtagCountMap, Context, MLDS_Cases),
 	ml_switch_generate_default(CanFail, CodeModel, Context, Default),
 
@@ -97,27 +97,27 @@
 	{ MLDS_Decls = [] },
 	{ MLDS_Statements = [SwitchStatement] }.
 
-:- pred ml_tag_switch__gen_ptag_cases(ptag_case_list, prog_var, code_model,
-		ptag_count_map, prog_context, list(mlds__switch_case),
-		ml_gen_info, ml_gen_info).
-:- mode ml_tag_switch__gen_ptag_cases(in, in, in, in, in, out, in, out) is det.
-
-ml_tag_switch__gen_ptag_cases([], _, _, _, _, []) --> [].
-ml_tag_switch__gen_ptag_cases([Case | Cases], Var, CodeModel, PtagCountMap,
-		Context, [MLDS_Case | MLDS_Cases]) -->
-	ml_tag_switch__gen_ptag_case(Case, Var, CodeModel, PtagCountMap,
-		Context, MLDS_Case),
-	ml_tag_switch__gen_ptag_cases(Cases, Var, CodeModel, PtagCountMap,
-		Context, MLDS_Cases).
+:- pred ml_tag_switch__gen_ptag_cases(ptag_case_list::in, prog_var::in,
+		can_fail::in, code_model::in, ptag_count_map::in,
+		prog_context::in, list(mlds__switch_case)::out,
+		ml_gen_info::in, ml_gen_info::out) is det.
+
+ml_tag_switch__gen_ptag_cases([], _, _, _, _, _, []) --> [].
+ml_tag_switch__gen_ptag_cases([Case | Cases], Var, CanFail, CodeModel,
+		PtagCountMap, Context, [MLDS_Case | MLDS_Cases]) -->
+	ml_tag_switch__gen_ptag_case(Case, Var, CanFail, CodeModel,
+		PtagCountMap, Context, MLDS_Case),
+	ml_tag_switch__gen_ptag_cases(Cases, Var, CanFail, CodeModel,
+		PtagCountMap, Context, MLDS_Cases).
 
 :- pred ml_tag_switch__gen_ptag_case(
 		pair(tag_bits, pair(stag_loc, stag_goal_map))::in,
-		prog_var::in, code_model::in, ptag_count_map::in,
+		prog_var::in, can_fail::in, code_model::in, ptag_count_map::in,
 		prog_context::in, mlds__switch_case::out,
 		ml_gen_info::in, ml_gen_info::out) is det.
 
-ml_tag_switch__gen_ptag_case(Case, Var, CodeModel, PtagCountMap, Context,
-		MLDS_Case) -->
+ml_tag_switch__gen_ptag_case(Case, Var, CanFail, CodeModel, PtagCountMap,
+		Context, MLDS_Case) -->
 	{ Case = PrimaryTag - (SecTagLocn - GoalMap) },
 	{ map__lookup(PtagCountMap, PrimaryTag, CountInfo) },
 	{ CountInfo = SecTagLocn1 - MaxSecondary },
@@ -138,22 +138,26 @@
 		)
 	;
 		(
+			{ CanFail = cannot_fail }
+		->
+			{ CaseCanFail = cannot_fail }
+		;
 			{ list__length(GoalList, GoalCount) },
 			{ FullGoalCount is MaxSecondary + 1 },
 			{ FullGoalCount = GoalCount }
 		->
-			{ CanFail = cannot_fail }
+			{ CaseCanFail = cannot_fail }
 		;
-			{ CanFail = can_fail }
+			{ CaseCanFail = can_fail }
 		),
-		( { GoalList = [_ - Goal], CanFail = cannot_fail } ->
+		( { GoalList = [_ - Goal], CaseCanFail = cannot_fail } ->
 			% There is only one possible matching goal,
 			% so we don't need to switch on it
 			ml_gen_goal(CodeModel, Goal, MLDS_Statement)
 		;
 			ml_tag_switch__gen_stag_switch(GoalList, PrimaryTag,
-				SecTagLocn, Var, CodeModel, CanFail, Context,
-				MLDS_Statement)
+				SecTagLocn, Var, CodeModel, CaseCanFail,
+				Context, MLDS_Statement)
 		)
 	),
 	{ PrimaryTagRval = const(int_const(PrimaryTag)) },

-- 
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-developers mailing list
Post messages to:       mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions:          mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------