[m-rev.] diff/for review: can_pass_as_mercury_type
Zoltan Somogyi
zs at cs.mu.OZ.AU
Wed May 12 20:25:25 AEST 2004
The need for this kind of assertion became evident during benchmarking of the
tabling system; the memcpy in boxing/unboxing was consuming too much time.
Once this change has bootstrapped, I intend to add the new assertion
to all the foreign C types in library/table_builtin.m.
Zoltan.
Extend foreign_type declarations with optional annotations that allow the
programmer to assert that values of the given type can be passed to and from
Mercury without boxing, via casts, which are faster.
doc/reference_manual.texi:
Document the new assertions.
compiler/prog_io_pragma.m:
Parse the new assertions in foreign_type declarations.
compiler/prog_data.m:
compiler/hlds_data.m:
Extend the foreign_type item and the foreign_type kind of HLDS type
definition with a field containing a list of assertions. Currently
the only assertion available is the one described above.
compiler/llds.m:
Extend the structures containing the input/output arguments of
foreign_procs with the list of applicable assertions.
compiler/make_hlds.m:
Transfer any assertions from foreign_type items to the HLDS type
definition.
compiler/pragma_c_gen.m:
Transfer any assertions from the HLDS type definition to the
descriptions of the inputs and outputs.
compiler/llds_out.m:
If the new assertion is present in the input/output arguments of
foreign_procs, generate casts instead of boxing/unboxing code.
compiler/foreign.m:
compiler/intermod.m:
compiler/mercury_to_mercury.m:
compiler/ml_code_gen.m:
compiler/mlds.m:
compiler/module_qual.m:
compiler/modules.m:
compiler/recompilation.check.m:
compiler/recompilation.version.m:
Minor changes to conform to the changes in data structures.
tests/hard_coded/foreign_type_assertion.{m,exp}
New test case to test the handling of the new assertion.
tests/hard_coded/Mmakefile:
Enable the new assertion in C grades.
cvs server: Diffing .
cvs server: Diffing analysis
cvs server: Diffing bindist
cvs server: Diffing boehm_gc
cvs server: Diffing boehm_gc/Mac_files
cvs server: Diffing boehm_gc/cord
cvs server: Diffing boehm_gc/cord/private
cvs server: Diffing boehm_gc/doc
cvs server: Diffing boehm_gc/include
cvs server: Diffing boehm_gc/include/private
cvs server: Diffing boehm_gc/tests
cvs server: Diffing browser
cvs server: Diffing bytecode
cvs server: Diffing compiler
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.36
diff -u -b -r1.36 foreign.m
--- compiler/foreign.m 23 Mar 2004 10:52:03 -0000 1.36
+++ compiler/foreign.m 12 May 2004 10:15:02 -0000
@@ -693,30 +693,50 @@
module_info_globals(ModuleInfo, Globals),
globals__get_target(Globals, Target),
- ( Target = c,
- ( MaybeC = yes(c(NameStr) - MaybeUserEqComp),
+ (
+ Target = c,
+ (
+ MaybeC = yes(Data),
+ Data = foreign_type_lang_data(c(NameStr),
+ MaybeUserEqComp, _Assertions),
Name = unqualified(NameStr)
- ; MaybeC = no,
+ ;
+ MaybeC = no,
unexpected(this_file,
"to_exported_type: no C type")
)
- ; Target = il,
- ( MaybeIL = yes(il(_, _, Name) - MaybeUserEqComp)
- ; MaybeIL = no,
+ ;
+ Target = il,
+ (
+ MaybeIL = yes(Data),
+ Data = foreign_type_lang_data(il(_, _, Name),
+ MaybeUserEqComp, _Assertions)
+ ;
+ MaybeIL = no,
unexpected(this_file,
"to_exported_type: no IL type")
)
- ; Target = java,
- ( MaybeJava = yes(java(NameStr) - MaybeUserEqComp),
+ ;
+ Target = java,
+ (
+ MaybeJava = yes(Data),
+ Data = foreign_type_lang_data(java(NameStr),
+ MaybeUserEqComp, _Assertions),
Name = unqualified(NameStr)
- ; MaybeJava = no,
+ ;
+ MaybeJava = no,
unexpected(this_file,
"to_exported_type: no Java type")
)
- ; Target = asm,
- ( MaybeC = yes(c(NameStr) - MaybeUserEqComp),
+ ;
+ Target = asm,
+ (
+ MaybeC = yes(Data),
+ Data = foreign_type_lang_data(c(NameStr),
+ MaybeUserEqComp, _Assertions),
Name = unqualified(NameStr)
- ; MaybeC = no,
+ ;
+ MaybeC = no,
unexpected(this_file,
"to_exported_type: no C type")
)
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.84
diff -u -b -r1.84 hlds_data.m
--- compiler/hlds_data.m 24 Mar 2004 00:39:28 -0000 1.84
+++ compiler/hlds_data.m 12 May 2004 10:15:05 -0000
@@ -337,7 +337,14 @@
java :: foreign_type_lang_body(java_foreign_type)
).
-:- type foreign_type_lang_body(T) == maybe(pair(T, maybe(unify_compare))).
+:- type foreign_type_lang_body(T) == maybe(foreign_type_lang_data(T)).
+
+:- type foreign_type_lang_data(T)
+ ---> foreign_type_lang_data(
+ T,
+ maybe(unify_compare),
+ list(foreign_type_assertion)
+ ).
% The `cons_tag_values' type stores the information on how
% a discriminated union type is represented.
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.158
diff -u -b -r1.158 intermod.m
--- compiler/intermod.m 23 Mar 2004 10:52:04 -0000 1.158
+++ compiler/intermod.m 12 May 2004 10:15:10 -0000
@@ -1139,16 +1139,17 @@
).
:- pred intermod__resolve_foreign_type_body_overloading_2(module_info::in,
- type_ctor::in, foreign_type_lang_body(T)::in,
- foreign_type_lang_body(T)::out, intermod_info::in,
- intermod_info::out) is det.
+ type_ctor::in,
+ foreign_type_lang_body(T)::in, foreign_type_lang_body(T)::out,
+ intermod_info::in, intermod_info::out) is det.
-intermod__resolve_foreign_type_body_overloading_2(_, _, no, no, Info, Info).
+intermod__resolve_foreign_type_body_overloading_2(_, _, no, no, !Info).
intermod__resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
- yes(Body - MaybeEqComp0), yes(Body - MaybeEqComp),
- Info0, Info) :-
+ yes(foreign_type_lang_data(Body, MaybeEqComp0, Assertions)),
+ yes(foreign_type_lang_data(Body, MaybeEqComp, Assertions)),
+ !Info) :-
intermod__resolve_unify_compare_overloading(ModuleInfo, TypeCtor,
- MaybeEqComp0, MaybeEqComp, Info0, Info).
+ MaybeEqComp0, MaybeEqComp, !Info).
:- pred intermod__resolve_unify_compare_overloading(module_info::in,
type_ctor::in, maybe(unify_compare)::in, maybe(unify_compare)::out,
@@ -1340,32 +1341,44 @@
{ ForeignTypeBody = foreign_type_body(MaybeIL, MaybeC,
MaybeJava) }
->
- ( { MaybeIL = yes(ILForeignType - ILUserEqComp) },
+ (
+ { MaybeIL = yes(DataIL) },
+ { DataIL = foreign_type_lang_data(ILForeignType,
+ ILUserEqComp, AssertionsIL) },
mercury_output_item(
type_defn(VarSet, Name, Args,
foreign_type(il(ILForeignType),
- ILUserEqComp), true),
+ ILUserEqComp, AssertionsIL),
+ true),
Context)
- ; { MaybeIL = no },
- []
+ ;
+ { MaybeIL = no }
),
- ( { MaybeC = yes(CForeignType - CUserEqComp) },
+ (
+ { MaybeC = yes(DataC) },
+ { DataC = foreign_type_lang_data(CForeignType,
+ CUserEqComp, AssertionsC) },
mercury_output_item(
type_defn(VarSet, Name, Args,
foreign_type(c(CForeignType),
- CUserEqComp), true),
+ CUserEqComp, AssertionsC),
+ true),
Context)
- ; { MaybeC = no },
- []
+ ;
+ { MaybeC = no }
),
- ( { MaybeJava = yes(JavaForeignType - JavaUserEqComp) },
+ (
+ { MaybeJava = yes(DataJava) },
+ { DataJava = foreign_type_lang_data(JavaForeignType,
+ JavaUserEqComp, AssertionsJava) },
mercury_output_item(
type_defn(VarSet, Name, Args,
foreign_type(java(JavaForeignType),
- JavaUserEqComp), true),
+ JavaUserEqComp, AssertionsJava),
+ true),
Context)
- ; { MaybeJava = no },
- []
+ ;
+ { MaybeJava = no }
)
;
[]
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.301
diff -u -b -r1.301 llds.m
--- compiler/llds.m 10 Apr 2004 10:33:01 -0000 1.301
+++ compiler/llds.m 12 May 2004 10:15:12 -0000
@@ -565,17 +565,37 @@
% A pragma_c_input represents the code that initializes one
% of the input variables for a pragma_c instruction.
:- type pragma_c_input
- ---> pragma_c_input(string, type, rval, maybe(string)).
- % variable name, type, variable value,
- % maybe C type if foreign type.
+ ---> pragma_c_input(
+ string, % the variable's name
+ type, % the variable's type
+ rval, % the variable's value
+ maybe(pragma_c_foreign_type)
+ % if type is a foreign type,
+ % info about that foreign type
+ ).
% A pragma_c_output represents the code that stores one of
% of the outputs for a pragma_c instruction.
:- type pragma_c_output
- ---> pragma_c_output(lval, type, string, maybe(string)).
- % where to put the output val, type and name
- % of variable containing the output val
- % followed by maybe C type if foreign type.
+ ---> pragma_c_output(
+ lval, % where to put the output val,
+ type,
+ string,
+ % type and name of the variable containing
+ % the output val
+ maybe(pragma_c_foreign_type)
+ % if type is a foreign type,
+ % info about that foreign type
+ ).
+
+:- type pragma_c_foreign_type
+ ---> pragma_c_foreign_type(
+ string, % The C type name.
+ list(foreign_type_assertion)
+ % The assertions on the foreign_type
+ % declarations that the C type name
+ % came from.
+ ).
% see runtime/mercury_trail.h
:- type reset_trail_reason
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.228
diff -u -b -r1.228 llds_out.m
--- compiler/llds_out.m 3 May 2004 11:38:36 -0000 1.228
+++ compiler/llds_out.m 12 May 2004 10:15:13 -0000
@@ -2165,17 +2165,29 @@
output_pragma_inputs([], !IO).
output_pragma_inputs([Input | Inputs], !IO) :-
- Input = pragma_c_input(VarName, Type, Rval, MaybeForeignType),
+ Input = pragma_c_input(VarName, Type, Rval, MaybeForeignTypeInfo),
io__write_string("\t", !IO),
(
- MaybeForeignType = yes(ForeignType),
+ MaybeForeignTypeInfo = yes(ForeignTypeInfo),
+ ForeignTypeInfo = pragma_c_foreign_type(ForeignType,
+ Assertions),
% For foreign types for which c_type_is_word_sized_int_or_ptr
% succeeds, the code in the else branch is not only correct,
% it also generates faster code than would be generated by
% the then branch, because MR_MAYBE_UNBOX_FOREIGN_TYPE
% invokes memcpy when given a word-sized type.
- \+ c_type_is_word_sized_int_or_ptr(ForeignType)
+ (
+ ( c_type_is_word_sized_int_or_ptr(ForeignType)
+ ; list__member(can_pass_as_mercury_type, Assertions)
+ )
->
+ % Note that for this cast to be correct the foreign
+ % type must be a word sized integer or pointer type.
+ io__write_string(VarName, !IO),
+ io__write_string(" = ", !IO),
+ io__write_string("(" ++ ForeignType ++ ") ", !IO),
+ output_rval_as_type(Rval, word, !IO)
+ ;
io__write_string("MR_MAYBE_UNBOX_FOREIGN_TYPE(", !IO),
io__write_string(ForeignType, !IO),
io__write_string(", ", !IO),
@@ -2183,7 +2195,9 @@
io__write_string(", ", !IO),
io__write_string(VarName, !IO),
io__write_string(")", !IO)
+ )
;
+ MaybeForeignTypeInfo = no,
io__write_string(VarName, !IO),
io__write_string(" = ", !IO),
( Type = term__functor(term__atom("string"), [], _) ->
@@ -2192,14 +2206,6 @@
; Type = term__functor(term__atom("float"), [], _) ->
output_rval_as_type(Rval, float, !IO)
;
- % 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)
- ;
- true
- ),
output_rval_as_type(Rval, word, !IO)
)
),
@@ -2225,7 +2231,16 @@
output_pragma_outputs([O | Outputs], !IO) :-
O = pragma_c_output(Lval, Type, VarName, MaybeForeignType),
io__write_string("\t", !IO),
- ( MaybeForeignType = yes(ForeignType) ->
+ (
+ MaybeForeignType = yes(ForeignTypeInfo),
+ ForeignTypeInfo = pragma_c_foreign_type(ForeignType,
+ Assertions),
+ ( list__member(can_pass_as_mercury_type, Assertions) ->
+ output_lval_as_word(Lval, !IO),
+ io__write_string(" = ", !IO),
+ output_llds_type_cast(word, !IO),
+ io__write_string(VarName, !IO)
+ ;
io__write_string("MR_MAYBE_BOX_FOREIGN_TYPE(", !IO),
io__write_string(ForeignType, !IO),
io__write_string(", ", !IO),
@@ -2233,7 +2248,9 @@
io__write_string(", ", !IO),
output_lval_as_word(Lval, !IO),
io__write_string(")", !IO)
+ )
;
+ MaybeForeignType = no,
output_lval_as_word(Lval, !IO),
io__write_string(" = ", !IO),
(
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.466
diff -u -b -r1.466 make_hlds.m
--- compiler/make_hlds.m 5 Apr 2004 05:07:40 -0000 1.466
+++ compiler/make_hlds.m 12 May 2004 10:15:17 -0000
@@ -2647,17 +2647,23 @@
convert_type_defn(eqv_type(Body), _, _, eqv_type(Body)).
convert_type_defn(abstract_type(IsSolverType), _, _,
abstract_type(IsSolverType)).
-convert_type_defn(foreign_type(ForeignType, UserEqComp), _, _,
+convert_type_defn(foreign_type(ForeignType, UserEqComp, Assertions), _, _,
foreign_type(Body, non_solver_type)) :-
- ( ForeignType = il(ILForeignType),
- Body = foreign_type_body(yes(ILForeignType - UserEqComp),
- no, no)
- ; ForeignType = c(CForeignType),
- Body = foreign_type_body(no,
- yes(CForeignType - UserEqComp), no)
- ; ForeignType = java(JavaForeignType),
- Body = foreign_type_body(no, no,
- yes(JavaForeignType - UserEqComp))
+ (
+ ForeignType = il(ILForeignType),
+ Data = foreign_type_lang_data(ILForeignType, UserEqComp,
+ Assertions),
+ Body = foreign_type_body(yes(Data), no, no)
+ ;
+ ForeignType = c(CForeignType),
+ Data = foreign_type_lang_data(CForeignType, UserEqComp,
+ Assertions),
+ Body = foreign_type_body(no, yes(Data), no)
+ ;
+ ForeignType = java(JavaForeignType),
+ Data = foreign_type_lang_data(JavaForeignType, UserEqComp,
+ Assertions),
+ Body = foreign_type_body(no, no, yes(Data))
).
:- pred ctors_add(list(constructor)::in, type_ctor::in, tvarset::in,
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.238
diff -u -b -r1.238 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 5 Apr 2004 05:07:41 -0000 1.238
+++ compiler/mercury_to_mercury.m 12 May 2004 10:15:19 -0000
@@ -1736,7 +1736,8 @@
io__write_string("\n\t.\n").
mercury_output_type_defn(TVarSet, Name, Args,
- foreign_type(ForeignType, MaybeEqCompare), _Context) -->
+ foreign_type(ForeignType, MaybeEqCompare, Assertions),
+ _Context) -->
io__write_string(":- pragma foreign_type("),
( { ForeignType = il(_) }, io__write_string("il, ")
; { ForeignType = c(_) }, io__write_string("c, ")
@@ -1750,12 +1751,21 @@
; RefOrVal = value, RefOrValStr = "valuetype "
),
sym_name_to_string(ForeignTypeName, ".", NameStr),
- ForeignTypeStr = RefOrValStr ++ "[" ++ ForeignLocStr ++
- "]" ++ NameStr
+ ForeignTypeStr = RefOrValStr ++
+ "[" ++ ForeignLocStr ++ "]" ++ NameStr
; ForeignType = c(c(ForeignTypeStr))
; ForeignType = java(java(ForeignTypeStr))
},
io__write_string(ForeignTypeStr),
+ (
+ { Assertions = [] }
+ ;
+ { Assertions = [_ | _] },
+ io__write_string(", ["),
+ io__write_list(Assertions, ", ",
+ mercury_output_foreign_type_assertion),
+ io__write_string("]")
+ ),
io__write_string("\")"),
( { MaybeEqCompare = yes(_) } ->
io__write_string(" ")
@@ -1764,6 +1774,12 @@
),
mercury_output_equality_compare_preds(MaybeEqCompare),
io__write_string(".\n").
+
+:- pred mercury_output_foreign_type_assertion(foreign_type_assertion::in,
+ io::di, io::uo) is det.
+
+mercury_output_foreign_type_assertion(can_pass_as_mercury_type, !IO) :-
+ io__write_string("can_pass_as_mercury_type", !IO).
:- pred mercury_output_begin_type_decl(is_solver_type, io__state, io__state).
:- mode mercury_output_begin_type_decl(in, di, uo) is det.
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.138
diff -u -b -r1.138 ml_code_gen.m
--- compiler/ml_code_gen.m 24 Mar 2004 00:39:29 -0000 1.138
+++ compiler/ml_code_gen.m 12 May 2004 10:15:20 -0000
@@ -897,7 +897,10 @@
Body = foreign_type(foreign_type_body(MaybeIL,
_MaybeC, _MaybeJava), _)
->
- ( MaybeIL = yes(il(_, Location, _) - _) ->
+ (
+ MaybeIL = yes(Data),
+ Data = foreign_type_lang_data(il(_, Location, _), _, _)
+ ->
Name = il_assembly_name(mercury_module_name_to_mlds(
unqualified(Location))),
Imports = [foreign_import(Name)]
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.111
diff -u -b -r1.111 mlds.m
--- compiler/mlds.m 23 Mar 2004 10:52:09 -0000 1.111
+++ compiler/mlds.m 12 May 2004 10:15:23 -0000
@@ -1761,37 +1761,57 @@
->
module_info_globals(ModuleInfo, Globals),
globals__get_target(Globals, Target),
- ( Target = c,
- ( MaybeC = yes(CForeignType - _),
+ (
+ Target = c,
+ (
+ MaybeC = yes(Data),
+ Data = foreign_type_lang_data(CForeignType,
+ _, _),
ForeignType = c(CForeignType)
- ; MaybeC = no,
+ ;
+ MaybeC = no,
% This is checked by check_foreign_type
% in make_hlds.
unexpected(this_file,
"mercury_type_to_mlds_type: No C foreign type")
)
- ; Target = il,
- ( MaybeIL = yes(ILForeignType - _),
+ ;
+ Target = il,
+ (
+ MaybeIL = yes(Data),
+ Data = foreign_type_lang_data(ILForeignType,
+ _, _),
ForeignType = il(ILForeignType)
- ; MaybeIL = no,
+ ;
+ MaybeIL = no,
% This is checked by check_foreign_type
% in make_hlds.
unexpected(this_file,
"mercury_type_to_mlds_type: No IL foreign type")
)
- ; Target = java,
- ( MaybeJava = yes(JavaForeignType - _),
+ ;
+ Target = java,
+ (
+ MaybeJava = yes(Data),
+ Data = foreign_type_lang_data(JavaForeignType,
+ _, _),
ForeignType = java(JavaForeignType)
- ; MaybeJava = no,
+ ;
+ MaybeJava = no,
% This is checked by check_foreign_type
% in make_hlds.
unexpected(this_file,
"mercury_type_to_mlds_type: No Java foreign type")
)
- ; Target = asm,
- ( MaybeC = yes(CForeignType - _),
+ ;
+ Target = asm,
+ (
+ MaybeC = yes(Data),
+ Data = foreign_type_lang_data(CForeignType,
+ _, _),
ForeignType = c(CForeignType)
- ; MaybeC = no,
+ ;
+ MaybeC = no,
% XXX This ought to be checked by the
% front-end, e.g. check_foreign_type
% in make_hlds.
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.89
diff -u -b -r1.89 module_qual.m
--- compiler/module_qual.m 1 Dec 2003 15:55:43 -0000 1.89
+++ compiler/module_qual.m 12 May 2004 10:15:29 -0000
@@ -746,7 +746,7 @@
qualify_type_defn(eqv_type(Type0), eqv_type(Type), Info0, Info) -->
qualify_type(Type0, Type, Info0, Info).
qualify_type_defn(abstract_type(_) @ Defn, Defn, Info, Info) --> [].
-qualify_type_defn(foreign_type(_, _) @ Defn, Defn, Info, Info) --> [].
+qualify_type_defn(foreign_type(_, _, _) @ Defn, Defn, Info, Info) --> [].
:- pred qualify_constructors(list(constructor)::in, list(constructor)::out,
mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.299
diff -u -b -r1.299 modules.m
--- compiler/modules.m 19 Mar 2004 10:19:24 -0000 1.299
+++ compiler/modules.m 12 May 2004 10:15:30 -0000
@@ -6934,7 +6934,7 @@
% `:- pragma import' is only supported for C.
item_needs_foreign_imports(pragma(import(_, _, _, _, _)), c).
item_needs_foreign_imports(Item @ type_defn(_, _, _, _, _), Lang) :-
- Item ^ td_ctor_defn = foreign_type(ForeignType, _),
+ Item ^ td_ctor_defn = foreign_type(ForeignType, _, _),
Lang = foreign_type_language(ForeignType).
item_needs_foreign_imports(pragma(foreign_decl(Lang, _)), Lang).
item_needs_foreign_imports(pragma(foreign_code(Lang, _)), Lang).
@@ -6983,7 +6983,7 @@
ShortInterfaceKind = int3,
IsSolverType = non_solver_type
;
- TypeDefn = foreign_type(_, _),
+ TypeDefn = foreign_type(_, _, _),
% We always need the definitions of foreign types
% to handle inter-language interfacing correctly.
IsSolverType = non_solver_type,
@@ -7005,9 +7005,9 @@
TypeDefn = du_type(Constructors, IsSolverType,
yes(abstract_noncanonical_type))
;
- TypeDefn0 = foreign_type(ForeignType, yes(_)),
+ TypeDefn0 = foreign_type(ForeignType, yes(_), Assertions),
TypeDefn = foreign_type(ForeignType,
- yes(abstract_noncanonical_type))
+ yes(abstract_noncanonical_type), Assertions)
).
% All instance declarations must be written
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.67
diff -u -b -r1.67 pragma_c_gen.m
--- compiler/pragma_c_gen.m 23 Mar 2004 10:52:11 -0000 1.67
+++ compiler/pragma_c_gen.m 12 May 2004 10:15:34 -0000
@@ -1195,7 +1195,7 @@
code_info__produce_variable(Var, FirstCode, Rval, !CI),
% code_info__produce_variable_in_reg(Var, FirstCode, Lval, !CI)
% Rval = lval(Lval),
- MaybeForeign = get_maybe_foreign_type_name(!.CI, Type),
+ MaybeForeign = get_maybe_foreign_type_info(!.CI, Type),
Input = pragma_c_input(Name, Type, Rval, MaybeForeign),
get_pragma_input_vars(Args, Inputs1, RestCode, !CI),
Inputs = [Input | Inputs1],
@@ -1206,9 +1206,10 @@
get_pragma_input_vars(Args, Inputs, Code, !CI)
).
-:- func get_maybe_foreign_type_name(code_info, (type)) = maybe(string).
+:- func get_maybe_foreign_type_info(code_info, (type)) =
+ maybe(pragma_c_foreign_type).
-get_maybe_foreign_type_name(CI, Type) = MaybeForeignType :-
+get_maybe_foreign_type_info(CI, Type) = MaybeForeignTypeInfo :-
code_info__get_module_info(CI, Module),
module_info_types(Module, Types),
@@ -1219,16 +1220,20 @@
Body = foreign_type(foreign_type_body(_MaybeIL, MaybeC,
_MaybeJava), _)
->
- ( MaybeC = yes(c(Name) - _),
- MaybeForeignType = yes(Name)
- ; MaybeC = no,
+ (
+ MaybeC = yes(Data),
+ Data = foreign_type_lang_data(c(Name), _, Assertions),
+ MaybeForeignTypeInfo = yes(
+ pragma_c_foreign_type(Name, Assertions))
+ ;
+ MaybeC = no,
% This is ensured by check_foreign_type in
% make_hlds.
unexpected(this_file, "get_maybe_foreign_type_name: "
++ "no c foreign type")
)
;
- MaybeForeignType = no
+ MaybeForeignTypeInfo = no
).
%---------------------------------------------------------------------------%
@@ -1261,7 +1266,7 @@
code_info__release_reg(Reg, !CI),
( code_info__variable_is_forward_live(!.CI, Var) ->
code_info__set_var_location(Var, Reg, !CI),
- MaybeForeign = get_maybe_foreign_type_name(!.CI, OrigType),
+ MaybeForeign = get_maybe_foreign_type_info(!.CI, OrigType),
( var_is_not_singleton(MaybeName, Name) ->
PragmaCOutput = pragma_c_output(Reg, OrigType,
Name, MaybeForeign),
@@ -1291,8 +1296,9 @@
( var_is_not_singleton(MaybeName, Name) ->
ArgInfo = arg_info(N, _),
Reg = reg(r, N),
- MaybeForeign = get_maybe_foreign_type_name(CI, OrigType),
- Input = pragma_c_input(Name, OrigType, lval(Reg), MaybeForeign),
+ MaybeForeign = get_maybe_foreign_type_info(CI, OrigType),
+ Input = pragma_c_input(Name, OrigType, lval(Reg),
+ MaybeForeign),
input_descs_from_arg_info(CI, Args, Inputs1),
Inputs = [Input | Inputs1]
;
@@ -1315,7 +1321,7 @@
( var_is_not_singleton(MaybeName, Name) ->
ArgInfo = arg_info(N, _),
Reg = reg(r, N),
- MaybeForeign = get_maybe_foreign_type_name(CI, OrigType),
+ MaybeForeign = get_maybe_foreign_type_info(CI, OrigType),
Outputs = [pragma_c_output(Reg, OrigType, Name, MaybeForeign) |
Outputs0]
;
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.107
diff -u -b -r1.107 prog_data.m
--- compiler/prog_data.m 31 Mar 2004 08:52:24 -0000 1.107
+++ compiler/prog_data.m 12 May 2004 10:15:35 -0000
@@ -1037,10 +1037,25 @@
% type_defn/3 is defined above as a constructor for item/0
:- type type_defn
- ---> du_type(list(constructor), is_solver_type, maybe(unify_compare))
- ; eqv_type(type)
- ; abstract_type(is_solver_type)
- ; foreign_type(foreign_language_type, maybe(unify_compare)).
+ ---> du_type(
+ list(constructor),
+ is_solver_type,
+ maybe(unify_compare)
+ )
+ ; eqv_type(
+ type
+ )
+ ; abstract_type(
+ is_solver_type
+ )
+ ; foreign_type(
+ foreign_language_type,
+ maybe(unify_compare),
+ list(foreign_type_assertion)
+ ).
+
+:- type foreign_type_assertion
+ ---> can_pass_as_mercury_type.
:- type constructor
---> ctor(
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.65
diff -u -b -r1.65 prog_io_pragma.m
--- compiler/prog_io_pragma.m 23 Mar 2004 10:52:11 -0000 1.65
+++ compiler/prog_io_pragma.m 12 May 2004 10:15:36 -0000
@@ -35,8 +35,9 @@
(
% new syntax: `:- pragma foo(...).'
PragmaTerms = [SinglePragmaTerm0],
- get_maybe_equality_compare_preds(ModuleName, SinglePragmaTerm0,
- SinglePragmaTerm, UnifyCompareResult),
+ get_maybe_equality_compare_preds(ModuleName,
+ SinglePragmaTerm0, SinglePragmaTerm,
+ UnifyCompareResult),
SinglePragmaTerm = term__functor(term__atom(PragmaType),
PragmaArgs, _),
parse_pragma_type(ModuleName, PragmaType, PragmaArgs,
@@ -50,12 +51,13 @@
->
(
Item0 = type_defn(_, _, _, _, _),
- foreign_type(Type, _) =
+ foreign_type(Type, _, Assertions) =
Item0 ^ td_ctor_defn
->
Result = ok(Item0 ^ td_ctor_defn :=
foreign_type(Type,
- MaybeUserEqCompare))
+ MaybeUserEqCompare,
+ Assertions))
;
Result = error(
"unexpected `where equality/comparison is'",
@@ -102,7 +104,17 @@
parse_pragma_type(ModuleName, "foreign_type", PragmaTerms, ErrorTerm, VarSet,
Result) :-
- ( PragmaTerms = [LangTerm, MercuryTypeTerm, ForeignTypeTerm] ->
+ (
+ (
+ PragmaTerms = [LangTerm, MercuryTypeTerm,
+ ForeignTypeTerm],
+ MaybeAssertionTerm = no
+ ;
+ PragmaTerms = [LangTerm, MercuryTypeTerm,
+ ForeignTypeTerm, AssertionTerm],
+ MaybeAssertionTerm = yes(AssertionTerm)
+ )
+ ->
( parse_foreign_language(LangTerm, Language) ->
parse_foreign_language_type(ForeignTypeTerm, Language,
MaybeForeignType),
@@ -118,11 +130,28 @@
varset__coerce(VarSet, TVarSet),
MercuryArgs = list__map(term__coerce,
MercuryArgs0),
+ ( parse_maybe_foreign_type_assertions(
+ MaybeAssertionTerm, Assertions)
+ ->
Result = ok(type_defn(TVarSet,
MercuryTypeSymName,
MercuryArgs,
- foreign_type(ForeignType, no),
+ foreign_type(
+ ForeignType,
+ no,
+ Assertions),
true))
+ ; MaybeAssertionTerm =
+ yes(ErrorAssertionTerm)
+ ->
+ Result = error(
+ "invalid assertion in `:- pragma foreign_type' declaration",
+ ErrorAssertionTerm)
+ ;
+ error(
+ "parse_pragma_type: unexpected failure of " ++
+ "parse_maybe_foreign_type_assertion")
+ )
;
MaybeTypeDefnHead =
error(String, Term),
@@ -360,6 +389,34 @@
qualified(unqualified("System"), "UInt32"))).
parse_special_il_type_name("unsigned int64", il(value, "mscorlib",
qualified(unqualified("System"), "UInt64"))).
+
+:- pred parse_maybe_foreign_type_assertions(maybe(term)::in,
+ list(foreign_type_assertion)::out) is semidet.
+
+parse_maybe_foreign_type_assertions(no, []).
+parse_maybe_foreign_type_assertions(yes(Term), Assertions) :-
+ parse_foreign_type_assertions(Term, Assertions).
+
+:- pred parse_foreign_type_assertions(term::in,
+ list(foreign_type_assertion)::out) is semidet.
+
+parse_foreign_type_assertions(Term, Assertions) :-
+ ( Term = term__functor(term__atom("[]"), [], _) ->
+ Assertions = []
+ ;
+ Term = term__functor(term__atom("[|]"), [Head, Tail], _),
+ parse_foreign_type_assertion(Head, HeadAssertion),
+ parse_foreign_type_assertions(Tail, TailAssertions),
+ Assertions = [HeadAssertion | TailAssertions]
+ ).
+
+:- pred parse_foreign_type_assertion(term::in,
+ foreign_type_assertion::out) is semidet.
+
+parse_foreign_type_assertion(Term, Assertion) :-
+ Term = term__functor(term__atom(Constant), [], _),
+ Constant = "can_pass_as_mercury_type",
+ Assertion = can_pass_as_mercury_type.
% This predicate parses both c_header_code and foreign_decl pragmas.
:- pred parse_pragma_foreign_decl_pragma(module_name, string,
Index: compiler/recompilation.check.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.check.m,v
retrieving revision 1.6
diff -u -b -r1.6 recompilation.check.m
--- compiler/recompilation.check.m 19 Mar 2004 10:19:25 -0000 1.6
+++ compiler/recompilation.check.m 12 May 2004 10:15:37 -0000
@@ -1136,7 +1136,7 @@
TypeCtor, du_type(Ctors, _, _)) -->
list__foldl(check_functor_ambiguities(NeedQualifier, TypeCtor),
Ctors).
-check_type_defn_ambiguity_with_functor(_, _, foreign_type(_, _)) --> [].
+check_type_defn_ambiguity_with_functor(_, _, foreign_type(_, _, _)) --> [].
:- pred check_functor_ambiguities(need_qualifier::in, type_ctor::in,
constructor::in, recompilation_check_info::in,
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.7
diff -u -b -r1.7 recompilation.version.m
--- compiler/recompilation.version.m 1 Dec 2003 15:55:48 -0000 1.7
+++ compiler/recompilation.version.m 12 May 2004 10:15:38 -0000
@@ -284,7 +284,7 @@
{ NameItem = Item },
{ BodyItem = Item }
;
- { Body = foreign_type(_, _) },
+ { Body = foreign_type(_, _, _) },
{ NameItem = Item },
{ BodyItem = Item }
),
cvs server: Diffing compiler/notes
cvs server: Diffing debian
cvs server: Diffing deep_profiler
cvs server: Diffing deep_profiler/notes
cvs server: Diffing doc
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.292
diff -u -b -r1.292 reference_manual.texi
--- doc/reference_manual.texi 18 Mar 2004 03:42:09 -0000 1.292
+++ doc/reference_manual.texi 12 May 2004 10:15:54 -0000
@@ -5745,6 +5745,28 @@
@samp{pragma foreign_proc} clauses for all of the languages for which there
are @samp{foreign_type} declarations for the type.
+You can also associate assertions about the properties
+of the foreign type with the @samp{foreign_type} declaration,
+using the following syntax:
+
+ at example
+:- pragma foreign_type(@var{Lang}, @var{MercuryTypeName}, @var{ForeignTypeDescriptor}, [@var{ForeignTypeAssertion}, ...]).
+ at end example
+
+Currently, only one kind of assertion is supported:
+ at samp{can_pass_as_mercury_type}.
+This asserts that on the C backends, values of the given type
+can be passed to and from Mercury code without boxing,
+via simple casts, which is faster.
+This requires the type to be either an integer type or a pointer type,
+and requires its size to be the same as or less than the size of Mercury word.
+Since deciding whether a C type satisfies this condition
+requires knowledge of the Mercury implementation,
+and violations are very likely to result in
+the generated executable silently doing the wrong thing,
+we do not recommend the use of assertions
+unless you are an implementor of the Mercury system.
+
As with discriminated union types, programmers can specify the unification
@w{and/or} comparison predicates to use for values of the type using the
following syntax (@pxref{User-defined equality and comparison}):
@@ -5759,6 +5781,7 @@
written in a different language @var{Y} provided that @var{X} and @var{Y}
have compatible interface conventions. Support for this kind of
compatibility is described in the language specific information below.
+
@c -----------------------------------------------------------------------
@node Adding foreign declarations
cvs server: Diffing extras
cvs server: Diffing extras/aditi
cvs server: Diffing extras/cgi
cvs server: Diffing extras/complex_numbers
cvs server: Diffing extras/complex_numbers/samples
cvs server: Diffing extras/complex_numbers/tests
cvs server: Diffing extras/concurrency
cvs server: Diffing extras/curs
cvs server: Diffing extras/curs/samples
cvs server: Diffing extras/curses
cvs server: Diffing extras/curses/sample
cvs server: Diffing extras/dynamic_linking
cvs server: Diffing extras/error
cvs server: Diffing extras/graphics
cvs server: Diffing extras/graphics/mercury_opengl
cvs server: Diffing extras/graphics/mercury_tcltk
cvs server: Diffing extras/graphics/samples
cvs server: Diffing extras/graphics/samples/calc
cvs server: Diffing extras/graphics/samples/maze
cvs server: Diffing extras/graphics/samples/pent
cvs server: Diffing extras/lazy_evaluation
cvs server: Diffing extras/lex
cvs server: Diffing extras/lex/samples
cvs server: Diffing extras/lex/tests
cvs server: Diffing extras/logged_output
cvs server: Diffing extras/moose
cvs server: Diffing extras/moose/samples
cvs server: Diffing extras/moose/tests
cvs server: Diffing extras/morphine
cvs server: Diffing extras/morphine/non-regression-tests
cvs server: Diffing extras/morphine/scripts
cvs server: Diffing extras/morphine/source
cvs server: Diffing extras/odbc
cvs server: Diffing extras/posix
cvs server: Diffing extras/quickcheck
cvs server: Diffing extras/quickcheck/tutes
cvs server: Diffing extras/references
cvs server: Diffing extras/references/samples
cvs server: Diffing extras/references/tests
cvs server: Diffing extras/stream
cvs server: Diffing extras/trailed_update
cvs server: Diffing extras/trailed_update/samples
cvs server: Diffing extras/trailed_update/tests
cvs server: Diffing extras/xml
cvs server: Diffing extras/xml/samples
cvs server: Diffing java
cvs server: Diffing java/runtime
cvs server: Diffing library
cvs server: Diffing profiler
cvs server: Diffing robdd
cvs server: Diffing runtime
cvs server: Diffing runtime/GETOPT
cvs server: Diffing runtime/machdeps
cvs server: Diffing samples
cvs server: Diffing samples/c_interface
cvs server: Diffing samples/c_interface/c_calls_mercury
cvs server: Diffing samples/c_interface/cplusplus_calls_mercury
cvs server: Diffing samples/c_interface/mercury_calls_c
cvs server: Diffing samples/c_interface/mercury_calls_cplusplus
cvs server: Diffing samples/c_interface/mercury_calls_fortran
cvs server: Diffing samples/c_interface/simpler_c_calls_mercury
cvs server: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs server: Diffing samples/diff
cvs server: Diffing samples/muz
cvs server: Diffing samples/rot13
cvs server: Diffing samples/solutions
cvs server: Diffing samples/tests
cvs server: Diffing samples/tests/c_interface
cvs server: Diffing samples/tests/c_interface/c_calls_mercury
cvs server: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs server: Diffing samples/tests/c_interface/mercury_calls_c
cvs server: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs server: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs server: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs server: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs server: Diffing samples/tests/diff
cvs server: Diffing samples/tests/muz
cvs server: Diffing samples/tests/rot13
cvs server: Diffing samples/tests/solutions
cvs server: Diffing samples/tests/toplevel
cvs server: Diffing scripts
cvs server: Diffing tests
cvs server: Diffing tests/benchmarks
cvs server: Diffing tests/debugger
cvs server: Diffing tests/debugger/declarative
cvs server: Diffing tests/dppd
cvs server: Diffing tests/general
cvs server: Diffing tests/general/accumulator
cvs server: Diffing tests/general/string_format
cvs server: Diffing tests/general/structure_reuse
cvs server: Diffing tests/grade_subdirs
cvs server: Diffing tests/invalid
cvs server: Diffing tests/invalid/purity
cvs server: Diffing tests/misc_tests
cvs server: Diffing tests/mmc_make
cvs server: Diffing tests/mmc_make/lib
cvs server: Diffing tests/recompilation
cvs server: Diffing tests/tabling
cvs server: Diffing tests/term
cvs server: Diffing tests/valid
cvs server: Diffing tests/warnings
cvs server: Diffing tools
cvs server: Diffing trace
cvs server: Diffing util
cvs server: Diffing vim
cvs server: Diffing vim/after
cvs server: Diffing vim/ftplugin
cvs server: Diffing vim/syntax
cvs server: Diffing tests
cvs server: Diffing tests/hard_coded
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.230
diff -u -b -r1.230 Mmakefile
--- tests/hard_coded/Mmakefile 24 Mar 2004 00:39:35 -0000 1.230
+++ tests/hard_coded/Mmakefile 12 May 2004 10:16:07 -0000
@@ -251,12 +251,14 @@
endif
# Fact tables currently work only in the C grades.
+# The foreign_type_assertion test is currently meaningful only in C grades.
ifeq "$(filter il% java%,$(GRADE))" ""
- FACTT_PROGS= \
+ C_ONLY_PROGS= \
factt \
- factt_sort_test
+ factt_sort_test \
+ foreign_type_assertion
else
- FACTT_PROGS=
+ C_ONLY_PROGS=
endif
# XXX test_array2d does not work in at least asm_fast.gc.profdeep; the
@@ -434,7 +436,7 @@
$(BACKEND_PROGS) $(NONDET_C_PROGS) \
$(C_AND_GC_ONLY_PROGS) $(STATIC_LINK_PROGS) \
$(CHAR_REP_PROGS) $(BROKEN_FOR_PROFDEEP) \
- $(FACTT_PROGS) $(DOTNET_PROGS) $(JAVA_PROGS)
+ $(C_ONLY_PROGS) $(DOTNET_PROGS) $(JAVA_PROGS)
endif
# --split-c-files does not work in the hl* grades (e.g. hlc.gc),
Index: tests/hard_coded/foreign_type_assertion.exp
===================================================================
RCS file: tests/hard_coded/foreign_type_assertion.exp
diff -N tests/hard_coded/foreign_type_assertion.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_type_assertion.exp 12 May 2004 10:16:08 -0000
@@ -0,0 +1,2 @@
+east
+x: 2, y: 3
Index: tests/hard_coded/foreign_type_assertion.m
===================================================================
RCS file: tests/hard_coded/foreign_type_assertion.m
diff -N tests/hard_coded/foreign_type_assertion.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_type_assertion.m 12 May 2004 10:16:08 -0000
@@ -0,0 +1,134 @@
+% This tests the use of assertions on C foreign types.
+% (Assertions on types in other languages are not yet used.)
+
+:- module foreign_type_assertion.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+main(!IO) :-
+ D0 = north,
+ C0 = new_coord(1, 2),
+ update_dir(D0, D),
+ update_coord(C0, C),
+ write_dir(D, !IO),
+ write_coord(C, !IO).
+
+:- pragma foreign_decl(c, "
+typedef enum {
+ north,
+ east,
+ west,
+ south,
+} dirs;
+
+typedef struct {
+ int x, y;
+} coord;
+
+typedef coord *coord_ptr;
+").
+
+:- type dir.
+:- type coord.
+
+:- pragma foreign_type(c, dir, "dirs", [can_pass_as_mercury_type]).
+:- pragma foreign_type(c, coord, "coord_ptr", [can_pass_as_mercury_type]).
+
+:- func north = dir.
+
+:- pragma foreign_proc(c,
+ north = (E::out),
+ [will_not_call_mercury, promise_pure],
+"
+ E = north;
+").
+
+:- func new_coord(int, int) = coord.
+
+:- pragma foreign_proc(c,
+ new_coord(X::in, Y::in) = (C::out),
+ [will_not_call_mercury, promise_pure],
+"
+ C = MR_NEW(coord);
+ C->x = X;
+ C->y = Y;
+").
+
+:- pred update_dir(dir::in, dir::out) is det.
+
+:- pragma foreign_proc(c,
+ update_dir(X::in, Y::out),
+ [will_not_call_mercury, promise_pure],
+"
+ switch (X)
+ {
+ case north: Y = east;
+ break;
+
+ case east: Y = south;
+ break;
+
+ case south: Y = west;
+ break;
+
+ case west: Y = north;
+ break;
+
+ default: MR_fatal_error(""update_dir: bad dir"");
+ break;
+ }
+").
+
+:- pred update_coord(coord::in, coord::out) is det.
+
+:- pragma foreign_proc(c,
+ update_coord(X::in, Y::out),
+ [will_not_call_mercury, promise_pure],
+"
+ Y = MR_NEW(coord);
+ Y->x = X->x + 1;
+ Y->y = X->y + 1;
+").
+
+:- pred write_dir(dir::in, io::di, io::uo) is det.
+
+:- pragma foreign_proc(c,
+ write_dir(X::in, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ switch (X)
+ {
+ case north: printf(""north\\n"");
+ break;
+
+ case east: printf(""east\\n"");
+ break;
+
+ case south: printf(""south\\n"");
+ break;
+
+ case west: printf(""west\\n"");
+ break;
+
+ default: MR_fatal_error(""write_dir: bad dir"");
+ break;
+ }
+
+ S = S0;
+").
+
+:- pred write_coord(coord::in, io::di, io::uo) is det.
+
+:- pragma foreign_proc(c,
+ write_coord(X::in, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ printf(""x: %d, y: %d\\n"", X->x, X->y);
+ S = S0;
+").
cvs server: Diffing tests/hard_coded/exceptions
cvs server: Diffing tests/hard_coded/purity
cvs server: Diffing tests/hard_coded/sub-modules
cvs server: Diffing tests/hard_coded/typeclasses
--------------------------------------------------------------------------
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