[m-rev.] fix --static-ground-terms for --high-level-data

Fergus Henderson fjh at cs.mu.OZ.AU
Fri Feb 15 20:06:36 AEDT 2002


Estimated hours taken: 8
Branches: main

A couple of improvements to the support for `--high-level-data'
in the MLDS back-end.

Tested by bootchecking in grade hl.gc.

compiler/ml_unify_gen.m:
	Use the correct types for constants produced by the
	`--static-ground-terms' optimization.

compiler/ml_type_gen.m:
	If compiling to C, don't include empty base classes in the list
	of inherited classes.  Standard C doesn't support empty structs,
	and even with GNU C, we were not emitting the correct initializers
	for the empty base classes.

Workspace: /home/ceres/fjh/mercury
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.21
diff -u -d -r1.21 ml_type_gen.m
--- compiler/ml_type_gen.m	16 Jan 2002 01:13:33 -0000	1.21
+++ compiler/ml_type_gen.m	15 Feb 2002 08:12:05 -0000
@@ -362,9 +362,11 @@
 			TagMembers = TagMembers0,
 			TagClassId = BaseClassId
 		;
+			module_info_globals(ModuleInfo, Globals),
+			globals__get_target(Globals, Target),
 			ml_gen_secondary_tag_class(MLDS_Context,
 				BaseClassQualifier, BaseClassId, TagMembers0,
-				TagTypeDefn, TagClassId),
+				Target, TagTypeDefn, TagClassId),
 			TagMembers = [TagTypeDefn]
 		)
 	),
@@ -496,11 +498,12 @@
 	% but not all constructors use secondary tags.
 	%
 :- pred ml_gen_secondary_tag_class(mlds__context, mlds_module_name,
-		mlds__class_id, mlds__defns, mlds__defn, mlds__class_id).
-:- mode ml_gen_secondary_tag_class(in, in, in, in, out, out) is det.
+		mlds__class_id, mlds__defns, compilation_target,
+		mlds__defn, mlds__class_id).
+:- mode ml_gen_secondary_tag_class(in, in, in, in, in, out, out) is det.
 
 ml_gen_secondary_tag_class(MLDS_Context, BaseClassQualifier, BaseClassId,
-		Members, MLDS_TypeDefn, SecondaryTagClassId) :-
+		Members, Target, MLDS_TypeDefn, SecondaryTagClassId) :-
 	% Generate the class name for the secondary tag class.
 	% Note: the secondary tag class is nested inside the
 	% base class for this type.
@@ -510,9 +513,16 @@
 	SecondaryTagClassId = mlds__class_type(ClassName, ClassArity,
 		mlds__class),
 
-	% the secondary tag class inherits the base class for this type
+	% the secondary tag class inherits the base class for this type,
+	% unless we're compiling to C -- in that case, we omit it,
+	% since it is empty, and we don't want to include empty base
+	% classes when compiling to C.
 	Imports = [],
-	Inherits = [BaseClassId],
+	( target_uses_empty_base_classes(Target) = yes ->
+		Inherits = [BaseClassId]
+	;
+		Inherits = []
+	),
 	Implements = [],
 	Ctors = [],
 
@@ -680,14 +690,18 @@
 
 			% we inherit either the base class for this type,
 			% or the secondary tag class, depending on whether
-			% we need a secondary tag
+			% we need a secondary tag.  But when targetting C,
+			% we want to omit empty base classes.  So if
+			% targetting C, don't include any base class if
+			% there is no secondary tag.
 			( MaybeSecTagVal = yes(_) ->
-				ParentClassId = SecondaryTagClassId
+				Inherits = [SecondaryTagClassId]
+			; target_uses_empty_base_classes(Target) = yes ->
+				Inherits = [BaseClassId]
 			;
-				ParentClassId = BaseClassId
+				Inherits = []
 			),
 			Imports = [],
