[m-dev.] for review: compiler-generated procedures

[Zoltan Somogyi]

By Fergus.

The code we were creating for the comparison procedure of an enumerated type
called mercury__compare_3_3, which called the comparison procedure of the
enumerated type (whose address was in the compare slot of the type_ctor_info).
This was an infinite loop. I think it only used to work because higher-order
specialization specialized the call to mercury__compare_3_3, but specialization
is turned off for debugging.

compiler/unify_proc.m:
	Fix the generation of the compare procedures for enumerated types;
	instead of calling mercury__compare_3_3, we cast the args to ints
	and call builtin_compare_int.

	At the same time, make the code that creates the special procedure
	bodies more robust by explicitly checking for invalid kinds of types.

Zoltan.

cvs diff: Diffing .
Index: unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.78
diff -u -b -r1.78 unify_proc.m
--- unify_proc.m	1999/09/30 01:48:38	1.78
+++ unify_proc.m	1999/09/30 07:41:10
@@ -502,7 +502,8 @@
 	is det.
 
 unify_proc__generate_unify_clauses(TypeBody, H1, H2, Context, Clauses) -->
-	( { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred), IsEnum = no } ->
+	(
+		{ TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred) },
 		( { MaybeEqPred = yes(PredName) } ->
 			%
 			% Just generate a call to the specified predicate,
@@ -521,15 +522,31 @@
 			{ Goal = Call - GoalInfo },
 			unify_proc__quantify_clause_body([H1, H2], Goal,
 				Context, Clauses)
-		;
-			unify_proc__generate_du_unify_clauses(Ctors, H1, H2,
+		; { IsEnum = yes } ->
+			{ create_atomic_unification(H1, var(H2), Context,
+				explicit, [], Goal) },
+			unify_proc__quantify_clause_body([H1, H2], Goal,
 				Context, Clauses)
+		;
+			unify_proc__generate_du_unify_clauses(Ctors,
+				H1, H2, Context, Clauses)
 		)
+
 	;
+		{ TypeBody = eqv_type(_Type) },
+		% We should check whether _Type is abstract or not.
+		% If it is, we should call its unification procedure;
+		% if it is not, we should generate its body inline here.
 		{ create_atomic_unification(H1, var(H2), Context, explicit, [],
 			Goal) },
 		unify_proc__quantify_clause_body([H1, H2], Goal, Context,
 			Clauses)
+	;
+		{ TypeBody = uu_type(_) },
+		{ error("trying to create unify proc for uu type") }
+	;
+		{ TypeBody = abstract_type },
+		{ error("trying to create unify proc for abstract type") }
 	).
 
 :- pred unify_proc__generate_index_clauses(hlds_type_body, prog_var, prog_var,
@@ -538,7 +555,8 @@
 	is det.
 
 unify_proc__generate_index_clauses(TypeBody, X, Index, Context, Clauses) -->
-	( { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred), IsEnum = no } ->
+	(
+		{ TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred) },
 		( { MaybeEqPred = yes(_) } ->
 			%
 			% For non-canonical types, we just give up and
@@ -551,15 +569,30 @@
 				ArgVars, Context, Goal),
 			unify_proc__quantify_clause_body(ArgVars, Goal,
 				Context, Clauses)
+		; { IsEnum = yes } ->
+			{ ArgVars = [X, Index] },
+			unify_proc__build_call(
+				"index", ArgVars, Context, Goal),
+			unify_proc__quantify_clause_body(ArgVars, Goal,
+				Context, Clauses)
 		;
 			unify_proc__generate_du_index_clauses(Ctors, X, Index,
 				Context, 0, Clauses)
 		)
 	;
+		{ TypeBody = eqv_type(_Type) },
+		% XXX zs: I believe this code works only by accident.
+		% XXX the point for unify also applies here
 		{ ArgVars = [X, Index] },
 		unify_proc__build_call("index", ArgVars, Context, Goal),
 		unify_proc__quantify_clause_body(ArgVars, Goal, Context,
 			Clauses)
+	;
+		{ TypeBody = uu_type(_) },
+		{ error("trying to create index proc for uu type") }
+	;
+		{ TypeBody = abstract_type },
+		{ error("trying to create index proc for abstract type") }
 	).
 
 :- pred unify_proc__generate_compare_clauses(hlds_type_body, prog_var, prog_var,
@@ -570,7 +603,8 @@
 
 unify_proc__generate_compare_clauses(TypeBody, Res, H1, H2, Context, Clauses)
 		-->
-	( { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred), IsEnum = no } ->
+	(
+		{ TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred) },
 		( { MaybeEqPred = yes(_) } ->
 			%
 			% just generate code that will call error/1
@@ -581,15 +615,47 @@
 				ArgVars, Context, Goal),
 			unify_proc__quantify_clause_body(ArgVars, Goal,
 				Context, Clauses)
+		; { IsEnum = yes } ->
+			{ construct_type(unqualified("int") - 0, [],
+				IntType) },
+			unify_proc__info_new_var(IntType, TC1),
+			unify_proc__info_new_var(IntType, TC2),
+			{ TC1ArgVars = [H1, TC1] },
+			unify_proc__build_call(
+				"unsafe_type_cast",
+				TC1ArgVars, Context, TC1Goal),
+			{ TC2ArgVars = [H2, TC2] },
+			unify_proc__build_call(
+				"unsafe_type_cast",
+				TC2ArgVars, Context, TC2Goal),
+			{ CompareArgVars = [Res, TC1, TC2] },
+			unify_proc__build_call(
+				"builtin_compare_int",
+				CompareArgVars, Context, CompareGoal),
+			{ goal_info_init(GoalInfo0) },
+			{ goal_info_set_context(GoalInfo0, Context,
+				GoalInfo) },
+			{ conj_list_to_goal([TC1Goal, TC2Goal, CompareGoal],
+				GoalInfo, Goal) },
+			{ ArgVars = [Res, H1, H2] },
+			unify_proc__quantify_clause_body(ArgVars, Goal,
+				Context, Clauses)
 		;
 			unify_proc__generate_du_compare_clauses(Ctors,
 				Res, H1, H2, Context, Clauses)
 		)
 	;
+		{ TypeBody = eqv_type(_) },
 		{ ArgVars = [Res, H1, H2] },
 		unify_proc__build_call("compare", ArgVars, Context, Goal),
 		unify_proc__quantify_clause_body(ArgVars, Goal, Context,
 			Clauses)
+	;
+		{ TypeBody = uu_type(_) },
+		{ error("trying to create compare proc for uu type") }
+	;
+		{ TypeBody = abstract_type },
+		{ error("trying to create compare proc for abstract type") }
 	).
 
 :- pred unify_proc__quantify_clause_body(list(prog_var), hlds_goal,
cvs diff: Diffing notes
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------