[m-rev.] [dotnet-foreign] for review: stage 1 of pragma foreign_type

Peter Ross peter.ross at miscrit.be
Tue Apr 10 00:08:45 AEST 2001


Hi,


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


Estimated hours taken: 24
Branches: dotnet-foreign

Introduce the new pragma `foreign_type'.  This allows the mercury code
generator to use the more specific foreign type when generating code.
This is a big win on the IL backend as casting between different
types is a very expensive operation.

Currently this change is very heavily tied to the IL backend, and needs
to be generalised before merging back onto the main branch.

compiler/prog_data.m:
    Add a type to hold the data from parsing a pragma foreign_type decl.
    
compiler/prog_io_pragma.m:
    Parse the pragma foreign_type.

compiler/hlds_data.m:
    Add a new alternative to hlds_type_body where the body of the type
    is a foreign type.
    
compiler/make_hlds.m:
    Place the foreign_type pragmas into the HLDS.

compiler/export.m:
    Change export__type_to_type_string so that we return the
    foreign type representation if it exits.

compiler/llds.m:
    Since export__type_to_type_string needs a module_info, we add a new
    field to pragma_c_arg_decl which is the result of calling
    export__type_to_type_string.  This avoids threading the module_info
    around various llds passes.
    
compiler/mlds.m:
    Table the result of export__type_to_type_string so as to avoid
    passing the module_info around the MLDS backend.
    Also add the foreign_type alternative to mlds__type.
    Update mercury_type_to_mlds_type so that handles types which are
    foreign types, and we also table the result of
    export__type_to_type_string.

compiler/pragma_c_gen.m:
    Table the results of export__type_to_type_string in
    pragma_c_arg_decl.
    
compiler/mlds_to_il.m:
    Convert a mlds__foreign_type into an ilds__type.

compiler/fact_table.m:
compiler/llds_out.m:
compiler/ml_code_gen.m:
compiler/ml_simplify_switch.m:
compiler/ml_string_switch.m:
compiler/ml_switch_gen.m:
compiler/ml_unify_gen.m:
compiler/mlds_to_c.m:
compiler/mlds_to_java.m:
compiler/rtti_to_mlds.m:
    Changes to handle the tabling of calls to export__type_to_type_string.
    
compiler/hlds_out.m:
compiler/intermod.m:
compiler/magic_util.m:
compiler/ml_type_gen.m:
compiler/term_util.m:
compiler/type_ctor_info.m:
compiler/unify_proc.m:
    Changes to handle the new hlds_type_body.

compiler/mercury_to_mercury.m:
    Output the pragma foreign_type declaration.

compiler/module_qual.m:
    Qualify the pragma foreign_type declarations.

compiler/modules.m:
    Pragma foreign_type is allowed in the interface.

Index: compiler/export.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.46
diff -u -r1.46 export.m
--- compiler/export.m	2001/02/05 08:01:40	1.46
+++ compiler/export.m	2001/04/09 13:06:24
@@ -50,8 +50,8 @@
 
 	% Convert the type to a string corresponding to its C type.
 	% (Defaults to MR_Word).
-:- pred export__type_to_type_string(type, string).
-:- mode export__type_to_type_string(in, out) is det.
+:- pred export__type_to_type_string(module_info, type, string).
+:- mode export__type_to_type_string(in, in, out) is det.
 
 	% Generate C code to convert an rval (represented as a string), from
 	% a C type to a mercury C type (ie. convert strings and floats to
@@ -71,7 +71,7 @@
 :- implementation.
 
 :- import_module modules.
-:- import_module hlds_pred, type_util.
+:- import_module hlds_data, hlds_pred, type_util.
 :- import_module code_model.
 :- import_module code_gen, code_util, llds_out.
 :- import_module globals, options.
@@ -88,23 +88,24 @@
 	module_info_get_pragma_exported_procs(HLDS, ExportedProcs),
 	module_info_globals(HLDS, Globals),
 	export__get_foreign_export_decls_2(Preds, ExportedProcs, Globals,
-		C_ExportDecls).
+		HLDS, C_ExportDecls).
 
 :- pred export__get_foreign_export_decls_2(pred_table,
-	list(pragma_exported_proc), globals, list(foreign_export_decl)).
-:- mode export__get_foreign_export_decls_2(in, in, in, out) is det.
+		list(pragma_exported_proc), globals,
+		module_info, list(foreign_export_decl)).
+:- mode export__get_foreign_export_decls_2(in, in, in, in, out) is det.
 
-export__get_foreign_export_decls_2(_Preds, [], _, []).
-export__get_foreign_export_decls_2(Preds, [E|ExportedProcs], Globals,
+export__get_foreign_export_decls_2(_Preds, [], _, _, []).
+export__get_foreign_export_decls_2(Preds, [E|ExportedProcs], Globals, Module,
 		C_ExportDecls) :-
 	E = pragma_exported_proc(PredId, ProcId, C_Function, _Ctxt),
-	get_export_info(Preds, PredId, ProcId, Globals, _HowToDeclare,
+	get_export_info(Preds, PredId, ProcId, Globals, Module, _HowToDeclare,
 		C_RetType, _DeclareReturnVal, _FailureAction, _SuccessAction,
 		HeadArgInfoTypes),
-	get_argument_declarations(HeadArgInfoTypes, no, ArgDecls),
+	get_argument_declarations(HeadArgInfoTypes, no, Module, ArgDecls),
 	C_ExportDecl = foreign_export_decl(c, C_RetType, C_Function, ArgDecls),
 	export__get_foreign_export_decls_2(Preds, ExportedProcs, Globals,
-		C_ExportDecls0),
+		Module, C_ExportDecls0),
 	C_ExportDecls = [C_ExportDecl | C_ExportDecls0].
 
 %-----------------------------------------------------------------------------%
@@ -203,10 +204,10 @@
 export__to_c(Preds, [E|ExportedProcs], Module, ExportedProcsCode) :-
 	E = pragma_exported_proc(PredId, ProcId, C_Function, _Ctxt),
 	module_info_globals(Module, Globals),
-	get_export_info(Preds, PredId, ProcId, Globals, DeclareString,
+	get_export_info(Preds, PredId, ProcId, Globals, Module, DeclareString,
 		C_RetType, MaybeDeclareRetval, MaybeFail, MaybeSucceed,
 		ArgInfoTypes),
-	get_argument_declarations(ArgInfoTypes, yes, ArgDecls),
+	get_argument_declarations(ArgInfoTypes, yes, Module, ArgDecls),
 
 		% work out which arguments are input, and which are output,
 		% and copy to/from the mercury registers.
@@ -266,13 +267,15 @@
 	%	- the actions on success and failure, and
 	%	- the argument locations/modes/types.
 
-:- pred get_export_info(pred_table, pred_id, proc_id, globals,
+:- pred get_export_info(pred_table, pred_id, proc_id, globals, module_info,
 			string, string, string, string, string,
 			assoc_list(arg_info, type)).
-:- mode get_export_info(in, in, in, in, out, out, out, out, out, out) is det.
+:- mode get_export_info(in, in, in, in, in,
+		out, out, out, out, out, out) is det.
 
-get_export_info(Preds, PredId, ProcId, Globals, HowToDeclareLabel, C_RetType,
-		MaybeDeclareRetval, MaybeFail, MaybeSucceed, ArgInfoTypes) :-
+get_export_info(Preds, PredId, ProcId, Globals, Module,
+		HowToDeclareLabel, C_RetType, MaybeDeclareRetval,
+		MaybeFail, MaybeSucceed, ArgInfoTypes) :-
 	map__lookup(Preds, PredId, PredInfo),
 	pred_info_import_status(PredInfo, Status),
 	(
@@ -306,7 +309,7 @@
 			RetArgMode = top_out,
 			\+ type_util__is_dummy_argument_type(RetType)
 		->
-			export__type_to_type_string(RetType, C_RetType),
+			export__type_to_type_string(Module, RetType, C_RetType),
 			argloc_to_string(RetArgLoc, RetArgString0),
 			convert_type_from_mercury(RetArgString0, RetType,
 				RetArgString),
@@ -364,37 +367,41 @@
 	% build a string to declare the argument types (and if
 	% NameThem = yes, the argument names) of a C function.
 
-:- pred get_argument_declarations(assoc_list(arg_info, type), bool, string).
-:- mode get_argument_declarations(in, in, out) is det.
+:- pred get_argument_declarations(assoc_list(arg_info, type), bool,
+		module_info, string).
+:- mode get_argument_declarations(in, in, in, out) is det.
+
+get_argument_declarations([], _, _, "void").
+get_argument_declarations([X|Xs], NameThem, Module, Result) :-
+	get_argument_declarations_2([X|Xs], 0, NameThem, Module, Result).
 
-get_argument_declarations([], _, "void").
-get_argument_declarations([X|Xs], NameThem, Result) :-
-	get_argument_declarations_2([X|Xs], 0, NameThem, Result).
-
 :- pred get_argument_declarations_2(assoc_list(arg_info, type), int, bool,
-				string).
-:- mode get_argument_declarations_2(in, in, in, out) is det.
+				module_info, string).
+:- mode get_argument_declarations_2(in, in, in, in, out) is det.
 
-get_argument_declarations_2([], _, _, "").
-get_argument_declarations_2([AT|ATs], Num0, NameThem, Result) :-
+get_argument_declarations_2([], _, _, _, "").
+get_argument_declarations_2([AT|ATs], Num0, NameThem, Module, Result) :-
 	AT = ArgInfo - Type,
 	Num is Num0 + 1,
-	get_argument_declaration(ArgInfo, Type, Num, NameThem,
+	get_argument_declaration(ArgInfo, Type, Num, NameThem, Module,
 			TypeString, ArgName),
 	(
 		ATs = []
 	->
 		string__append(TypeString, ArgName, Result)
 	;
-		get_argument_declarations_2(ATs, Num, NameThem, TheRest),
+		get_argument_declarations_2(ATs, Num, NameThem, Module,
+			TheRest),
 		string__append_list([TypeString, ArgName, ", ", TheRest],
 			Result)
 	).
 	
-:- pred get_argument_declaration(arg_info, type, int, bool, string, string).
-:- mode get_argument_declaration(in, in, in, in, out, out) is det.
+:- pred get_argument_declaration(arg_info, type, int, bool, module_info, 
+		string, string).
+:- mode get_argument_declaration(in, in, in, in, in, out, out) is det.
 
-get_argument_declaration(ArgInfo, Type, Num, NameThem, TypeString, ArgName) :-
+get_argument_declaration(ArgInfo, Type, Num, NameThem, Module,
+		TypeString, ArgName) :-
 	ArgInfo = arg_info(_Loc, Mode),
 	( NameThem = yes ->
 		string__int_to_string(Num, NumString),
@@ -402,7 +409,7 @@
 	;
 		ArgName = ""
 	),
-	export__type_to_type_string(Type, TypeString0),
+	export__type_to_type_string(Module, Type, TypeString0),
 	(
 		Mode = top_out
 	->
@@ -596,7 +603,7 @@
 	% Convert a term representation of a variable type to a string which
 	% represents the C type of the variable
 	% Apart from special cases, local variables become MR_Words
-export__type_to_type_string(Type, Result) :-
+export__type_to_type_string(ModuleInfo, Type, Result) :-
 	( Type = term__functor(term__atom("int"), [], _) ->
 		Result = "MR_Integer"
 	; Type = term__functor(term__atom("float"), [], _) ->
@@ -606,7 +613,28 @@
 	; Type = term__functor(term__atom("character"), [], _) ->
 		Result = "MR_Char"
 	;
-		Result = "MR_Word"
+		module_info_types(ModuleInfo, Types),
+		(
+			type_to_type_id(Type, TypeId, _),
+			map__search(Types, TypeId, TypeDefn)
+		->
+				% XXX how we output the type depends on
+				% which foreign language we are using.
+			hlds_data__get_type_defn_body(TypeDefn, Body),
+			( Body = foreign_type(ForeignType) ->
+				Result = sym_name_to_string(ForeignType) ++ " *"
+			;
+				Result = "MR_Word"
+			)
+		;
+			Result = "MR_Word"
+		)
 	).
+
+:- func sym_name_to_string(sym_name) = string.
+
+sym_name_to_string(unqualified(Name)) = Name.
+sym_name_to_string(qualified(ModuleSpec, Name)) 
+	= sym_name_to_string(ModuleSpec) ++ ("::" ++ Name).
 
 %-----------------------------------------------------------------------------%
Index: compiler/fact_table.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/fact_table.m,v
retrieving revision 1.39
diff -u -r1.39 fact_table.m
--- compiler/fact_table.m	2001/02/20 14:08:33	1.39
+++ compiler/fact_table.m	2001/04/09 13:06:25
@@ -3188,16 +3188,17 @@
 	list__map(lambda([X::in, Y::out] is det, X = pragma_var(_,_,Y)),
 		PragmaVars, Modes),
 	make_arg_infos(Types, Modes, model_non, ModuleInfo, ArgInfos),
-	generate_argument_vars_code_2(PragmaVars, ArgInfos, Types, DeclCode,
-		InputCode, OutputCode, SaveRegsCode, GetRegsCode, 1,
+	generate_argument_vars_code_2(PragmaVars, ArgInfos, Types, ModuleInfo,
+		DeclCode, InputCode, OutputCode, SaveRegsCode, GetRegsCode, 1,
 		NumInputArgs).
 
 :- pred generate_argument_vars_code_2(list(pragma_var), list(arg_info),
-		list(type), string, string, string, string, string, int, int).
-:- mode generate_argument_vars_code_2(in, in, in, out, out, out, out, out,
+		list(type), module_info, string,
+		string, string, string, string, int, int).
+:- mode generate_argument_vars_code_2(in, in, in, in, out, out, out, out, out,
 		in, out) is det.
 
-generate_argument_vars_code_2(PragmaVars0, ArgInfos0, Types0, DeclCode,
+generate_argument_vars_code_2(PragmaVars0, ArgInfos0, Types0, Module, DeclCode,
 		InputCode, OutputCode, SaveRegsCode, GetRegsCode,
 		NumInputArgs0, NumInputArgs) :-
 	(
@@ -3216,7 +3217,7 @@
 		ArgInfos0 = [arg_info(Loc, ArgMode) | ArgInfos],
 		Types0 = [Type | Types]
 	->
-		generate_arg_decl_code(VarName, Type, DeclCode0),
+		generate_arg_decl_code(VarName, Type, Module, DeclCode0),
 		( ArgMode = top_in ->
 			NumInputArgs1 is NumInputArgs0 + 1,
 			generate_arg_input_code(VarName, Type, Loc,
@@ -3234,8 +3235,9 @@
 			error("generate_argument_vars_code: invalid mode")
 		),
 		generate_argument_vars_code_2(PragmaVars, ArgInfos, Types,
-			DeclCode1, InputCode1, OutputCode1, SaveRegsCode1,
-			GetRegsCode1, NumInputArgs1, NumInputArgs),
+			Module, DeclCode1, InputCode1, OutputCode1,
+			SaveRegsCode1, GetRegsCode1, NumInputArgs1,
+			NumInputArgs),
 		string__append(DeclCode0, DeclCode1, DeclCode),
 		string__append(InputCode0, InputCode1, InputCode),
 		string__append(OutputCode0, OutputCode1, OutputCode),
@@ -3245,10 +3247,11 @@
 		error("generate_argument_vars_code: list length mismatch")
 	).
 
-:- pred generate_arg_decl_code(string::in, (type)::in, string::out) is det.
+:- pred generate_arg_decl_code(string::in, (type)::in, module_info::in,
+		string::out) is det.
 
-generate_arg_decl_code(Name, Type, DeclCode) :-
-	export__type_to_type_string(Type, C_Type),
+generate_arg_decl_code(Name, Type, Module, DeclCode) :-
+	export__type_to_type_string(Module, Type, C_Type),
 	string__format("\t\t%s %s;\n", [s(C_Type), s(Name)], DeclCode).
 
 :- pred generate_arg_input_code(string::in, (type)::in, int::in, int::in,
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.53
diff -u -r1.53 hlds_data.m
--- compiler/hlds_data.m	2001/03/01 12:52:48	1.53
+++ compiler/hlds_data.m	2001/04/09 13:06:25
@@ -289,7 +289,9 @@
 		)
 	;	uu_type(list(type))	% not yet implemented!
 	;	eqv_type(type)
-	;	abstract_type.
+	;	abstract_type
+	;	foreign_type(sym_name).	% Name of foreign type which represents
+					% the mercury type.
 
 	% The `cons_tag_values' type stores the information on how
 	% a discriminated union type is represented.
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.258
diff -u -r1.258 hlds_out.m
--- compiler/hlds_out.m	2001/04/07 14:04:40	1.258
+++ compiler/hlds_out.m	2001/04/09 13:06:26
@@ -2570,6 +2570,9 @@
 hlds_out__write_type_body(_Indent, _Tvarset, abstract_type) -->
 	io__write_string(".\n").
 
