[m-rev.] for prelim review: fix generation of type_ctor_info for unboxed types bug

[Peter Ross]

Hi,

This is for preliminary review.  How does this look to you Fergus?

+		% XXX replaced with UnifyInit and CompareInit
+		% Note however that this means that we will always create
+		% an extra level of indirection.
+		% We could be a bit smarter here and try and detect which
+		% types need unboxing (backend dependent)

Of particular interest to me is the answer to the above question.  You
will find it in the code.


===================================================================


The comparison and unification function pointers stored in the
type_ctor_info must be pointers to functions where all the arguments
are boxed.  This wasn't occuring on the IL backend for types which
are value types.

compiler/ml_closure_gen.m:
	Adapt ml_gen_closure_wrapper so that it can generate a wrapper
	for the special preds.

compiler/rtti_to_mlds.m:
	Call ml_gen_closure_wrapper to construct a version of the
	comparison and unification functions where the arguments are
	boxed.

Index: compiler/ml_closure_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_closure_gen.m,v
retrieving revision 1.22
diff -u -r1.22 ml_closure_gen.m
--- compiler/ml_closure_gen.m	13 Nov 2003 13:04:33 -0000	1.22
+++ compiler/ml_closure_gen.m	1 Dec 2003 16:09:58 -0000
@@ -50,7 +50,8 @@
 	%
 	% The ClosureKind parameter specifies whether the closure is
 	% an ordinary closure, used for higher-order procedure calls,
-	% or a typeclass_info, used for class method calls.
+	% or a typeclass_info, used for class method calls, or a call
+	% to a special pred.
 	% The NumClosuresArgs parameter specifies how many arguments
 	% to extract from the closure.
 	%
@@ -62,7 +63,8 @@
 
 :- type closure_kind
 	--->	higher_order_proc_closure
-	;	typeclass_info_closure.
+	;	typeclass_info_closure
+	;	special_pred.
 
 	% ml_gen_local_for_output_arg(VarName, Type, ArgNum, Context,
 	%	LocalVarDefn):
@@ -770,18 +772,24 @@
 	{ WrapperArgs1 = list__map(arg_delete_gc_trace_code, WrapperArgs0) },
 
 	% then insert the `closure_arg' parameter
-	{ ClosureArgType = mlds__generic_type },
-	{ ClosureArgName = mlds__var_name("closure_arg", no) },
-	{ ClosureArgDeclType = list__det_head(ml_make_boxed_types(1)) },
-	gen_closure_gc_trace_code(ClosureArgName, ClosureArgDeclType,
-		ClosureKind, WrapperArgTypes, Purity, PredOrFunc,
-		Context, ClosureArgGCTraceCode),
-	{ ClosureArg = mlds__argument(
-		data(var(ClosureArgName)),
-		ClosureArgType,
-		ClosureArgGCTraceCode) },
-	{ WrapperParams = mlds__func_params([ClosureArg | WrapperArgs1],
-		WrapperRetType) },
+	( { ClosureKind = special_pred } ->
+		{ MaybeClosureA = no },
+		{ WrapperArgs = WrapperArgs1 }
+	;
+		{ ClosureArgType = mlds__generic_type },
+		{ ClosureArgName = mlds__var_name("closure_arg", no) },
+		{ ClosureArgDeclType = list__det_head(ml_make_boxed_types(1)) },
+		gen_closure_gc_trace_code(ClosureArgName, ClosureArgDeclType,
+			ClosureKind, WrapperArgTypes, Purity, PredOrFunc,
+			Context, ClosureArgGCTraceCode),
+		{ ClosureArg = mlds__argument(
+			data(var(ClosureArgName)),
+			ClosureArgType,
+			ClosureArgGCTraceCode) },
+		{ MaybeClosureA = yes({ClosureArgType, ClosureArgName}) },
+		{ WrapperArgs = [ClosureArg | WrapperArgs1] }
+	),
+	{ WrapperParams = mlds__func_params(WrapperArgs, WrapperRetType) },
 
 	% also compute the lvals for the parameters,
 	% and local declarations for any by-value output parameters
@@ -814,14 +822,22 @@
 	% because it won't be live across an allocation, and because
 	% (unlike the closure_arg parameter) it isn't referenced from
 	% the GC tracing for other variables.
-	{ ClosureGCTraceCode = no },
 	{ MLDS_Context = mlds__make_context(Context) },
-	{ ClosureDecl = ml_gen_mlds_var_decl(var(ClosureName),
-		ClosureType, ClosureGCTraceCode, MLDS_Context) },
-	ml_gen_var_lval(ClosureName, ClosureType, ClosureLval),
-	ml_gen_var_lval(ClosureArgName, ClosureArgType, ClosureArgLval),
-	{ InitClosure = ml_gen_assign(ClosureLval, lval(ClosureArgLval),
-		Context) },
+	( { MaybeClosureA = yes({ClosureArgType1, ClosureArgName1}) } ->
+		{ ClosureGCTraceCode = no },
+		{ ClosureDecl = ml_gen_mlds_var_decl(var(ClosureName),
+			ClosureType, ClosureGCTraceCode, MLDS_Context) },
+		ml_gen_var_lval(ClosureName, ClosureType, ClosureLval),
+		ml_gen_var_lval(ClosureArgName1, ClosureArgType1,
+				ClosureArgLval),
+		{ InitClosure = ml_gen_assign(ClosureLval, lval(ClosureArgLval),
+			Context) },
+		{ MaybeClosureB = yes({ClosureDecl, InitClosure}) },
+		{ MaybeClosureC = yes(ClosureLval) }
+	;
+		{ MaybeClosureB = no },
+		{ MaybeClosureC = no }
+	),
 
 	%
 	% if the wrapper function is model_non, then
@@ -867,23 +883,33 @@
 	% `Offset' specifies the offset to add to the argument number to
 	% get the field number within the closure.  (Argument numbers start
 	% from 1, and field numbers start from 0.)
