[m-rev.] for review: write out user sharing annotations to .opt files
Peter Wang
novalazy at gmail.com
Mon Mar 3 17:02:02 AEDT 2008
This would cause a mutual dependency between mercury_to_mercury.m and
prog_data.m. Maybe attributes_to_strings should be in
mercury_to_mercury.m?
Estimated hours taken: 2.5
Branches: main
Write out user-specified structure sharing annotations
(no_sharing/unknown_sharing/sharing) on foreign_procs, e.g. when making `.opt'
files.
compiler/prog_data.m:
Make `attributes_to_strings' take into account user sharing
annotations.
compiler/mercury_to_mercury.m:
Conform to the change.
tests/valid/Mercury.options:
tests/valid/Mmakefile:
tests/valid/intermod_user_sharing.m:
tests/valid/intermod_user_sharing_2.m:
Add a test case.
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.328
diff -u -r1.328 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 27 Feb 2008 07:23:09 -0000 1.328
+++ compiler/mercury_to_mercury.m 3 Mar 2008 05:50:08 -0000
@@ -670,8 +670,12 @@
;
Pragma = pragma_import(Pred, PredOrFunc, ModeList, Attributes,
C_Function),
+ % XXX the varset is only used for writing some `sharing' annotations.
+ % It's unlikely anyone would write `sharing' annotations with `pragma
+ % import' (which is deprecated) so just make up a varset.
+ ProgVarset = varset.init,
mercury_format_pragma_import(Pred, PredOrFunc, ModeList,
- Attributes, C_Function, !IO)
+ Attributes, ProgVarset, C_Function, !IO)
;
Pragma = pragma_foreign_export(Lang, Pred, PredOrFunc, ModeList,
ExportName),
@@ -3454,7 +3458,7 @@
(func(pragma_var(_, _, ImportMode, _)) = ImportMode), Vars0),
mercury_format_pragma_import(PredName, PredOrFunc, ImportModes,
- Attributes, C_Function, !U)
+ Attributes, ProgVarset, C_Function, !U)
;
PragmaCode = fc_impl_ordinary(_, _),
mercury_format_pragma_foreign_code_2(Attributes, PredName,
@@ -3505,7 +3509,7 @@
add_string(")", !U)
),
add_string(", ", !U),
- mercury_format_pragma_foreign_attributes(Attributes, !U),
+ mercury_format_pragma_foreign_attributes(Attributes, ProgVarset, !U),
add_string(", ", !U),
(
PragmaCode = fc_impl_ordinary(C_Code, _),
@@ -3785,13 +3789,13 @@
%-----------------------------------------------------------------------------%
:- pred mercury_format_pragma_import(sym_name::in, pred_or_func::in,
- list(mer_mode)::in, pragma_foreign_proc_attributes::in, string::in,
- U::di, U::uo) is det <= output(U).
+ list(mer_mode)::in, pragma_foreign_proc_attributes::in, prog_varset::in,
+ string::in, U::di, U::uo) is det <= output(U).
mercury_format_pragma_import(Name, PredOrFunc, ModeList, Attributes,
- C_Function, !U) :-
- varset.init(Varset), % the varset isn't really used.
- InstInfo = simple_inst_info(Varset),
+ ProgVarset, C_Function, !U) :-
+ varset.init(InstVarset), % the varset isn't really used.
+ InstInfo = simple_inst_info(InstVarset),
add_string(":- pragma import(", !U),
mercury_format_sym_name(Name, !U),
(
@@ -3808,7 +3812,7 @@
add_string(")", !U)
),
add_string(", ", !U),
- mercury_format_pragma_foreign_attributes(Attributes, !U),
+ mercury_format_pragma_foreign_attributes(Attributes, ProgVarset, !U),
add_string(", """, !U),
add_string(C_Function, !U),
add_string(""").\n", !U).
@@ -3984,12 +3988,13 @@
%-----------------------------------------------------------------------------%
:- pred mercury_format_pragma_foreign_attributes(
- pragma_foreign_proc_attributes::in, U::di, U::uo) is det <= output(U).
+ pragma_foreign_proc_attributes::in, prog_varset::in, U::di, U::uo) is det
+ <= output(U).
-mercury_format_pragma_foreign_attributes(Attributes, !U) :-
+mercury_format_pragma_foreign_attributes(Attributes, VarSet, !U) :-
% This is one case where it is a bad idea to use field accessors.
add_string("[", !U),
- add_list(attributes_to_strings(Attributes), ", ", add_string, !U),
+ add_list(attributes_to_strings(Attributes, VarSet), ", ", add_string, !U),
add_string("]", !U).
%-----------------------------------------------------------------------------%
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.208
diff -u -r1.208 prog_data.m
--- compiler/prog_data.m 27 Feb 2008 09:46:06 -0000 1.208
+++ compiler/prog_data.m 3 Mar 2008 05:50:08 -0000
@@ -948,7 +948,8 @@
% attributes have one). In particular, the foreign language attribute needs
% to be handled separately as it belongs at the start of the pragma.
%
-:- func attributes_to_strings(pragma_foreign_proc_attributes) = list(string).
+:- func attributes_to_strings(pragma_foreign_proc_attributes, prog_varset)
+ = list(string).
%-----------------------------------------------------------------------------%
%
@@ -1723,9 +1724,12 @@
:- implementation.
:- import_module libs.compiler_util.
+:- import_module parse_tree.mercury_to_mercury.
:- import_module string.
+%-----------------------------------------------------------------------------%
+
eval_method_to_table_type(EvalMethod) = TableTypeStr :-
(
EvalMethod = eval_normal,
@@ -1848,12 +1852,12 @@
set_may_duplicate(MayDuplicate, Attrs0, Attrs) :-
Attrs = Attrs0 ^ attr_may_duplicate := MayDuplicate.
-attributes_to_strings(Attrs) = StringList :-
+attributes_to_strings(Attrs, VarSet) = StringList :-
% We ignore Lang because it isn't an attribute that you can put
% in the attribute list -- the foreign language specifier string
% is at the start of the pragma.
Attrs = attributes(_Lang, MayCallMercury, ThreadSafe, TabledForIO,
- Purity, Terminates, _UserSharing, Exceptions, _LegacyBehaviour,
+ Purity, Terminates, UserSharing, Exceptions, _LegacyBehaviour,
OrdinaryDespiteDetism, MayModifyTrail, MayCallMM_Tabled,
BoxPolicy, AffectsLiveness, AllocatesMemory, RegistersRoots,
MaybeMayDuplicate, ExtraAttributes),
@@ -1908,6 +1912,14 @@
TerminatesStrList = []
),
(
+ UserSharing = user_sharing(Sharing, MaybeTypes),
+ String = user_annotated_sharing_to_string(VarSet, Sharing, MaybeTypes),
+ UserSharingStrList = [String]
+ ;
+ UserSharing = no_user_annotated_sharing,
+ UserSharingStrList = []
+ ),
+ (
Exceptions = proc_will_not_throw_exception,
ExceptionsStrList = ["will_not_throw_exception"]
;
@@ -1995,13 +2007,75 @@
MayDuplicateStrList = []
),
StringList = [MayCallMercuryStr, ThreadSafeStr, TabledForIOStr |
- PurityStrList] ++ TerminatesStrList ++ ExceptionsStrList ++
+ PurityStrList] ++ TerminatesStrList ++ UserSharingStrList ++
+ ExceptionsStrList ++
OrdinaryDespiteDetismStrList ++ MayModifyTrailStrList ++
MayCallMM_TabledStrList ++ BoxPolicyStrList ++
AffectsLivenessStrList ++ AllocatesMemoryStrList ++
RegistersRootsStrList ++ MayDuplicateStrList ++
list.map(extra_attribute_to_string, ExtraAttributes).
+:- func user_annotated_sharing_to_string(prog_varset, structure_sharing_domain,
+ maybe(user_sharing_type_information)) = string.
+
+user_annotated_sharing_to_string(VarSet, Sharing, MaybeTypes) = String :-
+ (
+ Sharing = structure_sharing_bottom,
+ String = "no_sharing"
+ ;
+ Sharing = structure_sharing_top(_),
+ String = "unknown_sharing"
+ ;
+ Sharing = structure_sharing_real(SharingPairs),
+ (
+ MaybeTypes = yes(user_type_info(Types, TVarSet)),
+ TypeStrs = list.map(mercury_type_to_string(TVarSet, no), Types),
+ TypeListStr = string.join_list(", ", TypeStrs),
+ MaybeTypesStr = "yes(" ++ TypeListStr ++ ")"
+ ;
+ MaybeTypes = no,
+ MaybeTypesStr = "no",
+ TVarSet = varset.init
+ ),
+ SharingPairStrs = list.map(sharing_pair_to_string(VarSet, TVarSet),
+ SharingPairs),
+ SharingPairListStr = string.join_list(", ", SharingPairStrs),
+ String = string.append_list(
+ ["sharing(", MaybeTypesStr, ", [", SharingPairListStr, "])"])
+ ).
+
+:- func sharing_pair_to_string(prog_varset, tvarset, structure_sharing_pair)
+ = string.
+
+sharing_pair_to_string(VarSet, TVarSet, DataA - DataB) = Str :-
+ DataA = selected_cel(VarA, SelectorA),
+ DataB = selected_cel(VarB, SelectorB),
+ VarStrA = mercury_var_to_string(VarSet, no, VarA),
+ VarStrB = mercury_var_to_string(VarSet, no, VarB),
+ SelectorStrA = selector_to_string(TVarSet, SelectorA),
+ SelectorStrB = selector_to_string(TVarSet, SelectorB),
+ StrA = "cel(" ++ VarStrA ++ ", [" ++ SelectorStrA ++ "])",
+ StrB = "cel(" ++ VarStrB ++ ", [" ++ SelectorStrB ++ "])",
+ Str = StrA ++ " - " ++ StrB.
+
+:- func selector_to_string(tvarset, selector) = string.
+
+selector_to_string(TVarSet, Selector) = String :-
+ UnitStrs = list.map(unit_selector_to_string(TVarSet), Selector),
+ String = string.join_list(", ", UnitStrs).
+
+:- func unit_selector_to_string(tvarset, unit_selector) = string.
+
+unit_selector_to_string(TVarSet, UnitSelector) = String :-
+ (
+ UnitSelector = typesel(Type),
+ String = mercury_type_to_string(TVarSet, no, Type)
+ ;
+ UnitSelector = termsel(_, _),
+ unexpected(this_file,
+ "unit_selector_to_string: termsel in user-annotated sharing")
+ ).
+
add_extra_attribute(NewAttribute, Attributes0,
Attributes0 ^ attr_extra_attributes :=
[NewAttribute | Attributes0 ^ attr_extra_attributes]).
Index: tests/valid/Mercury.options
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/valid/Mercury.options,v
retrieving revision 1.45
diff -u -r1.45 Mercury.options
--- tests/valid/Mercury.options 28 Feb 2008 00:08:34 -0000 1.45
+++ tests/valid/Mercury.options 3 Mar 2008 05:50:10 -0000
@@ -79,6 +79,8 @@
MCFLAGS-intermod_user_equality = --intermodule-optimization
MCFLAGS-intermod_user_equality_nested2 = --intermodule-optimization
MCFLAGS-intermod_user_equality_nested = --intermodule-optimization
+MCFLAGS-intermod_user_sharing = --intermodule-optimization
+MCFLAGS-intermod_user_sharing_2 = --intermodule-optimization
MCFLAGS-lambda_inference = --infer-all
MCFLAGS-livevals_seq = -O5 --opt-space
MCFLAGS-loop_inv_bug = --common-struct --loop-invariants
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.207
diff -u -r1.207 Mmakefile
--- tests/valid/Mmakefile 28 Feb 2008 00:08:34 -0000 1.207
+++ tests/valid/Mmakefile 3 Mar 2008 05:50:10 -0000
@@ -135,6 +135,7 @@
intermod_typeclass \
intermod_user_equality \
intermod_user_equality_nested \
+ intermod_user_sharing \
lambda_inference\
lambda_instmap_bug \
lambda_output \
Index: tests/valid/intermod_user_sharing.m
===================================================================
RCS file: tests/valid/intermod_user_sharing.m
diff -N tests/valid/intermod_user_sharing.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/valid/intermod_user_sharing.m 3 Mar 2008 05:50:10 -0000
@@ -0,0 +1,29 @@
+% Test that we can write out and read back in `no_sharing', `unknown_sharing'
+% and `sharing' annotations on foreign_procs.
+
+:- module intermod_user_sharing.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module intermod_user_sharing_2.
+:- import_module io.
+
+%-----------------------------------------------------------------------------%
+
+main(!IO) :-
+ p_no_sharing(!IO),
+ p_unknown_sharing("bar", Bar),
+ io.write(Bar, !IO),
+ p_sharing(1, "foo", Array),
+ io.write(Array, !IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=8 sw=4 et wm=0 tw=0
Index: tests/valid/intermod_user_sharing_2.m
===================================================================
RCS file: tests/valid/intermod_user_sharing_2.m
diff -N tests/valid/intermod_user_sharing_2.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/valid/intermod_user_sharing_2.m 3 Mar 2008 05:50:10 -0000
@@ -0,0 +1,45 @@
+:- module intermod_user_sharing_2.
+:- interface.
+
+:- import_module io.
+
+%-----------------------------------------------------------------------------%
+
+:- type myarray(T).
+
+:- pred p_no_sharing(io::di, io::uo) is det.
+:- pred p_unknown_sharing(T::in, T::out) is det.
+:- pred p_sharing(int::in, T::in, myarray(T)::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- pragma foreign_type("C", myarray(T), "MR_Word").
+
+:- pragma foreign_proc("C",
+ p_no_sharing(IO0::di, IO::uo),
+ [promise_pure, no_sharing],
+"
+ IO = IO0;
+").
+
+:- pragma foreign_proc("C",
+ p_unknown_sharing(T0::in, T::out),
+ [promise_pure, unknown_sharing],
+"
+ T = T0;
+").
+
+:- pragma foreign_proc("C",
+ p_sharing(_Size::in, _Item::in, Array::uo),
+ [promise_pure,
+ sharing(yes(int, T, myarray(T)), [cel(Item, []) - cel(Array, [T])])],
+"
+ /* dummy */
+ Array = 0;
+").
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=8 sw=4 et wm=0 tw=0
--------------------------------------------------------------------------
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