-			Inherits = [ParentClassId],
 			Implements = [],
 
 			% put it all together
@@ -715,6 +729,12 @@
 target_uses_constructors(il)	= yes.
 target_uses_constructors(java)	= yes.
 target_uses_constructors(asm)	= no.
+
+:- func target_uses_empty_base_classes(compilation_target) = bool.
+target_uses_empty_base_classes(c)	= no.
+target_uses_empty_base_classes(il)	= yes.
+target_uses_empty_base_classes(java)	= yes.
+target_uses_empty_base_classes(asm)	= no.
 
 :- func gen_constructor_function(mlds__class_id, mlds__type, mlds_module_name,
 		mlds__class_id, maybe(int), mlds__defns, mlds__context) =
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.49
diff -u -d -r1.49 ml_unify_gen.m
--- compiler/ml_unify_gen.m	11 Jan 2002 07:41:26 -0000	1.49
+++ compiler/ml_unify_gen.m	15 Feb 2002 07:27:25 -0000
@@ -313,7 +313,7 @@
 :- mode ml_gen_static_const_arg_2(in, in, in, in, out, in, out) is det.
 
 ml_gen_static_const_arg_2(Tag, VarType, Var, StaticCons, Rval) -->
-	{ StaticCons = static_cons(_ConsId, ArgVars, StaticArgs) }, 
+	{ StaticCons = static_cons(ConsId, ArgVars, StaticArgs) }, 
 	(
 		%
 		% types for which some other constructor has a
@@ -355,17 +355,20 @@
 		% If this argument is something that would normally be allocated
 		% on the heap, just generate a reference to the static constant
 		% that we must have already generated for it.
-		% XXX Using mlds__array_type(mlds__generic_type) is probably 
-		% wrong when `--high-level-data' is enabled.
 		%
-		{ ConstType = mlds__array_type(mlds__generic_type) },	
+		ml_gen_type(VarType, MLDS_VarType),
+		ml_gen_info_get_globals(Globals),
+		{ globals__lookup_bool_option(Globals, highlevel_data,
+			HighLevelData) },
+		{ UsesBaseClass = (ml_tag_uses_base_class(Tag) -> yes ; no) },
+		{ ConstType = get_type_for_cons_id(MLDS_VarType,
+			UsesBaseClass, yes(ConsId), HighLevelData) },
 		ml_gen_static_const_addr(Var, ConstType, ConstAddrRval),
 		{ TagVal = 0 ->
 			TaggedRval = ConstAddrRval
 		;
 			TaggedRval = mkword(TagVal, ConstAddrRval)
 		},
-		ml_gen_type(VarType, MLDS_VarType),
 		{ Rval = unop(cast(MLDS_VarType), TaggedRval) }
 	;
 		%
@@ -1141,15 +1144,8 @@
 		ml_gen_var_list(ArgVars, ArgLvals),
 		=(Info),
 		{ ml_gen_info_get_module_info(Info, ModuleInfo) },
-		{ MaybeConsId = yes(ConsId) ->
-			ConsArgTypes = constructor_arg_types(ConsId,
-				ArgTypes, Type, ModuleInfo)
-		;
-			% it's a closure
-			% in this case, the arguments are all boxed
-			ConsArgTypes = ml_make_boxed_types(
-					list__length(ArgTypes))
-		},
+		{ get_maybe_cons_id_arg_types(MaybeConsId, ArgTypes, Type,
+			ModuleInfo, ConsArgTypes) },
 		ml_gen_cons_args(ArgLvals, ArgTypes, ConsArgTypes, ArgModes,
 			ModuleInfo, ArgRvals0, MLDS_ArgTypes0),
 
@@ -1181,48 +1177,63 @@
 		{ MLDS_Decls = [] }
 	;
 		{ HowToConstruct = construct_statically(StaticArgs) },
-
-		% XXX This code gets the types wrong
-		% for the --high-level-data case
-
-		list__map_foldl(ml_gen_type, ArgTypes, MLDS_ArgTypes0),
-		/****
-		XXX We ought to do something like this instead:
+		%
+		% Find out the types of the constructor arguments
+		%
 		=(Info),
 		{ ml_gen_info_get_module_info(Info, ModuleInfo) },
-		{ ConsArgTypes = constructor_arg_types(CtorId,
-			ArgTypes, Type, ModuleInfo) },
+		{ get_maybe_cons_id_arg_types(MaybeConsId, ArgTypes, Type,
+			ModuleInfo, ConsArgTypes) },
 		list__map_foldl(ml_gen_field_type, ConsArgTypes,
-			MLDS_ArgTypes0),
-		...
-		*****/
+			FieldTypes),
 
 		%
 		% Generate rvals for the arguments
 		%
+		list__map_foldl(ml_gen_type, ArgTypes, MLDS_ArgTypes0),
 		ml_gen_static_const_arg_list(ArgVars, StaticArgs, ArgRvals0),
 
 		%
-		% Insert the extra rvals at the start
-		%
-		{ list__append(ExtraRvals, ArgRvals0, ArgRvals1) },
-		{ list__append(ExtraTypes, MLDS_ArgTypes0, MLDS_ArgTypes) },
-
-		%
-		% Box all the arguments
+		% Box or unbox the arguments, if needed,
+		% and insert the extra rvals at the start
 		%
-		ml_gen_box_const_rval_list(MLDS_ArgTypes, ArgRvals1,
-			Context, BoxConstDefns, ArgRvals),
+		ml_gen_info_get_globals(Globals),
+		{ globals__lookup_bool_option(Globals, highlevel_data,
+			HighLevelData) },
+		(
+			{ HighLevelData = no },
+			%
+			% Box *all* the arguments, including the ExtraRvals
+			%
+			{ list__append(ExtraRvals, ArgRvals0, ArgRvals1) },
+			{ list__append(ExtraTypes, MLDS_ArgTypes0,
+				MLDS_ArgTypes) },
+			ml_gen_box_const_rval_list(MLDS_ArgTypes, ArgRvals1,
+				Context, BoxConstDefns, ArgRvals)
+		;
+			{ HighLevelData = yes },
+			ml_gen_box_or_unbox_const_rval_list(ArgTypes,
+				FieldTypes, ArgRvals0,
+				Context, BoxConstDefns, ArgRvals1),
+			% For --high-level-data, the ExtraRvals should
+			% already have the right type, so we don't need
+			% to worry about boxing or unboxing them
+			{ list__append(ExtraRvals, ArgRvals1, ArgRvals) }
+		),
 
 		%
 		% Generate a local static constant for this term.
-		% XXX Using mlds__array_type(mlds__generic_type) is probably 
-		% wrong when `--high-level-data' is enabled.
 		%
 		ml_gen_static_const_name(Var, ConstName),
-		{ ConstType = mlds__array_type(mlds__generic_type) },
+		{ UsesBaseClass = (MaybeCtorName = yes(_) -> no ; yes) },
+		{ ConstType = get_type_for_cons_id(MLDS_Type, UsesBaseClass,
+				MaybeConsId, HighLevelData) },
 		{ ArgInits = list__map(func(X) = init_obj(X), ArgRvals) },
-		{ Initializer = init_array(ArgInits) },
+		{ ConstType = mlds__array_type(_) ->
+			Initializer = init_array(ArgInits)
+		;
+			Initializer = init_struct(ArgInits)
+		},
 		{ ConstDefn = ml_gen_static_const_defn(ConstName, ConstType,
 			local, Initializer, Context) },
 
@@ -1304,6 +1315,96 @@
 		{ MLDS_Statements = [MLDS_Statement | MLDS_Statements0] }
 	).
 
