[m-rev.] for review: fix C foreign_type

[Peter Ross]

On Fri, May 17, 2002 at 12:43:49AM +1000, Fergus Henderson wrote:
> For review by Pete and/or Tyson.
> 
> Estimated hours taken: 12
> Branches: main
> 
> Implement C `pragma foreign_type' properly.
> 

This looks fine modulo adding some comments.  Feel free to check in.

> 
> Workspace: /home/ceres/fjh/mercury
> Index: compiler/export.m
> ===================================================================
> RCS file: /home/mercury1/repository/mercury/compiler/export.m,v
> retrieving revision 1.54
> diff -u -d -r1.54 export.m
> --- compiler/export.m	7 May 2002 14:43:39 -0000	1.54
> +++ compiler/export.m	16 May 2002 12:24:02 -0000
> @@ -335,15 +335,25 @@
>  			RetArgMode = top_out,
>  			\+ type_util__is_dummy_argument_type(RetType)
>  		->
> -			C_RetType = llds_exported_type_string(Module, RetType),
> +			Export_RetType = foreign__to_exported_type(Module,
> +				RetType),
> +			C_RetType = foreign__to_type_string(c, Export_RetType),
>  			argloc_to_string(RetArgLoc, RetArgString0),
>  			convert_type_from_mercury(RetArgString0, RetType,
>  				RetArgString),
>  			string__append_list(["\t", C_RetType,
>  					" return_value;\n"],
>  						MaybeDeclareRetval),
> -			string__append_list(["\treturn_value = ", RetArgString,
> -						";\n"], MaybeFail),
> +			( foreign__is_foreign_type(Export_RetType) = yes ->
> +				string__append_list(
> +					["\tMR_MAYBE_UNBOX_FOREIGN_TYPE(",
> +					C_RetType, ", ", RetArgString,
> +					", return_value);\n"], SetReturnValue)
> +			;
> +				string__append_list(["\treturn_value = ",
> +					RetArgString, ";\n"], SetReturnValue)
> +			),
> +			MaybeFail = SetReturnValue,
>  			string__append_list(["\treturn return_value;\n"],
>  				MaybeSucceed),
>  			ArgInfoTypes2 = ArgInfoTypes1

A comment explaining why they need to unboxed rather than boxed would be
appropiate.  I took me a bit of thinking to work out why, because my
first thought was that input args need to be boxed, but of course this
code is for the pragma export.


> @@ -435,7 +445,7 @@
>  	;
>  		ArgName = ""
>  	),
> -	TypeString0 = llds_exported_type_string(Module, Type),
> +	TypeString0 = foreign__to_type_string(c, Module, Type),
>  	(
>  		Mode = top_out
>  	->
> @@ -445,11 +455,11 @@
>  		TypeString = TypeString0
>  	).
>  
> -:- pred get_input_args(assoc_list(arg_info, type), int, string).
> -:- mode get_input_args(in, in, out) is det.
> +:- pred get_input_args(assoc_list(arg_info, type), int, module_info, string).
> +:- mode get_input_args(in, in, in, out) is det.
>  
> -get_input_args([], _, "").
> -get_input_args([AT|ATs], Num0, Result) :-
> +get_input_args([], _, _, "").
> +get_input_args([AT|ATs], Num0, ModuleInfo, Result) :-
>  	AT = ArgInfo - Type,
>  	ArgInfo = arg_info(ArgLoc, Mode),
>  	Num is Num0 + 1,
> @@ -460,9 +470,18 @@
>  		string__append("Mercury__argument", NumString, ArgName0),
>  		convert_type_to_mercury(ArgName0, Type, ArgName),
>  		argloc_to_string(ArgLoc, ArgLocString),
> -		string__append_list(
> -			["\t", ArgLocString, " = ", ArgName, ";\n" ],
> -			InputArg)
> +		Export_Type = foreign__to_exported_type(ModuleInfo, Type),
> +		( foreign__is_foreign_type(Export_Type) = yes ->
> +			C_Type = foreign__to_type_string(c, Export_Type),
> +			string__append_list(
> +				["\tMR_MAYBE_BOX_FOREIGN_TYPE(",
> +				C_Type, ", ", ArgName, ", ",
> +				ArgLocString, ");\n"], InputArg)
> +		;
> +			string__append_list(
> +				["\t", ArgLocString, " = ", ArgName, ";\n" ],
> +				InputArg)
> +		)
>  	;
>  		Mode = top_out,
>  		InputArg = ""

Ditto.

> @@ -470,14 +489,14 @@
>  		Mode = top_unused,
>  		InputArg = ""
>  	),
> -	get_input_args(ATs, Num, TheRest),
> +	get_input_args(ATs, Num, ModuleInfo, TheRest),
>  	string__append(InputArg, TheRest, Result).
>  
> -:- pred copy_output_args(assoc_list(arg_info, type), int, string).
> -:- mode copy_output_args(in, in, out) is det.
> +:- pred copy_output_args(assoc_list(arg_info, type), int, module_info, string).
> +:- mode copy_output_args(in, in, in, out) is det.
>  
> -copy_output_args([], _, "").
> -copy_output_args([AT|ATs], Num0, Result) :-
> +copy_output_args([], _, _, "").
> +copy_output_args([AT|ATs], Num0, ModuleInfo, Result) :-
>  	AT = ArgInfo - Type,
>  	ArgInfo = arg_info(ArgLoc, Mode),
>  	Num is Num0 + 1,
> @@ -486,19 +505,27 @@
>  		OutputArg = ""
>  	;
>  		Mode = top_out,
> -
>  		string__int_to_string(Num, NumString),
>  		string__append("Mercury__argument", NumString, ArgName),
>  		argloc_to_string(ArgLoc, ArgLocString0),
>  		convert_type_from_mercury(ArgLocString0, Type, ArgLocString),
> -		string__append_list(
> -			["\t*", ArgName, " = ", ArgLocString, ";\n" ],
> -			OutputArg)
> +		Export_Type = foreign__to_exported_type(ModuleInfo, Type),
> +		( foreign__is_foreign_type(Export_Type) = yes ->
> +			C_Type = foreign__to_type_string(c, Export_Type),
> +			string__append_list(
> +				["\tMR_MAYBE_UNBOX_FOREIGN_TYPE(",
> +				C_Type, ", ", ArgLocString, ", ",
> +				ArgName, ");\n"], OutputArg)
> +		;
> +			string__append_list(
> +				["\t*", ArgName, " = ", ArgLocString, ";\n" ],
> +				OutputArg)
> +		)
>  	;
>  		Mode = top_unused,
>  		OutputArg = ""
>  	),
> -	copy_output_args(ATs, Num, TheRest),
> +	copy_output_args(ATs, Num, ModuleInfo, TheRest),
>  	string__append(OutputArg, TheRest, Result).
>  	
>  	% convert an argument location (currently just a register number)

Ditto.

> Index: compiler/ml_code_gen.m
> ===================================================================
> RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
> retrieving revision 1.114
> diff -u -d -r1.114 ml_code_gen.m
> --- compiler/ml_code_gen.m	7 May 2002 11:03:02 -0000	1.114
> +++ compiler/ml_code_gen.m	16 May 2002 11:57:22 -0000
> @@ -2913,41 +2913,62 @@

..

> +				% For --no-high-level-data, we only need to use
> +				% a cast is for polymorphic types, which are
> +				% `Word' in the C interface but `MR_Box' in the
> +				% MLDS back-end.
> +				% Except for MC++, where polymorphic types
> +				% are MR_Box.

