[m-rev.] for review: fix C foreign_type
Fergus Henderson
fjh at cs.mu.OZ.AU
Fri May 17 00:43:49 AEST 2002
For review by Pete and/or Tyson.
Estimated hours taken: 12
Branches: main
Implement C `pragma foreign_type' properly.
compiler/mlds.m:
Allow C `pragma foreign_type' on the `--target asm' back-end.
compiler/mlds_to_c.m:
Output foreign types as MR_Box internally (i.e. for the ordinary
code that we generate), for compatibility with the `--target asm'
back-end. But output foreign types as the C type name for
`pragma foreign_proc' and `pragma export'.
runtime/mercury_heap.h:
Add macros MR_MAYBE_(UN)BOX_FOREIGN_TYPE,
for boxing/unboxing foreign_type values.
compiler/export.m:
compiler/ml_code_gen.m:
Change the LLDS/MLDS (respectively) back-end code for
`pragma export' to call the above macros when required.
compiler/llds_out.m:
compiler/mlds_to_c.m:
Change the LLDS/MLDS (respectively) back-end code for
C `pragma foreign_proc' to call the above macros when required.
compiler/foreign.m:
- Add a new boolean function foreign__is_foreign_type,
which tests whether an exported_type is a foreign_type or not.
- Delete the predicate llds_exported_type_string
(I changed the callers to use foreign__to_type_string instead).
compiler/ml_code_gen.m:
compiler/mlds_to_c.m:
compiler/pragma_c_gen.m:
Add an explicit module qualifier to calls to foreign__to_type_string.
doc/reference_manual.texi:
Update the documentation to reflect the changes:
- various unnecessary restrictions have been removed
- foreign_type now works properly with `pragma export'
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
@@ -223,8 +223,8 @@
% work out which arguments are input, and which are output,
% and copy to/from the mercury registers.
- get_input_args(ArgInfoTypes, 0, InputArgs),
- copy_output_args(ArgInfoTypes, 0, OutputArgs),
+ get_input_args(ArgInfoTypes, 0, Module, InputArgs),
+ copy_output_args(ArgInfoTypes, 0, Module, OutputArgs),
code_util__make_proc_label(Module, PredId, ProcId, ProcLabel),
llds_out__get_proc_label(ProcLabel, yes, ProcLabelString),
@@ -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
@@ -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 = ""
@@ -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)
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.15
diff -u -d -r1.15 foreign.m
--- compiler/foreign.m 7 May 2002 14:43:40 -0000 1.15
+++ compiler/foreign.m 16 May 2002 09:48:40 -0000
@@ -74,16 +74,17 @@
% of that type on the current backend.
:- func foreign__to_exported_type(module_info, (type)) = exported_type.
- % Given a representation of a type determine the string which
- % corresponds to that type in the specified foreign language.
+ % Given the exported_type representation for a type,
+ % determine whether or not it is a foreign type.
+:- func foreign__is_foreign_type(exported_type) = bool.
+
+ % Given a representation of a type, determine the string which
+ % corresponds to that type in the specified foreign language,
+ % for use with foreign language interfacing (`pragma export' or
+ % `pragma foreign_proc').
:- func foreign__to_type_string(foreign_language, exported_type) = string.
:- func foreign__to_type_string(foreign_language, module_info, (type)) = string.
- % Give a representation of a type determine the string which
- % corresponds to that type when the type is mentioned via a
- % pragma export on the llds backend.
-:- func llds_exported_type_string(module_info, (type)) = string.
-
% Filter the decls for the given foreign language.
% The first return value is the list of matches, the second is
% the list of mis-matches.
@@ -632,6 +633,9 @@
ExportType = mercury(Type)
).
+is_foreign_type(foreign(_)) = yes.
+is_foreign_type(mercury(_)) = no.
+
to_type_string(Lang, ModuleInfo, Type) =
to_type_string(Lang, to_exported_type(ModuleInfo, Type)).
@@ -674,14 +678,6 @@
to_type_string(il, mercury(_Type)) = _ :-
sorry(this_file, "to_type_string for il").
-llds_exported_type_string(ModuleInfo, Type) = TypeString :-
- ExportedType = to_exported_type(ModuleInfo, Type),
- ( ExportedType = foreign(_),
- TypeString = "MR_Word"
- ; ExportedType = mercury(_),
- TypeString = to_type_string(c, ExportedType)
- ).
-
%-----------------------------------------------------------------------------%
:- func this_file = string.
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.193
diff -u -d -r1.193 llds_out.m
--- compiler/llds_out.m 7 May 2002 11:02:51 -0000 1.193
+++ compiler/llds_out.m 16 May 2002 11:56:37 -0000
@@ -1979,26 +1979,36 @@
output_pragma_inputs([I|Inputs]) -->
{ I = pragma_c_input(VarName, Type, Rval, MaybeForeignType) },
io__write_string("\t"),
- io__write_string(VarName),
- io__write_string(" = "),
- (
- { Type = term__functor(term__atom("string"), [], _) }
- ->
- output_llds_type_cast(string),
- output_rval_as_type(Rval, word)
- ;
- { Type = term__functor(term__atom("float"), [], _) }
- ->
- output_rval_as_type(Rval, float)
+ ( { MaybeForeignType = yes(ForeignType) } ->
+ io__write_string("MR_MAYBE_UNBOX_FOREIGN_TYPE("),
+ io__write_string(ForeignType),
+ io__write_string(", "),
+ output_rval(Rval),
+ io__write_string(", "),
+ io__write_string(VarName),
+ io__write_string(")")
;
- % Note that for this cast to be correct the foreign type
- % must be a word sized integer or pointer type.
- ( { MaybeForeignType = yes(ForeignTypeStr) } ->
- io__write_string("(" ++ ForeignTypeStr ++ ") ")
+ io__write_string(VarName),
+ io__write_string(" = "),
+ (
+ { Type = term__functor(term__atom("string"), [], _) }
+ ->
+ output_llds_type_cast(string),
+ output_rval_as_type(Rval, word)
;
- []
- ),
- output_rval_as_type(Rval, word)
+ { Type = term__functor(term__atom("float"), [], _) }
+ ->
+ output_rval_as_type(Rval, float)
+ ;
+ % Note that for this cast to be correct the foreign type
+ % must be a word sized integer or pointer type.
+ ( { MaybeForeignType = yes(ForeignTypeStr) } ->
+ io__write_string("(" ++ ForeignTypeStr ++ ") ")
+ ;
+ []
+ ),
+ output_rval_as_type(Rval, word)
+ )
),
io__write_string(";\n"),
output_pragma_inputs(Inputs).
@@ -2023,28 +2033,31 @@
output_pragma_outputs([O|Outputs]) -->
{ O = pragma_c_output(Lval, Type, VarName, MaybeForeignType) },
io__write_string("\t"),
- output_lval_as_word(Lval),
- io__write_string(" = "),
- (
- { Type = term__functor(term__atom("string"), [], _) }
- ->
- output_llds_type_cast(word),
- io__write_string(VarName)
- ;
- { Type = term__functor(term__atom("float"), [], _) }
- ->
- io__write_string("MR_float_to_word("),
+ ( { MaybeForeignType = yes(ForeignType) } ->
+ io__write_string("MR_MAYBE_BOX_FOREIGN_TYPE("),
+ io__write_string(ForeignType),
+ io__write_string(", "),
io__write_string(VarName),
+ io__write_string(", "),
+ output_lval_as_word(Lval),
io__write_string(")")
;
- % Note that for this cast to be correct the foreign type
- % must be a word sized integer or pointer type.
- ( { MaybeForeignType = yes(_) } ->
- output_llds_type_cast(word)
+ output_lval_as_word(Lval),
+ io__write_string(" = "),
+ (
+ { Type = term__functor(term__atom("string"), [], _) }
+ ->
+ output_llds_type_cast(word),
+ io__write_string(VarName)
;
- []
- ),
- io__write_string(VarName)
+ { Type = term__functor(term__atom("float"), [], _) }
+ ->
+ io__write_string("MR_float_to_word("),
+ io__write_string(VarName),
+ io__write_string(")")
+ ;
+ io__write_string(VarName)
+ )
),
io__write_string(";\n"),
output_pragma_outputs(Outputs).
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
@@ -2845,7 +2845,7 @@
MaybeNameAndMode = yes(ArgName - _Mode),
\+ var_is_singleton(ArgName)
->
- TypeString = to_type_string(Lang, ModuleInfo, Type),
+ TypeString = foreign__to_type_string(Lang, ModuleInfo, Type),
string__format("\t%s %s;\n", [s(TypeString), s(ArgName)],
DeclString)
;
@@ -2913,41 +2913,62 @@
ml_gen_box_or_unbox_rval(VarType, OrigType,
lval(VarLval), ArgRval)
),
- { module_info_globals(ModuleInfo, Globals) },
- { globals__lookup_bool_option(Globals, highlevel_data,
- HighLevelData) },
- { HighLevelData = yes ->
- % In general, the types used for the C interface
- % are not the same as the types used by
- % --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.)
- TypeString = to_type_string(Lang, ModuleInfo, OrigType),
- string__format("(%s)", [s(TypeString)], Cast)
+ % At this point we have an rval with the right type for
+ % *internal* use in the code generated by the Mercury
+ % compiler's MLDS back-end. We need to convert this to
+ % the appropriate type to use for the C interface.
+ { ExportedType = foreign__to_exported_type(ModuleInfo,
+ OrigType) },
+ { TypeString = foreign__to_type_string(Lang, ExportedType) },
+ ( { foreign__is_foreign_type(ExportedType) = yes } ->
+ % For foreign types,
+ % we need to call MR_MAYBE_UNBOX_FOREIGN_TYPE
+ { AssignInput = [
+ raw_target_code("\tMR_MAYBE_UNBOX_FOREIGN_TYPE("
+ ++ TypeString ++ ", ", []),
+ target_code_input(ArgRval),
+ raw_target_code(", " ++ ArgName ++ ");\n", [])
+ ] }
;
- % 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.
- (
- type_util__var(OrigType, _),
- Lang \= managed_cplusplus
- ->
- Cast = "(MR_Word) "
+ % In the usual case, we can just use an assignment
+ % and perhaps a cast.
+ { module_info_globals(ModuleInfo, Globals) },
+ { globals__lookup_bool_option(Globals, highlevel_data,
+ HighLevelData) },
+ { HighLevelData = yes ->
+ % In general, the types used for the C
+ % interface are not the same as the types
+ % used by --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.)
+ string__format("(%s)", [s(TypeString)], Cast)
;
- Cast = ""
- )
- },
- { string__format("\t%s = %s\n",
- [s(ArgName), s(Cast)],
- AssignToArgName) },
- { AssignInput = [
- raw_target_code(AssignToArgName, []),
- target_code_input(ArgRval),
- raw_target_code(";\n", [])
- ] }
+ % 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.
+ (
+ type_util__var(OrigType, _),
+ Lang \= managed_cplusplus
+ ->
+ Cast = "(MR_Word) "
+ ;
+ Cast = ""
+ )
+ },
+ { string__format("\t%s = %s\n",
+ [s(ArgName), s(Cast)],
+ AssignToArgName) },
+ { AssignInput = [
+ raw_target_code(AssignToArgName, []),
+ target_code_input(ArgRval),
+ raw_target_code(";\n", [])
+ ] }
+ )
;
% if the variable doesn't occur in the ArgNames list,
% it can't be used, so we just ignore it
@@ -2996,41 +3017,64 @@
mlds__var_name(ArgName, no),
Context, ArgLval, ConvDecls, _ConvInputStatements,
ConvOutputStatements),
- { module_info_globals(ModuleInfo, Globals) },
- { globals__lookup_bool_option(Globals, highlevel_data,
- HighLevelData) },
- { HighLevelData = yes ->
- % In general, the types used for the C interface
- % are not the same as the types used by
- % --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.)
- % Note that we can't easily obtain the type string
- % for the RHS of the assignment, so instead we
- % cast the LHS.
- TypeString = to_type_string(Lang, ModuleInfo, OrigType),
- string__format("*(%s *)&", [s(TypeString)], LHS_Cast),
- RHS_Cast = ""
+ % At this point we have an lval with the right type for
+ % *internal* use in the code generated by the Mercury
+ % compiler's MLDS back-end. We need to convert this to
+ % the appropriate type to use for the C interface.
+ { ExportedType = foreign__to_exported_type(ModuleInfo,
+ OrigType) },
+ { TypeString = foreign__to_type_string(Lang, ExportedType) },
+ ( { foreign__is_foreign_type(ExportedType) = yes } ->
+ % For foreign types,
+ % we need to call MR_MAYBE_BOX_FOREIGN_TYPE
+ { AssignOutput = [
+ raw_target_code("\tMR_MAYBE_BOX_FOREIGN_TYPE("
+ ++ TypeString ++ ", " ++ ArgName ++
+ ", ", []),
+ target_code_output(ArgLval),
+ raw_target_code(");\n", [])
+ ] }
;
- % 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.
- ( type_util__var(OrigType, _) ->
- RHS_Cast = "(MR_Box) "
- ;
+ % In the usual case, we can just use an assignment,
+ % perhaps with a cast
+ { module_info_globals(ModuleInfo, Globals) },
+ { globals__lookup_bool_option(Globals, highlevel_data,
+ HighLevelData) },
+ { HighLevelData = yes ->
+ % In general, the types used for the C
+ % interface are not the same as the types
+ % used by --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.)
+ % Note that we can't easily obtain the type
+ % string for the RHS of the assignment, so
+ % instead we cast the LHS.
+ string__format("*(%s *)&", [s(TypeString)],
+ LHS_Cast),
RHS_Cast = ""
- ),
- LHS_Cast = ""
- },
- { string__format(" = %s%s;\n", [s(RHS_Cast), s(ArgName)],
- AssignFromArgName) },
- { string__format("\t%s\n", [s(LHS_Cast)], AssignTo) },
- { AssignOutput = [
- raw_target_code(AssignTo, []),
- target_code_output(ArgLval),
- raw_target_code(AssignFromArgName, [])
- ] }
+ ;
+ % 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.
+ ( type_util__var(OrigType, _) ->
+ RHS_Cast = "(MR_Box) "
+ ;
+ RHS_Cast = ""
+ ),
+ LHS_Cast = ""
+ },
+ { string__format(" = %s%s;\n", [s(RHS_Cast),
+ s(ArgName)], AssignFromArgName) },
+ { string__format("\t%s\n", [s(LHS_Cast)], AssignTo) },
+ { AssignOutput = [
+ raw_target_code(AssignTo, []),
+ target_code_output(ArgLval),
+ raw_target_code(AssignFromArgName, [])
+ ] }
+ )
;
% if the variable doesn't occur in the ArgNames list,
% it can't be used, so we just ignore it
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)
;
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"))),
+
+ % 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"))),
+
+ % 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")
+ ;
+ []
+ ).
+
+:- func boxed_name(mlds__entity_name) = mlds__entity_name.
+boxed_name(Name) = BoxedName :-
+ ( Name = data(var(var_name(VarName, Seq))) ->
+ BoxedName = data(var(var_name("boxed_" ++ VarName, Seq)))
+ ;
+ unexpected(this_file, "boxed_name called for non-var argument")
+ ).
+
+:- pred mlds_output_pragma_export_call(mlds_module_name,
+ mlds__qualified_entity_name, mlds__arguments,
+ io__state, io__state).
+:- mode mlds_output_pragma_export_call(in, in, in, di, uo) is det.
+
+mlds_output_pragma_export_call(ModuleName, FuncName, Parameters) -->
mlds_output_fully_qualified_name(FuncName),
io__write_string("("),
io__write_list(Parameters, ", ",
- mlds_output_name_with_cast(ModuleName)),
+ mlds_output_pragma_export_arg(ModuleName)),
io__write_string(");\n").
%
- % Write out the arguments to the MLDS function. Note the last
- % in the list of the arguments is the return value, so it must
- % be "&arg"
- %
-:- pred write_func_args(mlds_module_name::in, mlds__arguments::in,
- io__state::di, io__state::uo) is det.
-
-write_func_args(_ModuleName, []) -->
- { error("write_func_args: empty list") }.
-write_func_args(_ModuleName, [_Arg]) -->
- io__write_string("&arg").
-write_func_args(ModuleName, [Arg | Args]) -->
- { Args = [_|_] },
- mlds_output_name_with_cast(ModuleName, Arg),
- io__write_string(", "),
- write_func_args(ModuleName, Args).
-
- %
% Output a fully qualified name preceded by a cast.
%
-:- pred mlds_output_name_with_cast(mlds_module_name::in, mlds__argument::in,
+:- pred mlds_output_pragma_export_arg(mlds_module_name::in, mlds__argument::in,
io__state::di, io__state::uo) is det.
-mlds_output_name_with_cast(ModuleName, Arg) -->
+mlds_output_pragma_export_arg(ModuleName, Arg) -->
{ Arg = mlds__argument(Name, Type, _GC_TraceCode) },
- mlds_output_cast(Type),
- mlds_output_fully_qualified_name(qual(ModuleName, Name)).
+ ( { Type = mlds__foreign_type(c(_)) } ->
+ % This is a foreign_type input. Pass in the already-boxed
+ % value.
+ { BoxedName = boxed_name(Name) },
+ mlds_output_fully_qualified_name(qual(ModuleName, BoxedName))
+ ; { Type = mlds__ptr_type(mlds__foreign_type(c(_))) } ->
+ % This is a foreign_type output. Pass in the address of the
+ % local variable which will hold the boxed value.
+ io__write_string("&"),
+ { BoxedName = boxed_name(Name) },
+ mlds_output_fully_qualified_name(qual(ModuleName, BoxedName))
+ ;
+ % Otherwise, no boxing or unboxing is needed.
+ % Just cast the argument to the right type.
+ mlds_output_cast(Type),
+ mlds_output_fully_qualified_name(qual(ModuleName, Name))
+ ).
%
% Generates the signature for det functions in the forward mode.
@@ -1639,13 +1748,11 @@
mlds_output_type_prefix(mlds__native_bool_type) -->
io__write_string("MR_bool").
mlds_output_type_prefix(mlds__native_char_type) --> io__write_string("char").
-mlds_output_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_type_prefix(mlds__foreign_type(_ForeignType)) -->
+ % for binary compatibility with the --target asm back-end,
+ % we need to output these as a generic type, rather than making
+ % use of the C type name
+ io__write_string("MR_Box").
mlds_output_type_prefix(mlds__class_type(Name, Arity, ClassKind)) -->
( { ClassKind = mlds__enum } ->
%
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.51
diff -u -d -r1.51 pragma_c_gen.m
--- compiler/pragma_c_gen.m 7 May 2002 11:03:10 -0000 1.51
+++ compiler/pragma_c_gen.m 16 May 2002 10:31:53 -0000
@@ -1145,7 +1145,7 @@
(
var_is_not_singleton(ArgName, Name)
->
- OrigTypeString = to_type_string(c, Module, OrigType),
+ OrigTypeString = foreign__to_type_string(c, Module, OrigType),
Decl = pragma_c_arg_decl(OrigType, OrigTypeString, Name),
make_pragma_decls(Args, Module, Decls1),
Decls = [Decl | Decls1]
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.248
diff -u -d -r1.248 reference_manual.texi
--- doc/reference_manual.texi 15 May 2002 08:17:04 -0000 1.248
+++ doc/reference_manual.texi 16 May 2002 14:07:56 -0000
@@ -5492,16 +5492,12 @@
The @var{CForeignType} can be any C type name that obeys the following
restrictions.
-The C expression @samp{sizeof(CForeignType) == sizeof(void *)} must
-evaluate to true; if not, the result of using the foreign type is
-undefined.
+Function types, array types, and incomplete types are not allowed.
The type name must be such that when declaring a variable in C of that
type, that no part of the type name is required after the variable name.
-Function, array and incomplete types are not allowed.
-
-Currently only integer and pointer types are accepted as foreign_types;
-at a later date we plan to lift this restriction and allow enum, struct
-and floating point types.
+(This rule prohibits, for example, function pointer types such as
+ at samp{void (*)(void)}. However, it would be OK to use a typedef name
+which was defined as a function pointer type.)
@c XXX No point documenting this until `--gc accurate'
@c is officially supported.
@@ -5513,10 +5509,9 @@
it will be passed to the foreign_proc's foreign language code
as @var{CForeignType}.
- at c XXX This is not currently true.
- at c Furthermore, any Mercury procedure exported with @samp{pragma export}
- at c will use @var{CForeignType} as the type for any
- at c parameters whose Mercury type is @var{MercuryTypeName}.
+Furthermore, any Mercury procedure exported with @samp{pragma export}
+will use @var{CForeignType} as the type for any
+parameters whose Mercury type is @var{MercuryTypeName}.
Also see the section on using C pointers (@pxref{Using C pointers}) for
information on how to use the c_pointer type with the C interface.
Index: runtime/mercury_heap.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_heap.h,v
retrieving revision 1.23
diff -u -d -r1.23 mercury_heap.h
--- runtime/mercury_heap.h 13 Feb 2002 09:56:40 -0000 1.23
+++ runtime/mercury_heap.h 16 May 2002 12:02:10 -0000
@@ -342,4 +342,64 @@
MR_save_transient_hp(); \
} while (0)
+/*
+** Code to box/unbox types declared with `pragma foreign_type'.
+*/
+
+/*
+** void MR_MAYBE_BOX_FOREIGN_TYPE(type T, const T &value, MR_Box &box);
+** Copy a value of type T from `value' to `box',
+** boxing it if necessary (i.e. if type T won't fit in type MR_Box).
+*/
+#define MR_MAYBE_BOX_FOREIGN_TYPE(T, value, box) \
+ do { \
+ MR_CHECK_EXPR_TYPE((value), T); \
+ MR_CHECK_EXPR_TYPE((box), MR_Box); \
+ if (sizeof(T) > sizeof(MR_Box)) { \
+ size_t size_in_words = \
+ (sizeof(T) + sizeof(MR_Word) - 1) \
+ / sizeof(MR_Word); \
+ /* XXX this assumes that nothing requires */ \
+ /* stricter alignment than MR_Float */ \
+ MR_make_hp_float_aligned(); \
+ MR_incr_hp(MR_LVALUE_CAST(MR_Word, (box)), \
+ size_in_words); \
+ *(T *)(box) = (value); \
+ MR_maybe_record_allocation(size_in_words, \
+ "", "foreign type: " MR_STRINGIZE(T)); \
+ } else { \
+ /* We can't take the address of `box' here, */ \
+ /* since it might be a global register. */ \
+ /* Hence we need to use a temporary copy. */ \
+ MR_Box box_copy; \
+ if (sizeof(T) < sizeof(MR_Box)) { \
+ /* make sure we don't leave any */ \
+ /* part of it uninitialized */ \
+ box_copy = 0; \
+ } \
+ memcpy(&box_copy, &(value), sizeof(T)); \
+ (box) = box_copy; \
+ } \
+ } while (0)
+
+/*
+** void MR_MAYBE_UNBOX_FOREIGN_TYPE(type T, MR_Box box, T &value);
+** Copy a value of type T from `box' to `value',
+** unboxing it if necessary.
+*/
+#define MR_MAYBE_UNBOX_FOREIGN_TYPE(T, box, value) \
+ do { \
+ MR_CHECK_EXPR_TYPE((value), T); \
+ MR_CHECK_EXPR_TYPE((box), MR_Box); \
+ if (sizeof(T) > sizeof(MR_Word)) { \
+ (value) = *(T *)(box); \
+ } else { \
+ /* We can't take the address of `box' here, */ \
+ /* since it might be a global register. */ \
+ /* Hence we need to use a temporary copy. */ \
+ MR_Box box_copy = (box); \
+ memcpy(&(value), &box_copy, sizeof(T)); \
+ } \
+ } while (0)
+
#endif /* not MERCURY_HEAP_H */
--
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