+	% Return the MLDS type suitable for constructing a constant static
+	% ground term with the specified cons_id.
+:- func get_type_for_cons_id(mlds__type, bool, maybe(cons_id), bool)
+	= mlds__type.
+get_type_for_cons_id(MLDS_Type, UsesBaseClass, MaybeConsId, HighLevelData)
+		= ConstType :-
+	(
+		HighLevelData = no,
+		ConstType = mlds__array_type(mlds__generic_type)
+	;
+		HighLevelData = yes,
+		(
+			% Check for type_infos and typeclass_infos,
+			% since these need to be handled specially;
+			% their Mercury type definitions are lies.
+			MLDS_Type = mercury_type(MercuryType, user_type, _),
+			type_util__is_introduced_type_info_type(MercuryType)
+		->
+			ConstType = mlds__array_type(mlds__generic_type)
+		;
+			% Check if we're constructing a value for a 
+			% discriminated union where the specified cons_id
+			% which is represented as a derived class that
+			% is derived from the base class for this
+			% discriminated union type.
+			UsesBaseClass = no,
+			MaybeConsId = yes(ConsId),
+			ConsId = cons(CtorSymName, CtorArity),
+			( MLDS_Type = mlds__class_type(QualTypeName,
+				TypeArity, _)
+			; MLDS_Type = mercury_type(MercuryType, user_type, _),
+			  type_to_type_id(MercuryType, TypeId, _ArgsTypes),
+			  ml_gen_type_name(TypeId, QualTypeName, TypeArity)
+			)
+		->
+			% If so, append the name of the derived class to
+			% the name of the base class for this type
+			% (since the derived class will also be nested
+			% inside the base class).
+			unqualify_name(CtorSymName, CtorName),
+			QualTypeName = qual(MLDS_Module, TypeName),
+			ClassQualifier = mlds__append_class_qualifier(
+				MLDS_Module, TypeName, TypeArity),
+			ConstType = mlds__class_type(
+				qual(ClassQualifier, CtorName),
+				CtorArity, mlds__class)
+		;
+			% Convert mercury_types for user-defined types
+			% to the corresponding `mlds__class_type'.
+			% This is needed because these types get mapped to
+			% `mlds__ptr_type(mlds__class_type(...))', but when
+			% declarating static constants we want just the
+			% class type, not the pointer type.
+			MLDS_Type = mercury_type(MercuryType, user_type, _),
+			type_to_type_id(MercuryType, TypeId, _ArgsTypes)
+		->
+			ml_gen_type_name(TypeId, ClassName, ClassArity),
+			ConstType = mlds__class_type(ClassName, ClassArity,
+				mlds__class)
+		;
+			% For tuples, a similar issue arises;
+			% we want tuple constants to have array type,
+			% not the pointer type MR_Tuple.
+			MLDS_Type = mercury_type(_, tuple_type, _)
+		->
+			ConstType = mlds__array_type(mlds__generic_type)
+		;
+			% Likewise for closures, we need to use an array type
+			% rather than the pointer type MR_ClosurePtr.
+			% Note that we're still using a low-level data
+			% representation for closures, even when
+			% --high-level-data is enabled.
+			MLDS_Type = mercury_type(_, pred_type, _)
+		->
+			ConstType = mlds__array_type(mlds__generic_type)
+		;
+			ConstType = MLDS_Type
+		)
+	).
+
+:- pred ml_gen_field_type(prog_type, prog_type, ml_gen_info, ml_gen_info).
+:- mode ml_gen_field_type(in, out, in, out) is det.
+ml_gen_field_type(Type, FieldType) -->
+	=(Info),
+	{ ml_gen_info_get_module_info(Info, ModuleInfo) },
+	{ module_info_globals(ModuleInfo, Globals) },
+	{ globals__lookup_bool_option(Globals, highlevel_data,
+		HighLevelData) },
+	{ ml_type_as_field(Type, ModuleInfo, HighLevelData, FieldType) }.
+
 :- pred ml_type_as_field(prog_type, module_info, bool, prog_type).
 :- mode ml_type_as_field(in, in, in, out) is det.
 ml_type_as_field(FieldType, ModuleInfo, HighLevelData, BoxedFieldType) :-