-	{
-		ClosureKind = higher_order_proc_closure,
-		Offset = ml_closure_arg_offset
+	( { MaybeClosureC = yes(ClosureLval1) } ->
+		{ ClosureKind = higher_order_proc_closure,
+			Offset = ml_closure_arg_offset
+		; ClosureKind = typeclass_info_closure,
+			Offset = ml_typeclass_info_arg_offset
+		; ClosureKind = special_pred,
+			unexpected(this_file,
+				"ml_gen_closure_wrapper: special_pred")
+		},
+		ml_gen_closure_field_lvals(ClosureLval1, Offset, 1,
+				NumClosureArgs, ClosureArgLvals)
 	;
-		ClosureKind = typeclass_info_closure,
-		Offset = ml_typeclass_info_arg_offset
-	},
-	ml_gen_closure_field_lvals(ClosureLval, Offset, 1, NumClosureArgs,
-		ClosureArgLvals),
+		{ ClosureArgLvals = [] }
+	),
 	{ CallLvals = list__append(ClosureArgLvals, WrapperHeadVarLvals) },
 	ml_gen_call(PredId, ProcId, ProcHeadVarNames, CallLvals,
 		ProcBoxedArgTypes, CodeModel, Context, yes,
 		Decls0, Statements0),
 
 	% insert the stuff to declare and initialize the closure