Have you tested this on the MC++ backend?  I am not sure that things
will still work, but considering I am rewriting that part of the
compiler at the moment, if there are any problems I will fix them.

> Index: compiler/mlds.m
> ===================================================================
> RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
> retrieving revision 1.90
> diff -u -d -r1.90 mlds.m
> --- compiler/mlds.m	7 May 2002 11:03:04 -0000	1.90
> +++ compiler/mlds.m	16 May 2002 07:51:03 -0000
> @@ -1632,7 +1632,9 @@
>  
>  %-----------------------------------------------------------------------------%
>  
> -% Currently we return mlds__types that are just the same as Mercury types,
> +% There is some special-case handling for arrays and foreign_types here.
> +% But apart from that,
> +% currently we return mlds__types that are just the same as Mercury types,
>  % except that we also store the type category, so that we
>  % can tell if the type is an enumeration or not, without
>  % needing to refer to the HLDS type_table.
> @@ -1676,7 +1678,15 @@
>  		; Target = java,
>  			sorry(this_file, "foreign types on the java backend")
>  		; Target = asm,
> -			sorry(this_file, "foreign types on the asm backend")
> +			( MaybeC = yes(CForeignType),
> +				ForeignType = c(CForeignType)
> +			; MaybeC = no,
> +				% XXX This ought to be checked by the
> +				% front-end, e.g. check_foreign_type
> +				% in make_hlds.
> +				sorry(this_file,
> +				"mercury_type_to_mlds_type: No C foreign type")
> +			)
>  		),
>  		MLDSType = mlds__foreign_type(ForeignType)
>  	;