+hlds_out__write_type_body(_Indent, _Tvarset, foreign_type(_)) -->
+	{ error("hlds_out__write_type_body: foreign type body found") }.
+
 :- pred hlds_out__write_constructors(int, tvarset, list(constructor),
 	io__state, io__state).
 :- mode hlds_out__write_constructors(in, in, in, di, uo) is det.
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.97
diff -u -r1.97 intermod.m
--- compiler/intermod.m	2001/04/07 14:04:42	1.97
+++ compiler/intermod.m	2001/04/09 13:06:26
@@ -1256,6 +1256,9 @@
 		{ Body = abstract_type },
 		mercury_output_type_defn(VarSet,
 			abstract_type(Name, Args), Context)
+	;
+		{ Body = foreign_type(_) },
+		{ error("foreign types not implemented") }
 	).
 
 :- pred intermod__write_modes(module_info::in,
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.274
diff -u -r1.274 llds.m
--- compiler/llds.m	2001/03/13 12:40:12	1.274
+++ compiler/llds.m	2001/04/09 13:06:27
@@ -542,6 +542,8 @@
 	--->	pragma_c_arg_decl(
 			% This local variable corresponds to a procedure arg.
 			type,	% The Mercury type of the argument.
+			string,	% The string which is used to describe the
+				% type in the C code.
 			string	% The name of the local variable that
 				% will hold the value of that argument
 				% inside the C block.
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.174
diff -u -r1.174 llds_out.m
--- compiler/llds_out.m	2001/02/20 14:08:34	1.174
+++ compiler/llds_out.m	2001/04/09 13:06:28
@@ -1848,11 +1848,10 @@
 output_pragma_decls([]) --> [].
 output_pragma_decls([D|Decls]) -->
 	(
-		{ D = pragma_c_arg_decl(Type, VarName) },
 		% Apart from special cases, the local variables are MR_Words
-		{ export__type_to_type_string(Type, VarType) },
+		{ D = pragma_c_arg_decl(_Type, TypeString, VarName) },
 		io__write_string("\t"),
-		io__write_string(VarType),
+		io__write_string(TypeString),
 		io__write_string("\t"),
 		io__write_string(VarName),
 		io__write_string(";\n")
Index: compiler/magic_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.12
diff -u -r1.12 magic_util.m
--- compiler/magic_util.m	2000/10/13 13:55:33	1.12
+++ compiler/magic_util.m	2001/04/09 13:06:29
@@ -1380,6 +1380,8 @@
 	{ error("magic_util__check_type_defn: eqv_type") }.
 magic_util__check_type_defn(abstract_type, _, Errors0, Errors) -->
 	{ set__insert(Errors0, abstract, Errors) }.
+magic_util__check_type_defn(foreign_type(_), _, _, _) -->
+	{ error("magic_util__check_type_defn: foreign_type") }.
 
 :- pred magic_util__check_ctor(set(type_id)::in, constructor::in, 
 		set(argument_error)::in, set(argument_error)::out, 
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.368
diff -u -r1.368 make_hlds.m
--- compiler/make_hlds.m	2001/04/07 14:04:45	1.368
+++ compiler/make_hlds.m	2001/04/09 13:06:31
@@ -413,6 +413,23 @@
 		{ Pragma = foreign_proc(_, _, _, _, _, _) },
 		{ Module = Module0 }
 	;	
+		% XXXX
+		{ Pragma = foreign_type(MercuryType, _, ForeignType) },
+		{ module_info_types(Module0, Types0) },
+
+		{ type_to_type_id(MercuryType, TypeId, _) ->
+			Body = foreign_type(ForeignType),
+
+			hlds_data__set_type_defn(varset__init, [], Body,
+					ImportStatus, Context, TypeDefn),
+
+			% XXX do we need to add special preds!
+			map__set(Types0, TypeId, TypeDefn, Types),
+			module_info_set_types(Module0, Types, Module)
+		;
+			error("add_item_decl_pass_2: type_to_type_id failed")
+		}
+	;
 		% Handle pragma tabled decls later on (when we process
 		% clauses).
 		{ Pragma = tabled(_, _, _, _, _) },
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.184
diff -u -r1.184 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m	2001/04/03 03:19:57	1.184
+++ compiler/mercury_to_mercury.m	2001/04/09 13:06:32
@@ -358,6 +358,15 @@
 		mercury_output_pragma_foreign_code(Attributes, Pred,
 			PredOrFunc, Vars, VarSet, PragmaCode)
 	;
+		{ Pragma = foreign_type(_MercuryType,
+				MercuryTypeSymName, ForeignType) },
+		io__write_string(":- pragma foreign_type("),
+		% output_type(varset__init, no, MercuryType),
+		mercury_output_sym_name(MercuryTypeSymName),
+		io__write_string(", "),
+		mercury_output_sym_name(ForeignType),
+		io__write_string(").\n")
+	;
 		{ Pragma = import(Pred, PredOrFunc, ModeList, Attributes,
 			C_Function) },
 		mercury_output_pragma_import(Pred, PredOrFunc, ModeList,
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.80
diff -u -r1.80 ml_code_gen.m
--- compiler/ml_code_gen.m	2001/04/07 14:04:49	1.80
+++ compiler/ml_code_gen.m	2001/04/09 13:06:33
@@ -2111,8 +2111,12 @@
 	%
 	% Combine all the information about the each arg
 	%
+	=(MLDSGenInfo),
+	{ ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
+	{ list__map(export__type_to_type_string(ModuleInfo),
+			OrigArgTypes, OrigArgTypeStrings) },
 	{ ml_make_c_arg_list(ArgVars, ArgDatas, OrigArgTypes,
-		ArgList) },
+			OrigArgTypeStrings, ArgList) },
 
 	%
 	% Generate <declaration of one local variable for each arg>
@@ -2189,8 +2193,6 @@
 			raw_target_code("\t\tif (MR_succeeded) {\n")],
 			AssignOutputsList
 	]) },