-	{ Decls1 = [ClosureDecl | Decls0] },
-	{ Statements1 = [InitClosure | Statements0] },
+	( { MaybeClosureB = yes({ClosureDecl1, InitClosure1}) } ->
+		{ Decls1 = [ClosureDecl1 | Decls0] },
+		{ Statements1 = [InitClosure1 | Statements0] }
+	;
+		{ Decls1 = Decls0 },
+		{ Statements1 = Statements0 }
+	),
 
 	%
 	% For semidet code, add the declaration `MR_bool succeeded;'
@@ -904,9 +930,12 @@
 	% needed for accurate GC
 	%
 	{ module_info_globals(ModuleInfo, Globals) },
-	( { globals__get_gc_method(Globals, accurate) } ->
-		ml_gen_closure_wrapper_gc_decls(ClosureKind, ClosureArgName,
-			ClosureArgType, PredId, ProcId, Context, GC_Decls)
+	(
+		{ MaybeClosureA = yes({ClosureArgType2, ClosureArgName2}) },
+		{ globals__get_gc_method(Globals, accurate) }
+	->
+		ml_gen_closure_wrapper_gc_decls(ClosureKind, ClosureArgName2,
+			ClosureArgType2, PredId, ProcId, Context, GC_Decls)
 	;
 		{ GC_Decls = [] }
 	),
@@ -970,6 +999,10 @@
 	;
 		{ ClosureKind = typeclass_info_closure },
 		{ ClosureActualType = sample_typeclass_info_type }
+	;
+		{ ClosureKind = special_pred },
+		{ unexpected(this_file,
+				"gen_closure_gc_trace_code: special_pred") }
 	),
 	ml_gen_maybe_gc_trace_code(ClosureName, ClosureDeclType,
 		ClosureActualType, Context, ClosureGCTraceCode).
@@ -1177,6 +1210,11 @@
 			target_code_input(lval(ClosureLayoutPtrLval)),
 			raw_target_code(");\n", [])
 		] }
+	;
+		{ ClosureKind = special_pred },
+		{ unexpected(this_file,
+			"ml_gen_closure_wrapper_gc_decls: special_pred") }
+
 	),
 	{ TypeParamsGCInit = mlds__statement(atomic(inline_target_code(
 		lang_C, TypeParamsGCInitFragments)), MLDS_Context) },
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.43
diff -u -r1.43 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m	1 Dec 2003 06:53:29 -0000	1.43
+++ compiler/rtti_to_mlds.m	1 Dec 2003 16:09:58 -0000
@@ -196,16 +196,32 @@
 	NumPtags = type_ctor_details_num_ptags(TypeCtorDetails),
 	NumFunctors = type_ctor_details_num_functors(TypeCtorDetails),
 	gen_functors_layout_info(ModuleInfo, RttiTypeCtor, TypeCtorDetails,
-		FunctorsInfo, LayoutInfo, SubDefns),
+		FunctorsInfo, LayoutInfo, SubDefns0),
 	FunctorsRttiId = ctor_rtti_id(RttiTypeCtor, type_functors),
 	LayoutRttiId = ctor_rtti_id(RttiTypeCtor, type_layout),
+
+	some [!Defns] (
+		!:Defns = SubDefns0,
+		gen_init_special_pred(ModuleInfo, UnifyUniv, UnifyInit, !Defns),
+		gen_init_special_pred(ModuleInfo, CompareUniv,
+				CompareInit, !Defns),
+		SubDefns = !.Defns
+	),
+
 	Init = init_struct(mlds__rtti_type(RttiId), [
 		gen_init_int(TypeArity),
 		gen_init_int(Version),
 		gen_init_int(NumPtags),
 		gen_init_type_ctor_rep(TypeCtorData),
-		gen_init_proc_id_from_univ(ModuleInfo, UnifyUniv),
-		gen_init_proc_id_from_univ(ModuleInfo, CompareUniv),
+		% XXX replaced with UnifyInit and CompareInit
+		% Note however that this means that we will always create
+		% an extra level of indirection.
+		% We could be a bit smarter here and try and detect which
+		% types need unboxing (backend dependent)
+		% gen_init_proc_id_from_univ(ModuleInfo, UnifyUniv),
+		% gen_init_proc_id_from_univ(ModuleInfo, CompareUniv),
+		UnifyInit,
+		CompareInit,
 		gen_init_string(TypeModuleName),
 		gen_init_string(TypeName),
 		% In the C back-end, these two "structs" are actually unions.
@@ -1048,8 +1064,7 @@
 		list(mlds__defn), list(mlds__defn)).
 :- mode gen_init_method(in, in, in, out, in, out) is det.
 
-gen_init_method(ModuleInfo, NumExtra, RttiProcId, Init,
-		ExtraDefns0, ExtraDefns) :-
+gen_init_method(ModuleInfo, NumExtra, RttiProcId, Init, !ExtraDefns) :-
 	%
 	% we can't store the address of the typeclass method directly in
 	% the base_typeclass_info; instead, we need to generate
@@ -1064,7 +1079,29 @@
 	% Hopefully the Mercury HLDS->HLDS inlining and/or
 	% the target code compiler will be able to optimize this...
 	%
+	gen_wrapper_func_and_initializer(ModuleInfo, NumExtra, RttiProcId,
+			typeclass_info_closure, Init, !ExtraDefns).
+
+:- pred gen_init_special_pred(module_info::in, univ::in, mlds__initializer::out,
+		list(mlds__defn)::in, list(mlds__defn)::out) is det.
+
+gen_init_special_pred(ModuleInfo, RttiProcIdUniv, Init, !ExtraDefns) :-
+	( univ_to_type(RttiProcIdUniv, RttiProcId) ->
+		NumExtra = 0,
+		gen_wrapper_func_and_initializer(ModuleInfo, NumExtra,
+				RttiProcId, special_pred, Init, !ExtraDefns)
+	;
+		error("gen_init_special_pred: cannot extract univ value")
+	).
+
+
+:- pred gen_wrapper_func_and_initializer(module_info, int, rtti_proc_label,
+		closure_kind, mlds__initializer,
+		list(mlds__defn), list(mlds__defn)).
+:- mode gen_wrapper_func_and_initializer(in, in, in, in, out, in, out) is det.
 
+gen_wrapper_func_and_initializer(ModuleInfo, NumExtra, RttiProcId,
+		ClosureKind, Init, ExtraDefns0, ExtraDefns) :-
 	%
 	% We start off by creating a fresh MLGenInfo here,
 	% using the pred_id and proc_id of the wrapped procedure.
@@ -1083,16 +1120,15 @@
 	% Now we can safely go ahead and generate the wrapper function
 	%
 	term__context_init(Context),
-	ml_gen_closure_wrapper(PredId, ProcId, typeclass_info_closure,
+	ml_gen_closure_wrapper(PredId, ProcId, ClosureKind,
 		NumExtra, Context, WrapperFuncRval, WrapperFuncType,
 		MLGenInfo1, MLGenInfo),
 	ml_gen_info_get_extra_defns(MLGenInfo, ExtraDefns1),
 	ExtraDefns = list__append(ExtraDefns1, ExtraDefns0),
 	
 	%
-	% The initializer for the method field of the base_typeclass_info
-	% is just the wrapper function's address, converted to
-	% mlds__generic_type (by boxing).
+	% The initializer for the wrapper is just the wrapper function's
+	% address, converted to mlds__generic_type (by boxing).
 	%
 	Init = init_obj(unop(box(WrapperFuncType), WrapperFuncRval)).
 


-- 
Peter Ross		
Software Engineer                                (Work)   +32 2 757 10 15
Mission Critical                                 (Mobile) +32 485 482 559
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------