Change the sorry to unexpected and abstract the code in
make_hlds__check_foreign_type for the C target and reuse it for the asm
target.


> Index: compiler/mlds_to_c.m
> ===================================================================
> RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
> retrieving revision 1.128
> diff -u -d -r1.128 mlds_to_c.m
> --- compiler/mlds_to_c.m	7 May 2002 11:03:05 -0000	1.128
> +++ compiler/mlds_to_c.m	16 May 2002 13:48:58 -0000
> @@ -650,7 +650,7 @@
>  mlds_output_pragma_export_type(prefix, mercury_array_type(_ElemType)) -->
>  	io__write_string("MR_Word").
>  mlds_output_pragma_export_type(prefix, mercury_type(_, _, ExportedType)) -->
> -	io__write_string(to_type_string(c, ExportedType)).
> +	io__write_string(foreign__to_type_string(c, ExportedType)).
>  mlds_output_pragma_export_type(prefix, mlds__cont_type(_)) -->
>  	io__write_string("MR_Word").
>  mlds_output_pragma_export_type(prefix, mlds__commit_type) -->
> @@ -663,8 +663,13 @@
>  	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(_)) -->
> -	io__write_string("MR_Box").
> +mlds_output_pragma_export_type(prefix, mlds__foreign_type(ForeignType)) -->
> +	( { ForeignType = c(c(Name)) },
> +		io__write_string(Name)
> +	; { ForeignType = il(_) },
> +		{ unexpected(this_file,
> +			"mlds_output_type_prefix: il 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(_)) -->
> @@ -698,53 +703,157 @@
>  mlds_output_pragma_export_defn_body(ModuleName, FuncName, Signature) -->
>  	{ Signature = mlds__func_params(Parameters, RetTypes) },
>  
> +	% Declare local variables corresponding to any foreign_type
> +	% parameters
> +	{ IsCForeignType = (pred(Arg::in) is semidet :-
> +		Arg = mlds__argument(_Name, Type, _GCTraceCode),
> +		Type = mlds__foreign_type(c(_))) },
> +	{ IsCForeignTypePtr = (pred(Arg::in) is semidet :-
> +		Arg = mlds__argument(_Name, Type, _GCTraceCode),
> +		Type = mlds__ptr_type(mlds__foreign_type(c(_)))) },
> +	{ CForeignTypeInputs = list__filter(IsCForeignType, Parameters) },
> +	{ CForeignTypeOutputs = list__filter(IsCForeignTypePtr, Parameters) },
> +	io__write_list(CForeignTypeInputs ++ CForeignTypeOutputs, "",
> +		(pred(Arg::in, di, uo) is det -->
> +			{ Arg = mlds__argument(Name, Type, _GC_TraceCode) },
> +			io__write_string("\t"),
> +			mlds_output_data_decl_ho(mlds_output_type_prefix,
> +				mlds_output_type_suffix,
> +				qual(ModuleName, boxed_name(Name)), Type),
> +			io__write_string(";\n"))),
> +
> +	% Declare a local variable or two for the return value, if needed
> +	( { RetTypes = [RetType1] } ->
> +		( { RetType1 = mlds__foreign_type(c(_)) } ->
> +			io__write_string("\t"),
> +			mlds_output_pragma_export_type(RetType1),
> +			io__write_string(" ret_value;\n"),
> +			io__write_string("\t"),
> +			mlds_output_type(RetType1),
> +			io__write_string(" boxed_ret_value;\n")
> +		;
> +			io__write_string("\t"),
> +			mlds_output_pragma_export_type(RetType1),
> +			io__write_string(" ret_value;\n")
> +		)
> +	;
> +		[]
> +	),
> +
> +	% Generate code to box any foreign_type input parameters
> +	io__write_list(CForeignTypeInputs, "",
> +		(pred(Arg::in, di, uo) is det -->
> +			{ Arg = mlds__argument(Name, Type, _GC_TraceCode) },
> +			{ QualName = qual(ModuleName, Name) },
> +			{ BoxedQualName = qual(ModuleName, boxed_name(Name)) },
> +			io__write_string("\tMR_MAYBE_BOX_FOREIGN_TYPE("),
> +			mlds_output_pragma_export_type(Type),
> +			io__write_string(", "),
> +			mlds_output_fully_qualified_name(QualName),
> +			io__write_string(", "),
> +			mlds_output_fully_qualified_name(BoxedQualName),
> +			io__write_string(");\n"))),
> +

Again a comment about why they need to unboxed rather than boxed.

> +	% Generate code to actually call the Mercury procedure which
> +	% is being exported
>  	( { RetTypes = [] } ->
> -		io__write_string("\t")
> -	; { RetTypes = [RetType] } ->
> -		io__write_string("\treturn ("),
> -		mlds_output_pragma_export_type(RetType),
> -		io__write_string(") ")
> +		io__write_string("\t"),
> +		mlds_output_pragma_export_call(ModuleName, FuncName,
> +			Parameters)
> +	; { RetTypes = [RetType2] } ->
> +		( { RetType2 = mlds__foreign_type(c(_)) } ->
> +			io__write_string("\tboxed_ret_value = ")
> +		;
> +			io__write_string("\tret_value = ("),
> +			mlds_output_pragma_export_type(RetType2),
> +			io__write_string(")")
> +		),
> +		mlds_output_pragma_export_call(ModuleName, FuncName,
> +			Parameters)
>  	;
> +		% This is just for MLDS dumps when compiling to non-C targets.
> +		% So we don't need to worry about boxing/unboxing foreign types
> +		% here.
>  		io__write_string("\treturn ("),
>  		mlds_output_return_list(RetTypes,
>  				mlds_output_pragma_export_type),
>  		io__write_string(") ")
>  	),
>  
> +	% Generate code to unbox any foreign_type output parameters
> +	io__write_list(CForeignTypeOutputs, "",
> +		(pred(Arg::in, di, uo) is det -->
> +			{ Arg = mlds__argument(Name, Type, _GC_TraceCode) },
> +			{ QualName = qual(ModuleName, Name) },
> +			{ BoxedQualName = qual(ModuleName, boxed_name(Name)) },
> +			io__write_string("\tMR_MAYBE_UNBOX_FOREIGN_TYPE("),
> +			mlds_output_pragma_export_type(Type),
> +			io__write_string(", "),
> +			mlds_output_fully_qualified_name(BoxedQualName),
> +			io__write_string(", *"),
> +			mlds_output_fully_qualified_name(QualName),
> +			io__write_string(");\n"))),
> +

Ditto boxing/unboxing.

> +	% Generate the final statement to unbox and return the
> +	% return value, if needed.
> +	( { RetTypes = [RetType3] } ->
> +		( { RetType3 = mlds__foreign_type(c(_)) } ->
> +			io__write_string("\tMR_MAYBE_UNBOX_FOREIGN_TYPE("),
> +			mlds_output_pragma_export_type(RetType3),
> +			io__write_string(", boxed_ret_value, ret_value);\n")
> +		;
> +			[]
> +		),
> +		io__write_string("\treturn ret_value;\n")
> +	;
> +		[]
> +	).
> +
Ditto boxing/unboxing.

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