-	=(MLDSGenInfo),
-	{ ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
 	{ module_info_globals(ModuleInfo, Globals) },
 	{ globals__lookup_string_option(Globals, target, Target) },
 	( { CodeModel = model_non } ->
@@ -2312,8 +2314,12 @@
 	%
 	% Combine all the information about the each arg
 	%
+	=(MLDSGenInfo),
+	{ ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
+	{ list__map(export__type_to_type_string(ModuleInfo),
+			OrigArgTypes, OrigArgTypeStrings) },
 	{ ml_make_c_arg_list(ArgVars, ArgDatas, OrigArgTypes,
-		ArgList) },
+			OrigArgTypeStrings, ArgList) },
 
 	%
 	% Generate <declaration of one local variable for each arg>
@@ -2462,23 +2468,26 @@
 	--->	ml_c_arg(
 			prog_var,
 			maybe(pair(string, mode)),	% name and mode
-			prog_type	% original type before
+			prog_type,	% original type before
 					% inlining/specialization
 					% (the actual type may be an instance
 					% of this type, if this type is
 					% polymorphic).
+			string		% For the original type the result
+					% of export:type_to_type_string
 		).
 
 :- pred ml_make_c_arg_list(list(prog_var)::in,
 		list(maybe(pair(string, mode)))::in, list(prog_type)::in,
-		list(ml_c_arg)::out) is det.
+		list(string)::in, list(ml_c_arg)::out) is det.
 