@@ -1336,6 +1437,21 @@
 		BoxedFieldType = FieldType
 	).
 
+:- pred get_maybe_cons_id_arg_types(maybe(cons_id)::in, list(prog_type)::in,
+		prog_type::in, module_info::in, list(prog_type)::out) is det.
+
+get_maybe_cons_id_arg_types(MaybeConsId, ArgTypes, Type, ModuleInfo,
+		ConsArgTypes) :-
+	( MaybeConsId = yes(ConsId) ->
+		ConsArgTypes = constructor_arg_types(ConsId,
+			ArgTypes, Type, ModuleInfo)
+	;
+		% it's a closure
+		% in this case, the arguments are all boxed
+		ConsArgTypes = ml_make_boxed_types(
+				list__length(ArgTypes))
+	).
+
 :- func constructor_arg_types(cons_id, list(prog_type), prog_type,
 		module_info) = list(prog_type).
 
@@ -1401,6 +1517,50 @@
 
 :- func ml_gen_mktag(int) = mlds__rval.
 ml_gen_mktag(Tag) = unop(std_unop(mktag), const(int_const(Tag))).
+
+
+:- pred ml_gen_box_or_unbox_const_rval_list(list(prog_type), list(prog_type),
+		list(mlds__rval), prog_context, mlds__defns, list(mlds__rval),
+		ml_gen_info, ml_gen_info).
+:- mode ml_gen_box_or_unbox_const_rval_list(in, in, in, in, out, out, in, out)
+		is det.
+
+ml_gen_box_or_unbox_const_rval_list(ArgTypes, FieldTypes, ArgRvals,
+		Context, BoxConstDefns, FieldRvals) -->
+	(
+		{ ArgTypes = [], FieldTypes = [], ArgRvals = [] }
+	->
+		{ BoxConstDefns = [], FieldRvals = [] }
+	;
+		{ ArgTypes = [ArgType | ArgTypes1] },
+		{ FieldTypes = [FieldType | FieldTypes1] },
+		{ ArgRvals = [ArgRval | ArgRvals1] }
+	->
+		(
+			% Handle the case where the field type is a boxed
+			% type -- in that case, we can just box the argument
+			% type.
+			{ FieldType = term__variable(_) }
+		->
+			ml_gen_type(ArgType, MLDS_ArgType),
+			ml_gen_box_const_rval(MLDS_ArgType, ArgRval, Context,
+				BoxConstDefns0, FieldRval)
+		;
+			% Otherwise, fall back on ml_gen_box_or_unbox_rval.
+			% XXX this might still generate stuff which is not
+			% legal in a static initializer!
+			ml_gen_box_or_unbox_rval(ArgType, FieldType, ArgRval,
+				FieldRval),
+			{ BoxConstDefns0 = [] }
+		),
+		ml_gen_box_or_unbox_const_rval_list(ArgTypes1, FieldTypes1,
+			ArgRvals1, Context, BoxConstDefns1, FieldRvals1),
+		{ BoxConstDefns = BoxConstDefns0 ++ BoxConstDefns1 },
+		{ FieldRvals = [FieldRval | FieldRvals1] }
+	;
+		{ unexpected(this_file, "ml_gen_box_or_unbox_const_rval_list: "
+			++ "list length mismatch") }
+	).
 
 :- pred ml_gen_box_const_rval_list(list(mlds__type), list(mlds__rval),
 		prog_context, mlds__defns, list(mlds__rval),

-- 
Fergus Henderson <fjh at cs.mu.oz.au>  |  "I have always known that the pursuit
The University of Melbourne         |  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
--------------------------------------------------------------------------



More information about the reviews mailing list