[m-rev.] diff: attach foreign language to foreign tags
Julien Fischer
juliensf at csse.unimelb.edu.au
Mon Sep 10 19:01:28 AEST 2007
This is still pending a bootcheck.
Estimated hours taken: 1.5
Branches: main
Fix an XXX left over from the change that introduced foreign enumerations.
The representation of foreign tags in both the HLDS and MLDS needs to
have information about which foreign language the tag belongs attached to
it. In addition to fixing the above XXX (in intermod.m), this also
improves sanity checking of foreign tags.
compiler/hlds_data.m:
Extend the enum_or_dummy type to hold the foreign language
to which a foreign enumeration applies.
Extend the representation of foreign tags to include their
foreign language.
compiler/hlds_out.m:
When writing out the comment describing a d.u. type include
the foreign language in the description if the type is a foreign
enumeration.
compiler/intermod.m:
Instead of looking up the target language when writing foreign
enumeration pragmas to optimization interfaces, look up the language
of the foreign enumeration in the type definition.
compiler/mlds.m:
Extend the MLDS representation of foreign tags to include
their language. (There is no point making a similar change
to the LLDS since the language for that will always be C.)
compiler/rtti.m:
Include a foreign enumeration's language in the representation
of it's RTTI data.
compiler/add_pragma.m:
compiler/bytecode_gen.m:
compiler/erl_rtti.m:
compiler/export.m:
compiler/ml_switch_gen.m:
compiler/ml_type_gen.m:
compiler/ml_unify_gen.m:
compiler/ml_util.m:
compiler/mlds_to_c.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_il.m:
compiler/mlds_to_java.m:
compiler/mlds_to_managed.m:
compiler/rtti_out.m:
compiler/rtti_to_mlds.m:
compiler/switch_util.m:
compiler/type_ctor_info.m:
compiler/type_util.m:
compiler/unify_gen.m:
compiler/unify_proc.m:
Conform to the above change and strengthen sanity checking of
foreign tags; in particular make sure that each backend aborts
if passed foreign tags of a language that cannot be handled
by that backend.
Julien.
Index: add_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.69
diff -u -r1.69 add_pragma.m
--- add_pragma.m 20 Aug 2007 03:35:53 -0000 1.69
+++ add_pragma.m 10 Sep 2007 08:51:20 -0000
@@ -651,7 +651,7 @@
_MaybeUserEq, _ReservedTag, _IsForeignType),
(
( IsEnumOrDummy = is_enum
- ; IsEnumOrDummy = is_foreign_enum
+ ; IsEnumOrDummy = is_foreign_enum(_)
; IsEnumOrDummy = is_dummy
),
Attributes = export_enum_attributes(MaybePrefix),
@@ -1026,7 +1026,7 @@
->
% XXX We should also check that this type is not
% the subject of a reserved tag pragma.
- IsEnumOrDummy = is_foreign_enum,
+ IsEnumOrDummy = is_foreign_enum(Lang),
build_foreign_enum_tag_map(Context, ContextPieces,
TypeName, ForeignTagValues, MaybeForeignTagMap,
!Specs),
@@ -1034,7 +1034,7 @@
LangForForeignEnums = Lang,
MaybeForeignTagMap = yes(ForeignTagMap)
->
- map.foldl2(make_foreign_tag(ForeignTagMap),
+ map.foldl2(make_foreign_tag(Lang, ForeignTagMap),
OldTagValues, map.init, TagValues, [],
UnmappedCtors),
(
@@ -1076,7 +1076,7 @@
]
)
;
- IsEnumOrDummy0 = is_foreign_enum,
+ IsEnumOrDummy0 = is_foreign_enum(_),
( LangForForeignEnums \= Lang ->
MaybeSeverity = no,
ErrorPieces = []
@@ -1192,19 +1192,20 @@
sorry(this_file, "pragma foreign_enum and --target `x86_64'.").
target_lang_to_foreign_enum_lang(target_erlang) = lang_erlang.
-:- pred make_foreign_tag(map(sym_name, string)::in,
+:- pred make_foreign_tag(foreign_language::in, map(sym_name, string)::in,
cons_id::in, cons_tag::in,
cons_tag_values::in, cons_tag_values::out,
list(sym_name)::in, list(sym_name)::out) is det.
-make_foreign_tag(ForeignTagMap, ConsId, _, !ConsTagValues, !UnmappedCtors) :-
+make_foreign_tag(ForeignLanguage, ForeignTagMap, ConsId, _, !ConsTagValues,
+ !UnmappedCtors) :-
( ConsId = cons(ConsSymName0, 0) ->
ConsSymName = ConsSymName0
;
unexpected(this_file, "non arity zero enumeration constant.")
),
( map.search(ForeignTagMap, ConsSymName, ForeignTagValue) ->
- ForeignTag = foreign_tag(ForeignTagValue),
+ ForeignTag = foreign_tag(ForeignLanguage, ForeignTagValue),
svmap.set(ConsId, ForeignTag, !ConsTagValues)
;
!:UnmappedCtors = [ConsSymName | !.UnmappedCtors]
Index: bytecode_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.114
diff -u -r1.114 bytecode_gen.m
--- bytecode_gen.m 20 Aug 2007 03:35:53 -0000 1.114
+++ bytecode_gen.m 10 Sep 2007 08:51:20 -0000
@@ -780,7 +780,7 @@
unexpected(this_file, "string_tag cons tag " ++
"for non-string_constant cons id").
map_cons_tag(int_tag(IntVal), byte_enum_tag(IntVal)).
-map_cons_tag(foreign_tag(_), _) :-
+map_cons_tag(foreign_tag(_, _), _) :-
sorry(this_file, "bytecode with foreign tags").
map_cons_tag(float_tag(_), _) :-
unexpected(this_file, "float_tag cons tag " ++
Index: erl_rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/erl_rtti.m,v
retrieving revision 1.17
diff -u -r1.17 erl_rtti.m
--- erl_rtti.m 30 Aug 2007 05:46:01 -0000 1.17
+++ erl_rtti.m 10 Sep 2007 08:51:20 -0000
@@ -139,7 +139,7 @@
ErlFunctors),
Details = erlang_du(ErlFunctors)
).
-erlang_type_ctor_details_2(foreign_enum(_, _, _, _, _)) =
+erlang_type_ctor_details_2(foreign_enum(_, _, _, _, _, _)) =
sorry(this_file, "NYI foreign enumerations for Erlang.").
erlang_type_ctor_details_2(du(_, Functors, _, _, FunctorNums)) = Details :-
list.map_corresponding(convert_du_functor, Functors, FunctorNums,
Index: export.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.115
diff -u -r1.115 export.m
--- export.m 20 Aug 2007 03:35:53 -0000 1.115
+++ export.m 10 Sep 2007 08:51:20 -0000
@@ -789,7 +789,7 @@
unexpected(this_file, "d.u. is not an enumeration.")
;
( IsEnumOrDummy = is_enum
- ; IsEnumOrDummy = is_foreign_enum
+ ; IsEnumOrDummy = is_foreign_enum(_)
; IsEnumOrDummy = is_dummy
),
list.foldl(foreign_const_name_and_tag(NameMapping, TagValues),
@@ -838,7 +838,7 @@
TagVal = int_tag(IntTag),
Tag = ee_tag_rep_int(IntTag)
;
- TagVal = foreign_tag(ForeignTag),
+ TagVal = foreign_tag(_ForeignLang, ForeignTag),
Tag = ee_tag_rep_string(ForeignTag)
;
( TagVal = string_tag(_)
Index: hlds_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.115
diff -u -r1.115 hlds_data.m
--- hlds_data.m 20 Aug 2007 03:35:55 -0000 1.115
+++ hlds_data.m 10 Sep 2007 08:51:20 -0000
@@ -18,6 +18,7 @@
:- interface.
:- import_module hlds.hlds_pred.
+:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.program_representation.
:- import_module parse_tree.prog_data.
@@ -186,7 +187,7 @@
:- type enum_or_dummy
---> is_enum
; is_dummy
- ; is_foreign_enum
+ ; is_foreign_enum(foreign_language)
; not_enum_or_dummy.
:- type foreign_type_body
@@ -237,7 +238,7 @@
% the specified integer value. This is used for enumerations and
% character constants as well as for int constants.
- ; foreign_tag(string)
+ ; foreign_tag(foreign_language, string)
% This means the constant is represented by the string which is
% embedded directly in the target language. This is used for
% foreign enumerations, i.e. those enumeration types that are the
@@ -387,7 +388,7 @@
get_primary_tag(string_tag(_)) = no.
get_primary_tag(float_tag(_)) = no.
get_primary_tag(int_tag(_)) = no.
-get_primary_tag(foreign_tag(_)) = no.
+get_primary_tag(foreign_tag(_, _)) = no.
get_primary_tag(pred_closure_tag(_, _, _)) = no.
get_primary_tag(type_ctor_info_tag(_, _, _)) = no.
get_primary_tag(base_typeclass_info_tag(_, _, _)) = no.
@@ -407,7 +408,7 @@
get_secondary_tag(string_tag(_)) = no.
get_secondary_tag(float_tag(_)) = no.
get_secondary_tag(int_tag(_)) = no.
-get_secondary_tag(foreign_tag(_)) = no.
+get_secondary_tag(foreign_tag(_, _)) = no.
get_secondary_tag(pred_closure_tag(_, _, _)) = no.
get_secondary_tag(type_ctor_info_tag(_, _, _)) = no.
get_secondary_tag(base_typeclass_info_tag(_, _, _)) = no.
Index: hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.433
diff -u -r1.433 hlds_out.m
--- hlds_out.m 6 Sep 2007 12:45:23 -0000 1.433
+++ hlds_out.m 10 Sep 2007 08:51:20 -0000
@@ -3320,9 +3320,11 @@
write_indent(Indent, !IO),
io.write_string("/* enumeration */\n", !IO)
;
- EnumDummy = is_foreign_enum,
+ EnumDummy = is_foreign_enum(Lang),
write_indent(Indent, !IO),
- io.write_string("/* foreign enumeration */\n", !IO)
+ io.write_string("/* foreign enumeration for ", !IO),
+ io.write_string(foreign_language_string(Lang), !IO),
+ io.write_string(" */\n", !IO)
;
EnumDummy = is_dummy,
write_indent(Indent, !IO),
Index: intermod.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.222
diff -u -r1.222 intermod.m
--- intermod.m 20 Aug 2007 03:35:56 -0000 1.222
+++ intermod.m 10 Sep 2007 08:51:20 -0000
@@ -1359,30 +1359,8 @@
),
(
Body = hlds_du_type(_, ConsTagVals, EnumOrDummy, _, _, _),
- EnumOrDummy = is_foreign_enum
+ EnumOrDummy = is_foreign_enum(Lang)
->
- % XXX This language information should be attached to the type.
- % It doesn't actually matter too much while we don't support
- % foreign_enum pragmas for languages other than the target languages.
- globals.io_get_target(TargetLanguage, !IO),
- (
- TargetLanguage = target_c,
- Lang = lang_c
- ;
- TargetLanguage = target_il,
- Lang = lang_il
- ;
- TargetLanguage = target_erlang,
- Lang = lang_erlang
- ;
- TargetLanguage = target_java,
- Lang = lang_java
- ;
- ( TargetLanguage = target_asm
- ; TargetLanguage = target_x86_64
- ),
- sorry(this_file, "foreign enum and target_{asm,x86_64}")
- ),
map.foldl(gather_foreign_enum_value_pair, ConsTagVals, [],
ForeignEnumVals),
Pragma = pragma_foreign_enum(Lang, Name, Arity, ForeignEnumVals),
@@ -1402,10 +1380,10 @@
;
unexpected(this_file, "expected enumeration constant")
),
- ( ConsTag = foreign_tag(ForeignTag0) ->
+ ( ConsTag = foreign_tag(_ForeignLang, ForeignTag0) ->
ForeignTag = ForeignTag0
;
- unexpected(this_file, "exepcted foreign tag")
+ unexpected(this_file, "expected foreign tag")
),
!:Values = [SymName - ForeignTag | !.Values].
Index: ml_switch_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.33
diff -u -r1.33 ml_switch_gen.m
--- ml_switch_gen.m 7 Sep 2007 09:55:02 -0000 1.33
+++ ml_switch_gen.m 10 Sep 2007 08:51:20 -0000
@@ -444,8 +444,9 @@
Tag = string_tag(String),
Rval = const(mlconst_string(String))
;
- Tag = foreign_tag(ForeignTag),
- Rval = const(mlconst_foreign(ForeignTag, mlds_native_int_type))
+ Tag = foreign_tag(ForeignLang, ForeignTag),
+ Rval = const(mlconst_foreign(ForeignLang, ForeignTag,
+ mlds_native_int_type))
;
( Tag = float_tag(_)
; Tag = pred_closure_tag(_, _, _)
Index: ml_type_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.69
diff -u -r1.69 ml_type_gen.m
--- ml_type_gen.m 30 Aug 2007 20:10:36 -0000 1.69
+++ ml_type_gen.m 10 Sep 2007 08:51:20 -0000
@@ -158,7 +158,7 @@
% XXX we probably shouldn't ignore _ReservedTag
ml_gen_equality_members(MaybeUserEqComp, MaybeEqualityMembers),
(
- ( EnumDummy = is_foreign_enum
+ ( EnumDummy = is_foreign_enum(_)
; EnumDummy = is_enum
),
ml_gen_enum_type(TypeCtor, TypeDefn, Ctors, TagValues,
@@ -250,8 +250,8 @@
TagVal = int_tag(Int),
ConstValue = const(mlconst_int(Int))
;
- TagVal = foreign_tag(ForeignTagValue),
- ConstValue = const(mlconst_foreign(ForeignTagValue,
+ TagVal = foreign_tag(ForeignLang, ForeignTagValue),
+ ConstValue = const(mlconst_foreign(ForeignLang, ForeignTagValue,
mlds_native_int_type))
;
( TagVal = string_tag(_)
@@ -1077,8 +1077,8 @@
TagVal = int_tag(Int),
ConstValue = const(mlconst_int(Int))
;
- TagVal = foreign_tag(String),
- ConstValue = const(mlconst_foreign(String, mlds_native_int_type))
+ TagVal = foreign_tag(Lang, String),
+ ConstValue = const(mlconst_foreign(Lang, String, mlds_native_int_type))
;
( TagVal = string_tag(_)
; TagVal = float_tag(_)
Index: ml_unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.115
diff -u -r1.115 ml_unify_gen.m
--- ml_unify_gen.m 21 Aug 2007 15:50:42 -0000 1.115
+++ ml_unify_gen.m 10 Sep 2007 08:51:20 -0000
@@ -296,7 +296,7 @@
;
% Constants.
( Tag = int_tag(_)
- ; Tag = foreign_tag(_)
+ ; Tag = foreign_tag(_, _)
; Tag = float_tag(_)
; Tag = string_tag(_)
; Tag = reserved_address_tag(_)
@@ -410,8 +410,9 @@
ml_gen_constant(string_tag(String), _, const(mlconst_string(String)), !Info).
ml_gen_constant(int_tag(Int), _, const(mlconst_int(Int)), !Info).
-ml_gen_constant(foreign_tag(ForeignTag), _, Rval, !Info) :-
- Rval = const(mlconst_foreign(ForeignTag, mlds_native_int_type)).
+ml_gen_constant(foreign_tag(ForeignLang, ForeignTag), _, Rval, !Info) :-
+ Rval = const(mlconst_foreign(ForeignLang, ForeignTag,
+ mlds_native_int_type)).
ml_gen_constant(float_tag(Float), _, const(mlconst_float(Float)), !Info).
ml_gen_constant(shared_local_tag(Bits1, Num1), VarType, Rval, !Info) :-
ml_gen_type(!.Info, VarType, MLDS_Type),
@@ -1312,7 +1313,7 @@
(
( Tag = string_tag(_String)
; Tag = int_tag(_Int)
- ; Tag = foreign_tag(_)
+ ; Tag = foreign_tag(_, _)
; Tag = float_tag(_Float)
; Tag = pred_closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
@@ -1389,7 +1390,7 @@
;
( Tag = string_tag(_String)
; Tag = int_tag(_Int)
- ; Tag = foreign_tag(_)
+ ; Tag = foreign_tag(_, _)
; Tag = float_tag(_Float)
; Tag = pred_closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
@@ -1673,8 +1674,9 @@
binop(float_eq, Rval, const(mlconst_float(Float))).
ml_gen_tag_test_rval(int_tag(Int), _, _, Rval) =
binop(eq, Rval, const(mlconst_int(Int))).
-ml_gen_tag_test_rval(foreign_tag(ForeignVal), _, _, Rval) =
- binop(eq, Rval, const(mlconst_foreign(ForeignVal, mlds_native_int_type))).
+ml_gen_tag_test_rval(foreign_tag(ForeignLang, ForeignVal), _, _, Rval) =
+ binop(eq, Rval, const(mlconst_foreign(ForeignLang, ForeignVal,
+ mlds_native_int_type))).
ml_gen_tag_test_rval(pred_closure_tag(_, _, _), _, _, _Rval) = _TestRval :-
% This should never happen, since the error will be detected
% during mode checking.
Index: ml_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/ml_util.m,v
retrieving revision 1.59
diff -u -r1.59 ml_util.m
--- ml_util.m 21 Aug 2007 17:40:32 -0000 1.59
+++ ml_util.m 10 Sep 2007 08:51:20 -0000
@@ -180,7 +180,7 @@
:- func gen_init_string(string) = mlds_initializer.
-:- func gen_init_foreign(string) = mlds_initializer.
+:- func gen_init_foreign(foreign_language, string) = mlds_initializer.
:- func gen_init_int(int) = mlds_initializer.
@@ -702,8 +702,8 @@
gen_init_int(Int) = init_obj(const(mlconst_int(Int))).
-gen_init_foreign(String) =
- init_obj(const(mlconst_foreign(String, mlds_native_int_type))).
+gen_init_foreign(Lang, String) =
+ init_obj(const(mlconst_foreign(Lang, String, mlds_native_int_type))).
gen_init_bool(no) = init_obj(const(mlconst_false)).
gen_init_bool(yes) = init_obj(const(mlconst_true)).
Index: mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.158
diff -u -r1.158 mlds.m
--- mlds.m 31 Aug 2007 06:36:41 -0000 1.158
+++ mlds.m 10 Sep 2007 08:51:20 -0000
@@ -1590,7 +1590,7 @@
---> mlconst_true
; mlconst_false
; mlconst_int(int)
- ; mlconst_foreign(string, mlds_type)
+ ; mlconst_foreign(foreign_language, string, mlds_type)
; mlconst_float(float)
; mlconst_string(string)
; mlconst_multi_string(list(string))
Index: mlds_to_c.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.225
diff -u -r1.225 mlds_to_c.m
--- mlds_to_c.m 31 Aug 2007 07:35:15 -0000 1.225
+++ mlds_to_c.m 10 Sep 2007 08:51:20 -0000
@@ -1247,9 +1247,11 @@
->
io.write_int(Value, !IO)
;
- Initializer = init_obj(const(mlconst_foreign(Value,
+ Initializer = init_obj(const(mlconst_foreign(Lang, Value,
mlds_native_int_type)))
->
+ expect(unify(Lang, lang_c), this_file,
+ "mlconst_foreign for language other than C."),
io.write_string(Value, !IO)
;
unexpected(this_file,
@@ -3841,7 +3843,9 @@
% when `Integer' is 64 bits but `int' is 32 bits.
io.write_string("(MR_Integer) ", !IO),
io.write_int(N, !IO).
-mlds_output_rval_const(mlconst_foreign(Value, Type), !IO) :-
+mlds_output_rval_const(mlconst_foreign(Lang, Value, Type), !IO) :-
+ expect(unify(Lang, lang_c), this_file,
+ "output_rval_const - mlconst_foreign for language other than C."),
io.write_string("((", !IO),
mlds_output_type(Type, !IO),
io.write_string(") ", !IO),
Index: mlds_to_gcc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.135
diff -u -r1.135 mlds_to_gcc.m
--- mlds_to_gcc.m 21 Aug 2007 17:40:33 -0000 1.135
+++ mlds_to_gcc.m 10 Sep 2007 08:51:20 -0000
@@ -3670,7 +3670,7 @@
gcc__build_int(0, Expr).
build_rval_const(mlconst_int(N), _, Expr) -->
gcc__build_int(N, Expr).
-build_rval_const(mlconst_foreign(_Value, _Type), _, _) -->
+build_rval_const(mlconst_foreign(_Lang, _Value, _Type), _, _) -->
{ sorry(this_file,
"foreign tags not yet supported with `--target asm'") }.
build_rval_const(mlconst_float(FloatVal), _, Expr) -->
Index: mlds_to_il.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.194
diff -u -r1.194 mlds_to_il.m
--- mlds_to_il.m 31 Aug 2007 07:35:15 -0000 1.194
+++ mlds_to_il.m 10 Sep 2007 08:51:20 -0000
@@ -560,7 +560,7 @@
rename_const(mlconst_true) = mlconst_true.
rename_const(mlconst_false) = mlconst_false.
rename_const(mlconst_int(I)) = mlconst_int(I).
-rename_const(mlconst_foreign(F, T)) = mlconst_foreign(F, T).
+rename_const(mlconst_foreign(L, F, T)) = mlconst_foreign(L, F, T).
rename_const(mlconst_float(F)) = mlconst_float(F).
rename_const(mlconst_string(S)) = mlconst_string(S).
rename_const(mlconst_multi_string(S)) = mlconst_multi_string(S).
@@ -2393,7 +2393,7 @@
Const = mlconst_int(Int),
Instrs = instr_node(ldc(int32, i(Int)))
;
- Const = mlconst_foreign(_F, _T),
+ Const = mlconst_foreign(_Lang, _F, _T),
sorry(this_file, "NYI IL backend and foreign tags.")
;
Const = mlconst_float(Float),
@@ -3727,7 +3727,7 @@
rval_const_to_type(mlconst_int(_))
= mercury_type(IntType, type_cat_int, non_foreign_type(IntType)) :-
IntType = builtin_type(builtin_type_int).
-rval_const_to_type(mlconst_foreign(_, _))
+rval_const_to_type(mlconst_foreign(_, _, _))
= sorry(this_file, "IL backend and foreign tag.").
rval_const_to_type(mlconst_float(_))
= mercury_type(FloatType, type_cat_float,
Index: mlds_to_java.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.99
diff -u -r1.99 mlds_to_java.m
--- mlds_to_java.m 31 Aug 2007 07:35:16 -0000 1.99
+++ mlds_to_java.m 10 Sep 2007 08:51:20 -0000
@@ -3305,7 +3305,9 @@
% XXX Should we parenthesize this?
%
-output_rval_const(mlconst_foreign(Value, _Type), !IO) :-
+output_rval_const(mlconst_foreign(Lang, Value, _Type), !IO) :-
+ expect(unify(Lang, lang_java), this_file,
+ "output_rval_const - mlconst_foreign for language other than Java."),
io.write_string(Value, !IO).
output_rval_const(mlconst_float(FloatVal), !IO) :-
Index: mlds_to_managed.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mlds_to_managed.m,v
retrieving revision 1.47
diff -u -r1.47 mlds_to_managed.m
--- mlds_to_managed.m 21 Aug 2007 15:50:44 -0000 1.47
+++ mlds_to_managed.m 10 Sep 2007 08:51:20 -0000
@@ -468,8 +468,8 @@
io.write_string("0", !IO).
write_rval_const(mlconst_int(I), !IO) :-
io.write_int(I, !IO).
-write_rval_const(mlconst_foreign(Value, _Type), !IO) :-
- io.write_string(Value, !IO).
+write_rval_const(mlconst_foreign(_Lang, _Value, _Type), !IO) :-
+ sorry(this_file, "mlconst_foreign for managed languages").
write_rval_const(mlconst_float(F), !IO) :-
io.write_float(F, !IO).
% XXX We don't quote this correctly.
Index: rtti.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti.m,v
retrieving revision 1.85
diff -u -r1.85 rtti.m
--- rtti.m 20 Aug 2007 03:36:05 -0000 1.85
+++ rtti.m 10 Sep 2007 08:51:20 -0000
@@ -30,6 +30,7 @@
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_rtti.
+:- import_module libs.globals.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.
@@ -182,6 +183,7 @@
:: list(int)
)
; foreign_enum(
+ foreign_enum_language :: foreign_language,
foreign_enum_axioms :: equality_axioms,
foreign_enum_functors :: list(foreign_enum_functor),
foreign_enum_ordinal_table :: map(int, foreign_enum_functor),
@@ -1542,7 +1544,7 @@
)
)
;
- TypeCtorDetails = foreign_enum(TypeCtorUserEq, _, _, _, _),
+ TypeCtorDetails = foreign_enum(_, TypeCtorUserEq, _, _, _, _),
(
TypeCtorUserEq = standard,
RepStr = "MR_TYPECTOR_REP_FOREIGN_ENUM"
@@ -1685,7 +1687,7 @@
rtti_data_pseudo_type_info(type_var(0)).
type_ctor_details_num_ptags(enum(_, _, _, _, _, _)) = -1.
-type_ctor_details_num_ptags(foreign_enum(_, _, _, _, _)) = -1.
+type_ctor_details_num_ptags(foreign_enum(_, _, _, _, _, _)) = -1.
type_ctor_details_num_ptags(du(_, _, PtagMap, _, _)) = LastPtag + 1 :-
map.keys(PtagMap, Ptags),
list.last_det(Ptags, LastPtag).
@@ -1707,7 +1709,7 @@
type_ctor_details_num_functors(enum(_, Functors, _, _, _, _)) =
list.length(Functors).
-type_ctor_details_num_functors(foreign_enum(_, Functors, _, _, _)) =
+type_ctor_details_num_functors(foreign_enum(_, _, Functors, _, _, _)) =
list.length(Functors).
type_ctor_details_num_functors(du(_, Functors, _, _, _)) =
list.length(Functors).
Index: rtti_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_out.m,v
retrieving revision 1.74
diff -u -r1.74 rtti_out.m
--- rtti_out.m 20 Aug 2007 03:36:05 -0000 1.74
+++ rtti_out.m 10 Sep 2007 08:51:20 -0000
@@ -667,8 +667,10 @@
MaybeFunctorsName = yes(type_ctor_enum_name_ordered_table),
HaveFunctorNumberMap = yes
;
- TypeCtorDetails = foreign_enum(_, ForeignEnumFunctors,
+ TypeCtorDetails = foreign_enum(Lang, _, ForeignEnumFunctors,
ForeignEnumByOrdinal, ForeignEnumByName, FunctorNumberMap),
+ expect(unify(Lang, lang_c), this_file,
+ "language other than C for foreign enumeration"),
list.foldl2(output_foreign_enum_functor_defn(RttiTypeCtor),
ForeignEnumFunctors, !DeclSet, !IO),
output_foreign_enum_ordinal_ordered_table(RttiTypeCtor,
Index: rtti_to_mlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.81
diff -u -r1.81 rtti_to_mlds.m
--- rtti_to_mlds.m 20 Aug 2007 03:36:05 -0000 1.81
+++ rtti_to_mlds.m 10 Sep 2007 08:51:20 -0000
@@ -61,6 +61,7 @@
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_rtti.
:- import_module libs.compiler_util.
+:- import_module libs.globals.
:- import_module mdbcomp.prim_data.
:- import_module ml_backend.ml_closure_gen.
:- import_module ml_backend.ml_code_util.
@@ -525,10 +526,11 @@
type_ctor_functor_number_map),
Defns = EnumFunctorDescs ++ [ByValueDefn, ByNameDefn, NumberMapDefn]
;
- TypeCtorDetails = foreign_enum(_, ForeignEnumFunctors,
+ TypeCtorDetails = foreign_enum(ForeignEnumLang, _, ForeignEnumFunctors,
ForeignEnumByOrdinal, ForeignEnumByName, FunctorNumberMap),
ForeignEnumFunctorDescs = list.map(
- gen_foreign_enum_functor_desc(ModuleInfo, RttiTypeCtor),
+ gen_foreign_enum_functor_desc(ModuleInfo, ForeignEnumLang,
+ RttiTypeCtor),
ForeignEnumFunctors),
ByOrdinalDefn = gen_foreign_enum_ordinal_ordered_table(ModuleInfo,
RttiTypeCtor, ForeignEnumByOrdinal),
@@ -636,18 +638,18 @@
]),
rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn).
-:- func gen_foreign_enum_functor_desc(module_info, rtti_type_ctor,
- foreign_enum_functor) = mlds_defn.
+:- func gen_foreign_enum_functor_desc(module_info, foreign_language,
+ rtti_type_ctor, foreign_enum_functor) = mlds_defn.
-gen_foreign_enum_functor_desc(_ModuleInfo, RttiTypeCtor, ForeignEnumFunctor)
- = MLDS_Defn :-
+gen_foreign_enum_functor_desc(_ModuleInfo, Lang,
+ RttiTypeCtor, ForeignEnumFunctor) = MLDS_Defn :-
ForeignEnumFunctor = foreign_enum_functor(FunctorName, Ordinal, Value),
RttiName = type_ctor_foreign_enum_functor_desc(Ordinal),
RttiId = ctor_rtti_id(RttiTypeCtor, RttiName),
Init = init_struct(mlds_rtti_type(item_type(RttiId)), [
gen_init_string(FunctorName),
gen_init_int(Ordinal),
- gen_init_foreign(Value)
+ gen_init_foreign(Lang, Value)
]),
rtti_id_and_init_to_defn(RttiId, Init, MLDS_Defn).
Index: switch_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.37
diff -u -r1.37 switch_util.m
--- switch_util.m 20 Aug 2007 03:36:06 -0000 1.37
+++ switch_util.m 10 Sep 2007 08:51:20 -0000
@@ -277,7 +277,7 @@
switch_priority(no_tag) = 0. % should never occur
switch_priority(int_tag(_)) = 1.
-switch_priority(foreign_tag(_)) = 1.
+switch_priority(foreign_tag(_, _)) = 1.
switch_priority(reserved_address_tag(_)) = 1.
switch_priority(shared_local_tag(_, _)) = 1.
switch_priority(single_functor_tag) = 2.
@@ -392,7 +392,7 @@
; Tag = string_tag(_)
; Tag = float_tag(_)
; Tag = int_tag(_)
- ; Tag = foreign_tag(_)
+ ; Tag = foreign_tag(_, _)
; Tag = pred_closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
@@ -459,7 +459,7 @@
; Tag = string_tag(_)
; Tag = float_tag(_)
; Tag = int_tag(_)
- ; Tag = foreign_tag(_)
+ ; Tag = foreign_tag(_, _)
; Tag = pred_closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
; Tag = base_typeclass_info_tag(_, _, _)
Index: type_ctor_info.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.90
diff -u -r1.90 type_ctor_info.m
--- type_ctor_info.m 20 Aug 2007 03:36:06 -0000 1.90
+++ type_ctor_info.m 10 Sep 2007 08:51:20 -0000
@@ -374,8 +374,8 @@
make_enum_details(Ctors, ConsTagMap, ReservedTag,
EqualityAxioms, Details)
;
- EnumDummy = is_foreign_enum,
- make_foreign_enum_details(Ctors, ConsTagMap, ReservedTag,
+ EnumDummy = is_foreign_enum(Lang),
+ make_foreign_enum_details(Lang, Ctors, ConsTagMap, ReservedTag,
EqualityAxioms, Details)
;
EnumDummy = is_dummy,
@@ -636,10 +636,11 @@
% Make the functor and layout tables for a foreign enum type.
%
-:- pred make_foreign_enum_details(list(constructor)::in, cons_tag_values::in,
- bool::in, equality_axioms::in, type_ctor_details::out) is det.
+:- pred make_foreign_enum_details(foreign_language::in, list(constructor)::in,
+ cons_tag_values::in, bool::in, equality_axioms::in,
+ type_ctor_details::out) is det.
-make_foreign_enum_details(Ctors, ConsTagMap, ReserveTag, EqualityAxioms,
+make_foreign_enum_details(Lang, Ctors, ConsTagMap, ReserveTag, EqualityAxioms,
Details) :-
(
ReserveTag = yes,
@@ -647,13 +648,14 @@
;
ReserveTag = no
),
- make_foreign_enum_functors(Ctors, 0, ConsTagMap, ForeignEnumFunctors),
+ make_foreign_enum_functors(Lang, Ctors, 0, ConsTagMap,
+ ForeignEnumFunctors),
OrdinalMap0 = map.init,
NameMap0 = map.init,
list.foldl2(make_foreign_enum_maps, ForeignEnumFunctors,
OrdinalMap0, OrdinalMap, NameMap0, NameMap),
FunctorNumberMap = make_functor_number_map(Ctors),
- Details = foreign_enum(EqualityAxioms, ForeignEnumFunctors,
+ Details = foreign_enum(Lang, EqualityAxioms, ForeignEnumFunctors,
OrdinalMap, NameMap, FunctorNumberMap).
% Create a foreign_enum_functor structure for each functor in an enum type.
@@ -664,12 +666,12 @@
% caller to sort this list on functor name, which is how the type functors
% structure is constructed.
%
-:- pred make_foreign_enum_functors(list(constructor)::in,
+:- pred make_foreign_enum_functors(foreign_language::in, list(constructor)::in,
int::in, cons_tag_values::in, list(foreign_enum_functor)::out) is det.
-make_foreign_enum_functors([], _, _, []).
-make_foreign_enum_functors([Functor | Functors], NextOrdinal, ConsTagMap,
- [ForeignEnumFunctor | ForeignEnumFunctors]) :-
+make_foreign_enum_functors(_, [], _, _, []).
+make_foreign_enum_functors(Lang, [Functor | Functors], NextOrdinal,
+ ConsTagMap, [ForeignEnumFunctor | ForeignEnumFunctors]) :-
Functor = ctor(ExistTvars, Constraints, SymName, FunctorArgs, _Context),
expect(unify(ExistTvars, []), this_file,
"existential arguments in functor in foreign enum"),
@@ -680,7 +682,9 @@
"functor in foreign enum has nonzero arity"),
ConsId = make_cons_id_from_qualified_sym_name(SymName, FunctorArgs),
map.lookup(ConsTagMap, ConsId, ConsTag),
- ( ConsTag = foreign_tag(ForeignTagValue0) ->
+ ( ConsTag = foreign_tag(ForeignTagLang, ForeignTagValue0) ->
+ expect(unify(Lang, ForeignTagLang), this_file,
+ "language mismatch between foreign tag and foreign enum."),
ForeignTagValue = ForeignTagValue0
;
unexpected(this_file, "non foreign tag for foreign enum functor")
@@ -688,7 +692,7 @@
FunctorName = unqualify_name(SymName),
ForeignEnumFunctor = foreign_enum_functor(FunctorName, NextOrdinal,
ForeignTagValue),
- make_foreign_enum_functors(Functors, NextOrdinal + 1, ConsTagMap,
+ make_foreign_enum_functors(Lang, Functors, NextOrdinal + 1, ConsTagMap,
ForeignEnumFunctors).
:- pred make_foreign_enum_maps(foreign_enum_functor::in,
@@ -837,7 +841,7 @@
( ConsTag = no_tag
; ConsTag = string_tag(_)
; ConsTag = int_tag(_)
- ; ConsTag = foreign_tag(_)
+ ; ConsTag = foreign_tag(_, _)
; ConsTag = float_tag(_)
; ConsTag = pred_closure_tag(_, _, _)
; ConsTag = type_ctor_info_tag(_, _, _)
Index: type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.181
diff -u -r1.181 type_util.m
--- type_util.m 6 Sep 2007 12:45:25 -0000 1.181
+++ type_util.m 10 Sep 2007 08:51:20 -0000
@@ -561,7 +561,7 @@
Ctors = TypeBody ^ du_type_ctors,
UserEqCmp = TypeBody ^ du_type_usereq,
EnumOrDummy = TypeBody ^ du_type_is_enum,
- EnumOrDummy \= is_foreign_enum,
+ EnumOrDummy \= is_foreign_enum(_),
constructor_list_represents_dummy_argument_type(Ctors, UserEqCmp)
)
;
@@ -668,7 +668,7 @@
module_info_get_type_table(ModuleInfo, TypeDefnTable),
map.search(TypeDefnTable, TypeCtor, TypeDefn),
get_type_defn_body(TypeDefn, TypeBody),
- TypeBody ^ du_type_is_enum = is_foreign_enum.
+ TypeBody ^ du_type_is_enum = is_foreign_enum(_).
%-----------------------------------------------------------------------------%
Index: unify_gen.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.182
diff -u -r1.182 unify_gen.m
--- unify_gen.m 20 Aug 2007 03:36:07 -0000 1.182
+++ unify_gen.m 10 Sep 2007 08:51:20 -0000
@@ -280,7 +280,9 @@
ConsTag = int_tag(Int),
TestRval = binop(eq, Rval, const(llconst_int(Int)))
;
- ConsTag = foreign_tag(ForeignVal),
+ ConsTag = foreign_tag(ForeignLang, ForeignVal),
+ expect(unify(ForeignLang, lang_c), this_file,
+ "foreign tag for language other than C"),
TestRval = binop(eq, Rval, const(llconst_foreign(ForeignVal, integer)))
;
ConsTag = pred_closure_tag(_, _, _),
@@ -390,7 +392,9 @@
code_info.assign_const_to_var(Var, const(llconst_int(Int)), !CI),
Code = empty
;
- ConsTag = foreign_tag(Val),
+ ConsTag = foreign_tag(Lang, Val),
+ expect(unify(Lang, lang_c), this_file,
+ "foreign_tag for language other than C"),
ForeignConst = const(llconst_foreign(Val, integer)),
code_info.assign_const_to_var(Var, ForeignConst, !CI),
Code = empty
@@ -945,7 +949,7 @@
(
( Tag = string_tag(_String)
; Tag = int_tag(_Int)
- ; Tag = foreign_tag(_)
+ ; Tag = foreign_tag(_, _)
; Tag = float_tag(_Float)
; Tag = pred_closure_tag(_, _, _)
; Tag = type_ctor_info_tag(_, _, _)
Index: unify_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.191
diff -u -r1.191 unify_proc.m
--- unify_proc.m 27 Aug 2007 06:22:16 -0000 1.191
+++ unify_proc.m 10 Sep 2007 08:51:20 -0000
@@ -780,7 +780,7 @@
(
TypeBody = hlds_du_type(Ctors, _, EnumDummy, _, _, _),
(
- ( EnumDummy = is_foreign_enum
+ ( EnumDummy = is_foreign_enum(_)
; EnumDummy = is_enum
),
make_simple_test(X, Y, umc_explicit, [], Goal),
@@ -992,12 +992,14 @@
% an integer comparison, and does not call the type's index
% predicate, so do not generate an index predicate for such
% types.
- ( EnumDummy = is_enum
- ; EnumDummy = is_foreign_enum
- ),
+ EnumDummy = is_enum,
unexpected(this_file,
"trying to create index proc for enum type")
;
+ EnumDummy = is_foreign_enum(_),
+ unexpected(this_file,
+ "trying to create index proc for foreign enum type")
+ ;
EnumDummy = is_dummy,
unexpected(this_file,
"trying to create index proc for dummy type")
@@ -1053,7 +1055,7 @@
TypeBody = hlds_du_type(Ctors0, _, EnumDummy, _, _, _),
(
( EnumDummy = is_enum
- ; EnumDummy = is_foreign_enum
+ ; EnumDummy = is_foreign_enum(_)
),
generate_enum_compare_proc_body(Res, X, Y, Context, Clause,
!Info)
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list