-ml_make_c_arg_list(Vars, ArgDatas, Types, ArgList) :-
-	( Vars = [], ArgDatas = [], Types = [] ->
+ml_make_c_arg_list(Vars, ArgDatas, Types, TypeStrings, ArgList) :-
+	( Vars = [], ArgDatas = [], Types = [], TypeStrings = [] ->
 		ArgList = []
-	; Vars = [V|Vs], ArgDatas = [N|Ns], Types = [T|Ts] ->
-		Arg = ml_c_arg(V, N, T),
-		ml_make_c_arg_list(Vs, Ns, Ts, Args),
+	; Vars = [V|Vs], ArgDatas = [N|Ns],
+			Types = [T|Ts], TypeStrings = [TS|TSs] ->
+		Arg = ml_c_arg(V, N, T, TS),
+		ml_make_c_arg_list(Vs, Ns, Ts, TSs, Args),
 		ArgList = [Arg | Args]
 	;
 		error("ml_code_gen:make_c_arg_list - length mismatch")
@@ -2502,12 +2511,12 @@
 %
 :- pred ml_gen_pragma_c_decl(ml_c_arg::in, target_code_component::out) is det.
 
-ml_gen_pragma_c_decl(ml_c_arg(_Var, MaybeNameAndMode, Type), Decl) :-
+ml_gen_pragma_c_decl(ml_c_arg(_Var, MaybeNameAndMode, _Type, TypeString),
+		Decl) :-
 	(
 		MaybeNameAndMode = yes(ArgName - _Mode),
 		\+ var_is_singleton(ArgName)
 	->
-		export__type_to_type_string(Type, TypeString),
 		string__format("\t%s %s;\n", [s(TypeString), s(ArgName)],
 			DeclString)
 	;
@@ -2551,7 +2560,7 @@
 		list(target_code_component)::out,
 		ml_gen_info::in, ml_gen_info::out) is det.
 
-ml_gen_pragma_c_input_arg(ml_c_arg(Var, MaybeNameAndMode, OrigType),
+ml_gen_pragma_c_input_arg(ml_c_arg(Var, MaybeNameAndMode, OrigType, TypeString),
 		AssignInput) -->
 	=(MLDSGenInfo),
 	{ ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
@@ -2583,7 +2592,6 @@
 			% --high-level-data, so we always use a cast here.
 			% (Strictly speaking the cast is not needed for
 			% a few cases like `int', but it doesn't do any harm.)
-			export__type_to_type_string(OrigType, TypeString),
 			string__format("(%s)", [s(TypeString)], Cast)
 		;
 			% For --no-high-level-data, we only need to use
@@ -2634,7 +2642,8 @@
 		mlds__defns::out, mlds__statements::out,
 		ml_gen_info::in, ml_gen_info::out) is det.
 
-ml_gen_pragma_c_output_arg(ml_c_arg(Var, MaybeNameAndMode, OrigType),
+ml_gen_pragma_c_output_arg(
+		ml_c_arg(Var, MaybeNameAndMode, OrigType, TypeString),
 		Context, AssignOutput, ConvDecls, ConvOutputStatements) -->
 	=(MLDSGenInfo),
 	{ ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
@@ -2661,7 +2670,6 @@
 			% Note that we can't easily obtain the type string
 			% for the RHS of the assignment, so instead we
 			% cast the LHS.
-			export__type_to_type_string(OrigType, TypeString),
 			string__format("*(%s *)&", [s(TypeString)], LHS_Cast),
 			RHS_Cast = ""
 		;
Index: compiler/ml_simplify_switch.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_simplify_switch.m,v
retrieving revision 1.2
diff -u -r1.2 ml_simplify_switch.m
--- compiler/ml_simplify_switch.m	2001/01/20 15:42:47	1.2
+++ compiler/ml_simplify_switch.m	2001/04/09 13:06:33
@@ -100,9 +100,9 @@
 :- pred is_integral_type(mlds__type::in) is semidet.
 is_integral_type(mlds__native_int_type).
 is_integral_type(mlds__native_char_type).
-is_integral_type(mlds__mercury_type(_, int_type)).
-is_integral_type(mlds__mercury_type(_, char_type)).
-is_integral_type(mlds__mercury_type(_, enum_type)).
+is_integral_type(mlds__mercury_type(_, int_type, _)).
+is_integral_type(mlds__mercury_type(_, char_type, _)).
+is_integral_type(mlds__mercury_type(_, enum_type, _)).
 
 :- pred is_dense_switch(list(mlds__switch_case)::in, int::in) is semidet.
 is_dense_switch(Cases, ReqDensity) :-
Index: compiler/ml_string_switch.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_string_switch.m,v
retrieving revision 1.5
diff -u -r1.5 ml_string_switch.m
--- compiler/ml_string_switch.m	2001/02/20 07:52:18	1.5
+++ compiler/ml_string_switch.m	2001/04/09 13:06:33
@@ -291,4 +291,4 @@
 	).
 
 :- func ml_string_type = mlds__type.
-ml_string_type = mercury_type(string_type, str_type).
+ml_string_type = mercury_type(string_type, str_type, "MR_String").
Index: compiler/ml_switch_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.7
diff -u -r1.7 ml_switch_gen.m
--- compiler/ml_switch_gen.m	2001/01/10 11:15:32	1.7
+++ compiler/ml_switch_gen.m	2001/04/09 13:06:33
@@ -99,7 +99,7 @@
 :- import_module ml_tag_switch, ml_string_switch.
 :- import_module ml_code_gen, ml_unify_gen, ml_code_util, ml_simplify_switch.
 :- import_module switch_util, type_util.
-:- import_module options.
+:- import_module export, options.
 
 :- import_module bool, int, string, map, tree, std_util, require.
 
@@ -395,8 +395,9 @@
 ml_switch_gen_range(MLDS_Type, Range) -->
 	=(MLGenInfo),
 	{
-		MLDS_Type = mercury_type(Type, TypeCategory),
 		ml_gen_info_get_module_info(MLGenInfo, ModuleInfo),
+		export__type_to_type_string(ModuleInfo, Type, TypeString),
+		MLDS_Type = mercury_type(Type, TypeCategory, TypeString),
 		switch_util__type_range(TypeCategory, Type, ModuleInfo,
 			MinRange, MaxRange)
 	->
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.5
diff -u -r1.5 ml_type_gen.m
--- compiler/ml_type_gen.m	2001/02/20 07:52:17	1.5
+++ compiler/ml_type_gen.m	2001/04/09 13:06:34
@@ -106,6 +106,9 @@
 		ml_gen_du_parent_type(ModuleInfo, TypeId, TypeDefn,
 			Ctors, TagValues, MaybeEqualityMembers)
 	).
+	% XXXX
+ml_gen_type_2(foreign_type(_), _, _, _) -->
+	{ error("sorry, foreign types not implemented") }.
 
 %-----------------------------------------------------------------------------%
 %
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.32
diff -u -r1.32 ml_unify_gen.m
--- compiler/ml_unify_gen.m	2001/03/13 12:40:16	1.32
+++ compiler/ml_unify_gen.m	2001/04/09 13:06:34
@@ -1129,7 +1129,7 @@
 
 ml_gen_box_const_rval(Type, Rval, Context, ConstDefns, BoxedRval) -->
 	(
-		{ Type = mercury_type(term__variable(_), _)
+		{ Type = mercury_type(term__variable(_), _, _)
 		; Type = mlds__generic_type
 		}
 	->
@@ -1144,7 +1144,7 @@
 		% but calls to malloc() are not).
 		%
 		{ Type = mercury_type(term__functor(term__atom("float"),
-				[], _), _)
+				[], _), _, _)
 		; Type = mlds__native_float_type
 		}
 	->
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.49
diff -u -r1.49 mlds.m
--- compiler/mlds.m	2001/02/28 15:59:18	1.49
+++ compiler/mlds.m	2001/04/09 13:06:35
@@ -486,9 +486,12 @@
 :- type mlds__type
 	--->	% Mercury data types
 		mercury_type(
-			prog_data__type,	% the exact Mercury type
-			builtin_type		% what kind of type it is:
-						% enum, float, etc.
+			prog_data__type, % the exact Mercury type
+			builtin_type,	% what kind of type it is:
+					% enum, float, etc.
+			string		% the result of 
+					% export__type_to_type_string
+			
 		)
 
 		% The type for the continuation functions used
@@ -508,6 +511,10 @@
 	;	mlds__native_float_type
 	;	mlds__native_char_type
 
+		% This is a type of the MLDS target language.  Currently
+		% this is only used by the il backend.
+	;	mlds__foreign_type(sym_name)
+
 		% MLDS types defined using mlds__class_defn
 	;	mlds__class_type(
 			mlds__class,		% name
@@ -1354,8 +1361,8 @@
 %-----------------------------------------------------------------------------%
 
 :- implementation.
-:- import_module modules.
-:- import_module int, term, string, require.
+:- import_module export, modules.
+:- import_module int, map, require, string, term.  
 
 %-----------------------------------------------------------------------------%
 
@@ -1380,8 +1387,24 @@
 % XXX It might be a better idea to get rid of the mercury_type/2
 % MLDS type and instead fully convert all Mercury types to MLDS types.
 
-mercury_type_to_mlds_type(ModuleInfo, Type) = mercury_type(Type, Category) :-
-	classify_type(Type, ModuleInfo, Category).
+mercury_type_to_mlds_type(ModuleInfo, Type) = MLDS_Type :-
+	module_info_types(ModuleInfo, Types),
+	classify_type(Type, ModuleInfo, Category),
+	export__type_to_type_string(ModuleInfo, Type, TypeString),
+	(
+		type_to_type_id(Type, TypeId, _),
+		map__search(Types, TypeId, TypeDefn)
+	->
+		hlds_data__get_type_defn_body(TypeDefn, Body),
+		( Body = foreign_type(ForeignType) ->
+			MLDS_Type = mlds__foreign_type(ForeignType)
+		;
+			MLDS_Type = mercury_type(Type, Category, TypeString)
+		)
+	;
+		MLDS_Type = mercury_type(Type, Category, TypeString)
+	).
+	
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.83
diff -u -r1.83 mlds_to_c.m
--- compiler/mlds_to_c.m	2001/03/09 14:35:27	1.83
+++ compiler/mlds_to_c.m	2001/04/09 13:06:36
@@ -42,7 +42,6 @@
 :- import_module ml_code_util.	% for ml_gen_public_field_decl_flags, which is
 				% used by the code that handles derived classes
 :- import_module ml_type_gen.	% for ml_gen_type_name
-:- import_module export.	% for export__type_to_type_string
 :- import_module globals, options, passes_aux.
 :- import_module builtin_ops, c_util, modules.
 :- import_module prog_data, prog_out, type_util, error_util.
@@ -600,9 +599,8 @@
 :- mode mlds_output_pragma_export_type(in, in, di, uo) is det.
 
 mlds_output_pragma_export_type(suffix, _Type) --> [].
-mlds_output_pragma_export_type(prefix, mercury_type(Type, _)) -->
-	{ export__type_to_type_string(Type, String) },
-	io__write_string(String).
+mlds_output_pragma_export_type(prefix, mercury_type(_, _, TypeString)) -->
+	io__write_string(TypeString).
 mlds_output_pragma_export_type(prefix, mlds__cont_type(_)) -->
 	io__write_string("MR_Word").
 mlds_output_pragma_export_type(prefix, mlds__commit_type) -->
@@ -615,6 +613,8 @@
 	io__write_string("MR_Float").
 mlds_output_pragma_export_type(prefix, mlds__native_char_type) -->
 	io__write_string("MR_Char").
+mlds_output_pragma_export_type(prefix, mlds__foreign_type(_)) -->
+	{ error("mlds_output_pragma_export_type: foreign_type") }.
 mlds_output_pragma_export_type(prefix, mlds__class_type(_, _, _)) -->
 	io__write_string("MR_Word").
 mlds_output_pragma_export_type(prefix, mlds__array_type(_)) -->
@@ -857,7 +857,7 @@
 			Kind \= mlds__enum,
 			ClassType = Type
 		;
-			Type = mercury_type(MercuryType, user_type),
+			Type = mercury_type(MercuryType, user_type, _),
 			type_to_type_id(MercuryType, TypeId, _ArgsTypes),
 			ml_gen_type_name(TypeId, ClassName, ClassArity),
 			ClassType = mlds__class_type(ClassName, ClassArity,
@@ -1513,12 +1513,14 @@
 :- pred mlds_output_type_prefix(mlds__type, io__state, io__state).
 :- mode mlds_output_type_prefix(in, di, uo) is det.
 
-mlds_output_type_prefix(mercury_type(Type, TypeCategory)) -->
+mlds_output_type_prefix(mercury_type(Type, TypeCategory, _)) -->
 	mlds_output_mercury_type_prefix(Type, TypeCategory).
 mlds_output_type_prefix(mlds__native_int_type)   --> io__write_string("int").
 mlds_output_type_prefix(mlds__native_float_type) --> io__write_string("float").
 mlds_output_type_prefix(mlds__native_bool_type)  --> io__write_string("bool").
 mlds_output_type_prefix(mlds__native_char_type)  --> io__write_string("char").
+mlds_output_type_prefix(mlds__foreign_type(_)) -->
+	{ error("mlds_output_type_prefix: foreign_type") }.
 mlds_output_type_prefix(mlds__class_type(Name, Arity, ClassKind)) -->
 	( { ClassKind = mlds__enum } ->
 		%
@@ -1671,11 +1673,12 @@
 		io__state, io__state).
 :- mode mlds_output_type_suffix(in, in, di, uo) is det.
 
-mlds_output_type_suffix(mercury_type(_, _), _) --> [].
+mlds_output_type_suffix(mercury_type(_, _, _), _) --> [].
 mlds_output_type_suffix(mlds__native_int_type, _) --> [].
 mlds_output_type_suffix(mlds__native_float_type, _) --> [].
 mlds_output_type_suffix(mlds__native_bool_type, _) --> [].
 mlds_output_type_suffix(mlds__native_char_type, _) --> [].
+mlds_output_type_suffix(mlds__foreign_type(_), _) --> [].
 mlds_output_type_suffix(mlds__class_type(_, _, _), _) --> [].
 mlds_output_type_suffix(mlds__ptr_type(_), _) --> [].
 mlds_output_type_suffix(mlds__array_type(_), ArraySize) -->
@@ -2557,7 +2560,7 @@
 		FieldType, _ClassType)) -->
 	(
 		{ FieldType = mlds__generic_type
-		; FieldType = mlds__mercury_type(term__variable(_), _)
+		; FieldType = mlds__mercury_type(term__variable(_), _, _)
 		}
 	->
 		% XXX this generated code is ugly;
@@ -2742,7 +2745,7 @@
 mlds_output_boxed_rval(Type, Exprn) -->
 	(
 		{ Type = mlds__mercury_type(term__functor(term__atom("float"),
-				[], _), _)
+				[], _), _, _)
 		; Type = mlds__native_float_type
 		}
 	->
@@ -2751,7 +2754,7 @@
 		io__write_string(")")
 	;
 		{ Type = mlds__mercury_type(term__functor(term__atom("character"),
-				[], _), _)
+				[], _), _, _)
 		; Type = mlds__native_char_type
 		; Type = mlds__native_bool_type
 		; Type = mlds__native_int_type
@@ -2775,7 +2778,7 @@
 mlds_output_unboxed_rval(Type, Exprn) -->
 	(
 		{ Type = mlds__mercury_type(term__functor(term__atom("float"),
-				[], _), _)
+				[], _), _, _)
 		; Type = mlds__native_float_type
 		}
 	->
@@ -2784,7 +2787,7 @@
 		io__write_string(")")
 	;
 		{ Type = mlds__mercury_type(term__functor(term__atom("character"),
-				[], _), _)
+				[], _), _, _)
 		; Type = mlds__native_char_type
 		; Type = mlds__native_bool_type
 		; Type = mlds__native_int_type
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.15
diff -u -r1.15 mlds_to_il.m
--- compiler/mlds_to_il.m	2001/03/16 04:17:46	1.15
+++ compiler/mlds_to_il.m	2001/04/09 13:06:37
@@ -1810,11 +1810,15 @@
 
 mlds_type_to_ilds_type(mlds__native_float_type) = ilds__type([], float64).
 
+mlds_type_to_ilds_type(mlds__foreign_type(ForeignType))
+	= ilds__type([], Class) :-
+	Class = class(sym_name_to_structured_name(ForeignType)).
+
 mlds_type_to_ilds_type(mlds__ptr_type(MLDSType)) =
 	ilds__type([], '&'(mlds_type_to_ilds_type(MLDSType))).
 
 	% XXX should use the classification now that it is available.
-mlds_type_to_ilds_type(mercury_type(Type, _Classification)) = ILType :-
+mlds_type_to_ilds_type(mercury_type(Type, _Classification, _)) = ILType :-
 	( 
 		Type = term__functor(term__atom(Atom), [], _),
 		( Atom = "string", 	SimpleType = il_string_simple_type
@@ -1843,6 +1847,13 @@
 
 mlds_type_to_ilds_type(mlds__unknown_type) = _ :-
 	unexpected(this_file, "mlds_type_to_ilds_type: unknown_type").
+
+:- func sym_name_to_structured_name(sym_name) = structured_name.
+
+sym_name_to_structured_name(unqualified(Name)) = [Name].
+sym_name_to_structured_name(qualified(Specifier, Name))
+	= sym_name_to_structured_name(Specifier) ++ [Name].
+
 %-----------------------------------------------------------------------------
 %
 % Name mangling.
@@ -2110,16 +2121,22 @@
 	mlds__array_type(mlds__generic_type).
 rval_const_to_type(code_addr_const(_)) = mlds__func_type(
 		mlds__func_params([], [])).
-rval_const_to_type(int_const(_)) = mercury_type(
-	term__functor(term__atom("int"), [], context("", 0)), int_type).
-rval_const_to_type(float_const(_)) = mercury_type(
-	term__functor(term__atom("float"), [], context("", 0)), float_type).
+rval_const_to_type(int_const(_)) 
+	= mercury_type(term__functor(term__atom("int"), [], context("", 0)),
+			int_type, "MR_Integer").
+rval_const_to_type(float_const(_))
+	= mercury_type(term__functor(term__atom("float"), [], context("", 0)),
+		float_type, "MR_Float").
 rval_const_to_type(false) = mlds__native_bool_type.
 rval_const_to_type(true) = mlds__native_bool_type.
-rval_const_to_type(string_const(_)) = mercury_type(
-	term__functor(term__atom("string"), [], context("", 0)), str_type).
-rval_const_to_type(multi_string_const(_, _)) = mercury_type(
-	term__functor(term__atom("string"), [], context("", 0)), str_type).
+rval_const_to_type(string_const(_))
+	= mercury_type(
+		term__functor(term__atom("string"), [], context("", 0)),
+			str_type, "MR_String").
+rval_const_to_type(multi_string_const(_, _))
+	= mercury_type(term__functor(term__atom("string"), [], context("", 0)),
+			% XXX Should this be MR_Word instead?
+			str_type, "MR_String").
 rval_const_to_type(null(MldsType)) = MldsType.
 
 %-----------------------------------------------------------------------------%
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.2
diff -u -r1.2 mlds_to_java.m
--- compiler/mlds_to_java.m	2001/03/01 15:52:35	1.2
+++ compiler/mlds_to_java.m	2001/04/09 13:06:37
@@ -61,7 +61,6 @@
 :- import_module ml_code_util.	% for ml_gen_mlds_var_decl, which is used by
 				% the code that handles derived classes
 :- import_module ml_type_gen.	% for ml_gen_type_name
-:- import_module export.	% for export__type_to_type_string
 :- import_module globals, options, passes_aux.
 :- import_module builtin_ops.
 :- import_module prog_data, prog_out, type_util, error_util.
@@ -157,7 +156,7 @@
 :- mode type_is_enum(in) is semidet.
 
 type_is_enum(Type) :-
-	Type = mercury_type(_, Builtin),
+	Type = mercury_type(_, Builtin, _),
 	Builtin = enum_type.
 
 	%  Succeeds iff this type is something that 
@@ -168,7 +167,7 @@
 :- mode type_is_object(in) is semidet.
 
 type_is_object(Type) :-
-	Type = mercury_type(_, Builtin),
+	Type = mercury_type(_, Builtin, _),
 	( Builtin = enum_type 
 	; Builtin = polymorphic_type
 	; Builtin = user_type 
@@ -861,21 +860,24 @@
 :- func get_java_type_initializer(mlds__type) = string.
 :- mode get_java_type_initializer(in) = out is det.
 
-get_java_type_initializer(mercury_type(_, int_type)) = "0".
-get_java_type_initializer(mercury_type(_, char_type)) = "0".
-get_java_type_initializer(mercury_type(_, float_type)) = "0".
-get_java_type_initializer(mercury_type(_, str_type)) = "null".
-get_java_type_initializer(mercury_type(_, pred_type)) = "null".
-get_java_type_initializer(mercury_type(_, tuple_type)) = "null".
-get_java_type_initializer(mercury_type(_, enum_type)) = "null".
-get_java_type_initializer(mercury_type(_, polymorphic_type)) = "null".
-get_java_type_initializer(mercury_type(_, user_type)) = "null".
+get_java_type_initializer(mercury_type(_, int_type, _)) = "0".
+get_java_type_initializer(mercury_type(_, char_type, _)) = "0".
+get_java_type_initializer(mercury_type(_, float_type, _)) = "0".
+get_java_type_initializer(mercury_type(_, str_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, pred_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, tuple_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, enum_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, polymorphic_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, user_type, _)) = "null".
 get_java_type_initializer(mlds__cont_type(_)) = "null".
 get_java_type_initializer(mlds__commit_type) = "null".
 get_java_type_initializer(mlds__native_bool_type) = "false".
 get_java_type_initializer(mlds__native_int_type) = "0".
 get_java_type_initializer(mlds__native_float_type) = "0".
 get_java_type_initializer(mlds__native_char_type) = "0".
+get_java_type_initializer(mlds__foreign_type(_)) = _ :-
+	unexpected(this_file, 
+		"get_type_initializer: variable has foreign_type"). 
 get_java_type_initializer(mlds__class_type(_, _, _)) = "null".
 get_java_type_initializer(mlds__array_type(_)) = "null".
 get_java_type_initializer(mlds__ptr_type(_)) = "null".
@@ -1208,12 +1210,14 @@
 :- pred output_type(mlds__type, io__state, io__state).
 :- mode output_type(in, di, uo) is det.
 
-output_type(mercury_type(Type, TypeCategory)) -->
+output_type(mercury_type(Type, TypeCategory, _)) -->
 	output_mercury_type(Type, TypeCategory).
 output_type(mlds__native_int_type)   --> io__write_string("int").
 output_type(mlds__native_float_type) --> io__write_string("double").
 output_type(mlds__native_bool_type) --> io__write_string("boolean").
 output_type(mlds__native_char_type)  --> io__write_string("char").
+output_type(mlds__foreign_type(_))  -->
+	{ unexpected(this_file, "output_type: foreign_type NYI.") }.
 output_type(mlds__class_type(Name, Arity, ClassKind)) -->
 	( { ClassKind = mlds__enum } ->
 		output_fully_qualified(Name, output_mangled_name),
@@ -1882,9 +1886,10 @@
 				( 
 				    { TargetType = ArgType }
 			  	; 
-			    	    { TargetType = 
-					mercury_type(_, TargetBuiltinType),
-			      	      ArgType = mercury_type(_, ArgBuiltinType),
+			    	    { TargetType = mercury_type(
+				    		_, TargetBuiltinType, _),
+			      	      ArgType = mercury_type(
+				      		_, ArgBuiltinType, _),
 			      	      TargetBuiltinType = ArgBuiltinType }
 			  	) 
 			
@@ -2093,17 +2098,18 @@
 java_builtin_type(Type, "int", "java.lang.Integer", "intValue") :-
 	Type = mlds__native_int_type.
 java_builtin_type(Type, "int", "java.lang.Integer", "intValue") :-
-	Type = mlds__mercury_type(term__functor(term__atom("int"), [], _), _).
+	Type = mlds__mercury_type(term__functor(term__atom("int"),
+		[], _), _, _).
 java_builtin_type(Type, "double", "java.lang.Double", "doubleValue") :-
 	Type = mlds__native_float_type.
 java_builtin_type(Type, "double", "java.lang.Double", "doubleValue") :-
 	Type = mlds__mercury_type(term__functor(term__atom("float"),
-		[], _), _).
+		[], _), _, _).
 java_builtin_type(Type, "char", "java.lang.Character", "charValue") :-
 	Type = mlds__native_char_type.
 java_builtin_type(Type, "char", "java.lang.Character", "charValue") :-
 	Type = mlds__mercury_type(term__functor(term__atom("character"),
-		[], _), _).
+		[], _), _, _).
 java_builtin_type(Type, "boolean", "java.lang.Boolean", "booleanValue") :-
 	Type = mlds__native_bool_type.
 
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.65
diff -u -r1.65 module_qual.m
--- compiler/module_qual.m	2001/04/03 03:20:06	1.65
+++ compiler/module_qual.m	2001/04/09 13:06:38
@@ -210,7 +210,12 @@
 collect_mq_info_2(func(_,_,__,_,_,_,_,_,_,_), Info, Info).
 collect_mq_info_2(pred_mode(_,_,_,_,_), Info, Info).
 collect_mq_info_2(func_mode(_,_,_,_,_,_), Info, Info).
-collect_mq_info_2(pragma(_), Info, Info).
+collect_mq_info_2(pragma(Pragma), Info0, Info) :-
+	( Pragma = foreign_type(_Type, SymName, _ForeignType) ->
+		add_type_defn(abstract_type(SymName, []), Info0, Info)
+	;
+		Info = Info0
+	).
 collect_mq_info_2(assertion(Goal, _ProgVarSet), Info0, Info) :-
 	process_assert(Goal, SymNames, Success),
 	(
@@ -901,6 +906,9 @@
 qualify_pragma(source_file(File), source_file(File), Info, Info) --> [].
 qualify_pragma(foreign_decl(L, Code), foreign_decl(L, Code), Info, Info) --> [].
 qualify_pragma(foreign_code(L, C), foreign_code(L, C), Info, Info) --> [].
+qualify_pragma(foreign_type(Type0, SymName, F),
+		foreign_type(Type, SymName, F), Info0, Info) -->
+	qualify_type(Type0, Type, Info0, Info).
 qualify_pragma(
 	    foreign_proc(Rec, SymName, PredOrFunc, PragmaVars0, Varset, Code),
 	    foreign_proc(Rec, SymName, PredOrFunc, PragmaVars, Varset, Code), 
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.158
diff -u -r1.158 modules.m
--- compiler/modules.m	2001/04/08 08:59:21	1.158
+++ compiler/modules.m	2001/04/09 13:06:39
@@ -1029,6 +1029,7 @@
 pragma_allowed_in_interface(foreign_decl(_, _), no).
 pragma_allowed_in_interface(foreign_code(_, _), no).
 pragma_allowed_in_interface(foreign_proc(_, _, _, _, _, _), no).
+pragma_allowed_in_interface(foreign_type(_, _, _), yes).
 pragma_allowed_in_interface(inline(_, _), no).
 pragma_allowed_in_interface(no_inline(_, _), no).
 pragma_allowed_in_interface(obsolete(_, _), yes).
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.44
diff -u -r1.44 pragma_c_gen.m
--- compiler/pragma_c_gen.m	2001/04/03 03:20:14	1.44
+++ compiler/pragma_c_gen.m	2001/04/09 13:06:40
@@ -42,7 +42,7 @@
 :- implementation.
 
 :- import_module hlds_module, hlds_pred, llds_out, trace, tree.
-:- import_module code_util.
+:- import_module code_util, export.
 :- import_module options, globals.
 
 :- import_module bool, string, int, assoc_list, set, map, require, term.
@@ -423,13 +423,13 @@
 	%
 	% Generate <declaration of one local variable for each arg>
 	%
-	{ make_pragma_decls(Args, Decls) },
+	code_info__get_module_info(ModuleInfo),
+	{ make_pragma_decls(Args, ModuleInfo, Decls) },
 
 	%
 	% Generate #define MR_PROC_LABEL <procedure label> /* see note (5) */
 	% and #undef MR_PROC_LABEL
 	%
-	code_info__get_module_info(ModuleInfo),
 	code_info__get_pred_id(CallerPredId),
 	code_info__get_proc_id(CallerProcId),
 	{ make_proc_label_hash_define(ModuleInfo, CallerPredId, CallerProcId,
@@ -637,8 +637,8 @@
 	{ make_c_arg_list(ArgVars, ArgDatas, OrigArgTypes, ArgInfos, Args) },
 	{ pragma_select_in_args(Args, InArgs) },
 	{ pragma_select_out_args(Args, OutArgs) },
-	{ make_pragma_decls(Args, Decls) },
-	{ make_pragma_decls(OutArgs, OutDecls) },
+	{ make_pragma_decls(Args, ModuleInfo, Decls) },
+	{ make_pragma_decls(OutArgs, ModuleInfo, OutDecls) },
 
 	{ input_descs_from_arg_info(InArgs, InputDescs) },
 	{ output_descs_from_arg_info(OutArgs, OutputDescs) },
@@ -1090,21 +1090,23 @@
 % data structure in the LLDS. It is essentially a list of pairs of type and
 % variable name, so that declarations of the form "Type Name;" can be made.
 
-:- pred make_pragma_decls(list(c_arg)::in, list(pragma_c_decl)::out) is det.
+:- pred make_pragma_decls(list(c_arg)::in, module_info::in,
+		list(pragma_c_decl)::out) is det.
 
-make_pragma_decls([], []).
-make_pragma_decls([Arg | Args], Decls) :-
+make_pragma_decls([], _, []).
+make_pragma_decls([Arg | Args], Module, Decls) :-
 	Arg = c_arg(_Var, ArgName, OrigType, _ArgInfo),
 	(
 		var_is_not_singleton(ArgName, Name)
 	->
-		Decl = pragma_c_arg_decl(OrigType, Name),
-		make_pragma_decls(Args, Decls1),
+		export__type_to_type_string(Module, OrigType, OrigTypeString),
+		Decl = pragma_c_arg_decl(OrigType, OrigTypeString, Name),
+		make_pragma_decls(Args, Module, Decls1),
 		Decls = [Decl | Decls1]
 	;
 		% if the variable doesn't occur in the ArgNames list,
 		% it can't be used, so we just ignore it
-		make_pragma_decls(Args, Decls)
+		make_pragma_decls(Args, Module, Decls)
 	).
 
 %---------------------------------------------------------------------------%
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.65
diff -u -r1.65 prog_data.m
--- compiler/prog_data.m	2001/04/03 03:20:15	1.65
+++ compiler/prog_data.m	2001/04/09 13:06:40
@@ -158,6 +158,9 @@
 			%	whether or not the code is thread-safe
 			% PredName, Predicate or Function, Vars/Mode, 
 			% VarNames, Foreign Code Implementation Info
+
+	;	foreign_type((type), sym_name, sym_name)
+			% MercuryType, MercuryTypeName, ForeignType
 	
 	;	type_spec(sym_name, sym_name, arity, maybe(pred_or_func),
 			maybe(list(mode)), type_subst, tvarset)
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.30
diff -u -r1.30 prog_io_pragma.m
--- compiler/prog_io_pragma.m	2001/04/03 03:20:16	1.30
+++ compiler/prog_io_pragma.m	2001/04/09 13:06:40
@@ -70,6 +70,44 @@
 			ErrorTerm)
 	).
 
+parse_pragma_type(ModuleName, "foreign_type", PragmaTerms,
+            ErrorTerm, _VarSet, Result) :-
+    ( PragmaTerms = [MercuryName, ForeignName] ->
+	parse_implicitly_qualified_term(ModuleName, MercuryName,
+		ErrorTerm, "`:- pragma unused_args' declaration",
+		MaybeMercuryType),
+	(
+	    MaybeMercuryType = ok(MercuryTypeSymName, MercuryArgs),
+	    ( MercuryArgs = [] ->
+		parse_qualified_term(ForeignName, ErrorTerm,
+		    "`:- pragma foreign_type' declaration",
+		    MaybeForeignType),
+		(
+		    MaybeForeignType = ok(ForeignType, ForeignArgs),
+		    ( ForeignArgs = [] ->
+        		term__coerce(MercuryName, MercuryType),
+			Result = ok(pragma(foreign_type(MercuryType,
+				MercuryTypeSymName, ForeignType)))
+		    ;
+			Result = error("foreign type arity not 0", ErrorTerm)
+		    )
+		;
+		    MaybeForeignType = error(String, Term),
+		    Result = error(String, Term)
+		)
+	    ;
+		Result = error("mercury type arity not 0", ErrorTerm)
+	    )
+	;
+	    MaybeMercuryType = error(String, Term),
+	    Result = error(String, Term)
+	)
+    ;
+        Result = error(
+    "wrong number of arguments in `:- pragma foreign_type' declaration",
+            ErrorTerm)
+    ).
+
 parse_pragma_type(ModuleName, "foreign_decl", PragmaTerms,
 			ErrorTerm, VarSet, Result) :-
 	parse_pragma_foreign_decl_pragma(ModuleName, "foreign_decl",
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.12
diff -u -r1.12 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m	2001/02/20 07:52:19	1.12
+++ compiler/rtti_to_mlds.m	2001/04/09 13:06:41
@@ -135,7 +135,7 @@
 		Init, []) :-
 	Init = gen_init_array(gen_init_maybe(
 			mercury_type(functor(atom("string"), [],
-				context("", 0)), str_type),
+				context("", 0)), str_type, "MR_String"),
 			gen_init_string), MaybeNames).
 gen_init_rtti_data_defn(field_types(_RttiTypeId, _Ordinal, Types),
 		ModuleName, _, Init, []) :-
@@ -249,7 +249,7 @@
 	Init = gen_init_pseudo_type_info_defn(Pseudo, ModuleName).
 
 :- func ml_string_type = mlds__type.
-ml_string_type = mercury_type(string_type, str_type).
+ml_string_type = mercury_type(string_type, str_type, "MR_String").
 
 :- func gen_init_functors_info(type_ctor_functors_info, module_name,
 		rtti_type_id) = mlds__initializer.
Index: compiler/term_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_util.m,v
retrieving revision 1.14
diff -u -r1.14 term_util.m
--- compiler/term_util.m	2000/09/18 11:51:47	1.14
+++ compiler/term_util.m	2001/04/09 13:06:41
@@ -268,6 +268,10 @@
 		% but we will never see them in this analysis
 		TypeBody = abstract_type,
 		Weights = Weights0
+	;
+		% This type does not introduce any functors
+		TypeBody = foreign_type(_),
+		Weights = Weights0
 	).
 
 :- pred find_weights_for_cons_list(list(constructor)::in,
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.13
diff -u -r1.13 type_ctor_info.m
--- compiler/type_ctor_info.m	2001/03/18 23:09:59	1.13
+++ compiler/type_ctor_info.m	2001/04/09 13:06:41
@@ -87,6 +87,8 @@
 			map__lookup(TypeTable, TypeId, TypeDefn),
 			hlds_data__get_type_defn_body(TypeDefn, TypeBody),
 			TypeBody \= abstract_type,
+				% XXXX
+			TypeBody \= foreign_type(_),
 			\+ type_id_has_hand_defined_rtti(TypeId)
 		->
 			type_ctor_info__gen_type_ctor_gen_info(TypeId,
@@ -254,6 +256,15 @@
 		error("type_ctor_layout: sorry, undiscriminated union unimplemented\n")
 	;
 		TypeBody = abstract_type,
+		TypeCtorRep = unknown,
+		NumFunctors = -1,
+		FunctorsInfo = no_functors,
+		LayoutInfo = no_layout,
+		TypeTables = [],
+		NumPtags = -1
+	;
+			% XXXX
+		TypeBody = foreign_type(_),
 		TypeCtorRep = unknown,
 		NumFunctors = -1,
 		FunctorsInfo = no_functors,
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.92
diff -u -r1.92 unify_proc.m
--- compiler/unify_proc.m	2001/03/18 23:10:00	1.92
+++ compiler/unify_proc.m	2001/04/09 13:06:46
@@ -744,6 +744,9 @@
 	;
 		{ TypeBody = abstract_type },
 		{ error("trying to create unify proc for abstract type") }
+	;
+		{ TypeBody = foreign_type(_) },
+		{ error("trying to create unify proc for foreign type") }
 	).
 
 	% This predicate generates the bodies of index predicates for the
@@ -798,6 +801,9 @@
 	;
 		{ TypeBody = abstract_type },
 		{ error("trying to create index proc for abstract type") }
+	;
+		{ TypeBody = foreign_type(_) },
+		{ error("trying to create index proc for foreign type") }
 	).
 
 :- pred unify_proc__generate_compare_clauses((type)::in, hlds_type_body::in,
@@ -865,6 +871,9 @@
 	;
 		{ TypeBody = abstract_type },
 		{ error("trying to create compare proc for abstract type") }
+	;
+		{ TypeBody = foreign_type(_) },
+		{ error("trying to create compare proc for foreign type") }
 	).
 
 :- pred unify_proc__quantify_clauses_body(list(prog_var)::in, hlds_goal::in,

--------------------------------------------------------------------------
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