[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