[m-rev.] for review: write out user sharing annotations to .opt files
Peter Wang
novalazy at gmail.com
Tue Mar 4 11:35:24 AEDT 2008
On 2008-03-03, Julien Fischer <juliensf at csse.unimelb.edu.au> wrote:
>
> On Mon, 3 Mar 2008, Peter Wang wrote:
>
>> 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?
>
> Based on a quick grep through the compiler directory, mercury_to_mercury
> seems to be the only place that calls it anyway, so move it there.
> (It should be renamed to something like
> foreign_code_attributes_to_strings as there are few other declarations
> that have attributes, e.g. pragma foreign_{decl, type, export_enum}, mutable.)
It turns out `attributes_to_strings' was in prog_data.m to avoid
forgetting to update it if a new field was added to
`pragma_foreign_proc_attributes', which is private to that module.
I have moved it anyway but added a comment. Interdiff follows.
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:
Move `attributes_to_strings' to mercury_to_mercury.m and rename it to
less ambiguous `foreign_proc_attributes_to_strings'. This is to avoid
a circular dependency.
Add a comment that adding a field to `pragma_foreign_proc_attributes'
requires updating `foreign_proc_attributes_to_strings'.
compiler/mercury_to_mercury.m:
Make `foreign_proc_attributes_to_strings' take into account user
sharing annotations.
tests/valid/Mercury.options:
tests/valid/Mmakefile:
tests/valid/intermod_user_sharing.m:
tests/valid/intermod_user_sharing_2.m:
Add a test case.
diff -u compiler/mercury_to_mercury.m compiler/mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 3 Mar 2008 05:50:08 -0000
+++ compiler/mercury_to_mercury.m 4 Mar 2008 00:25:31 -0000
@@ -3992,11 +3992,260 @@
<= output(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, VarSet), ", ", add_string, !U),
+ add_list(foreign_attributes_to_strings(Attributes, VarSet), ", ",
+ add_string, !U),
add_string("]", !U).
+ % Convert the foreign code attributes to their source code representations
+ % suitable for placing in the attributes list of the pragma (not all
+ % attributes have one). In particular, the foreign language attribute needs
+ % to be handled separately as it belongs at the start of the pragma.
+ %
+:- func foreign_attributes_to_strings(pragma_foreign_proc_attributes,
+ prog_varset) = list(string).
+
+foreign_attributes_to_strings(Attrs, VarSet) = StringList :-
+ MayCallMercury = get_may_call_mercury(Attrs),
+ ThreadSafe = get_thread_safe(Attrs),
+ TabledForIO = get_tabled_for_io(Attrs),
+ Purity = get_purity(Attrs),
+ Terminates = get_terminates(Attrs),
+ UserSharing = get_user_annotated_sharing(Attrs),
+ Exceptions = get_may_throw_exception(Attrs),
+ OrdinaryDespiteDetism = get_ordinary_despite_detism(Attrs),
+ MayModifyTrail = get_may_modify_trail(Attrs),
+ MayCallMM_Tabled = get_may_call_mm_tabled(Attrs),
+ BoxPolicy = get_box_policy(Attrs),
+ AffectsLiveness = get_affects_liveness(Attrs),
+ AllocatesMemory = get_allocates_memory(Attrs),
+ RegistersRoots = get_registers_roots(Attrs),
+ MaybeMayDuplicate = get_may_duplicate(Attrs),
+ ExtraAttributes = get_extra_attributes(Attrs),
+ (
+ MayCallMercury = proc_may_call_mercury,
+ MayCallMercuryStr = "may_call_mercury"
+ ;
+ MayCallMercury = proc_will_not_call_mercury,
+ MayCallMercuryStr = "will_not_call_mercury"
+ ),
+ (
+ ThreadSafe = proc_not_thread_safe,
+ ThreadSafeStr = "not_thread_safe"
+ ;
+ ThreadSafe = proc_thread_safe,
+ ThreadSafeStr = "thread_safe"
+ ;
+ ThreadSafe = proc_maybe_thread_safe,
+ ThreadSafeStr = "maybe_thread_safe"
+ ),
+ (
+ TabledForIO = proc_tabled_for_io,
+ TabledForIOStr = "tabled_for_io"
+ ;
+ TabledForIO = proc_tabled_for_io_unitize,
+ TabledForIOStr = "tabled_for_io_unitize"
+ ;
+ TabledForIO = proc_tabled_for_descendant_io,
+ TabledForIOStr = "tabled_for_descendant_io"
+ ;
+ TabledForIO = proc_not_tabled_for_io,
+ TabledForIOStr = "not_tabled_for_io"
+ ),
+ (
+ Purity = purity_pure,
+ PurityStrList = ["promise_pure"]
+ ;
+ Purity = purity_semipure,
+ PurityStrList = ["promise_semipure"]
+ ;
+ Purity = purity_impure,
+ PurityStrList = []
+ ),
+ (
+ Terminates = proc_terminates,
+ TerminatesStrList = ["terminates"]
+ ;
+ Terminates = proc_does_not_terminate,
+ TerminatesStrList = ["does_not_terminate"]
+ ;
+ Terminates = depends_on_mercury_calls,
+ 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"]
+ ;
+ Exceptions = default_exception_behaviour,
+ ExceptionsStrList = []
+ ),
+ (
+ OrdinaryDespiteDetism = yes,
+ OrdinaryDespiteDetismStrList = ["ordinary_despite_detism"]
+ ;
+ OrdinaryDespiteDetism = no,
+ OrdinaryDespiteDetismStrList = []
+ ),
+ (
+ MayModifyTrail = proc_may_modify_trail,
+ MayModifyTrailStrList = ["may_modify_trail"]
+ ;
+ MayModifyTrail = proc_will_not_modify_trail,
+ MayModifyTrailStrList = ["will_not_modify_trail"]
+ ),
+ (
+ MayCallMM_Tabled = may_call_mm_tabled,
+ MayCallMM_TabledStrList = ["may_call_mm_tabled"]
+ ;
+ MayCallMM_Tabled = will_not_call_mm_tabled,
+ MayCallMM_TabledStrList =["will_not_call_mm_tabled"]
+ ;
+ MayCallMM_Tabled = default_calls_mm_tabled,
+ MayCallMM_TabledStrList = []
+ ),
+ (
+ BoxPolicy = native_if_possible,
+ BoxPolicyStrList = []
+ ;
+ BoxPolicy = always_boxed,
+ BoxPolicyStrList = ["always_boxed"]
+ ),
+ (
+ AffectsLiveness = proc_affects_liveness,
+ AffectsLivenessStrList = ["affects_liveness"]
+ ;
+ AffectsLiveness = proc_does_not_affect_liveness,
+ AffectsLivenessStrList = ["doesnt_affect_liveness"]
+ ;
+ AffectsLiveness = proc_default_affects_liveness,
+ AffectsLivenessStrList = []
+ ),
+ (
+ AllocatesMemory = proc_does_not_allocate_memory,
+ AllocatesMemoryStrList =["doesnt_allocate_memory"]
+ ;
+ AllocatesMemory = proc_allocates_bounded_memory,
+ AllocatesMemoryStrList = ["allocates_bounded_memory"]
+ ;
+ AllocatesMemory = proc_allocates_unbounded_memory,
+ AllocatesMemoryStrList = ["allocates_unbounded_memory"]
+ ;
+ AllocatesMemory = proc_default_allocates_memory,
+ AllocatesMemoryStrList = []
+ ),
+ (
+ RegistersRoots = proc_registers_roots,
+ RegistersRootsStrList = ["registers_roots"]
+ ;
+ RegistersRoots = proc_does_not_register_roots,
+ RegistersRootsStrList =["doesnt_register_roots"]
+ ;
+ RegistersRoots = proc_does_not_have_roots,
+ RegistersRootsStrList = ["doesnt_have_roots"]
+ ;
+ RegistersRoots = proc_default_registers_roots,
+ RegistersRootsStrList = []
+ ),
+ (
+ MaybeMayDuplicate = yes(MayDuplicate),
+ (
+ MayDuplicate = proc_may_duplicate,
+ MayDuplicateStrList = ["may_duplicate"]
+ ;
+ MayDuplicate = proc_may_not_duplicate,
+ MayDuplicateStrList = ["may_not_duplicate"]
+ )
+ ;
+ MaybeMayDuplicate = no,
+ MayDuplicateStrList = []
+ ),
+ StringList = [MayCallMercuryStr, ThreadSafeStr, TabledForIOStr |
+ 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")
+ ).
+
+:- func extra_attribute_to_string(pragma_foreign_proc_extra_attribute)
+ = string.
+
+extra_attribute_to_string(refers_to_llds_stack) = "refers_to_llds_stack".
+extra_attribute_to_string(backend(low_level_backend)) = "low_level_backend".
+extra_attribute_to_string(backend(high_level_backend)) = "high_level_backend".
+extra_attribute_to_string(max_stack_size(Size)) =
+ "max_stack_size(" ++ string.int_to_string(Size) ++ ")".
+
%-----------------------------------------------------------------------------%
% Write a term to standard output.
diff -u compiler/prog_data.m compiler/prog_data.m
--- compiler/prog_data.m 3 Mar 2008 05:50:08 -0000
+++ compiler/prog_data.m 4 Mar 2008 00:25:32 -0000
@@ -943,14 +943,6 @@
:- type pragma_foreign_proc_extra_attributes ==
list(pragma_foreign_proc_extra_attribute).
- % Convert the foreign code attributes to their source code representations
- % suitable for placing in the attributes list of the pragma (not all
- % 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, prog_varset)
- = list(string).
-
%-----------------------------------------------------------------------------%
%
% Goals
@@ -1724,7 +1716,6 @@
:- implementation.
:- import_module libs.compiler_util.
-:- import_module parse_tree.mercury_to_mercury.
:- import_module string.
@@ -1763,6 +1754,9 @@
% Some more stuff for the foreign language interface
%
+ % If you add an attribute you may need to modify
+ % `foreign_attributes_to_strings'.
+ %
:- type pragma_foreign_proc_attributes
---> attributes(
attr_foreign_language :: foreign_language,
@@ -1852,243 +1846,10 @@
set_may_duplicate(MayDuplicate, Attrs0, Attrs) :-
Attrs = Attrs0 ^ attr_may_duplicate := MayDuplicate.
-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,
- OrdinaryDespiteDetism, MayModifyTrail, MayCallMM_Tabled,
- BoxPolicy, AffectsLiveness, AllocatesMemory, RegistersRoots,
- MaybeMayDuplicate, ExtraAttributes),
- (
- MayCallMercury = proc_may_call_mercury,
- MayCallMercuryStr = "may_call_mercury"
- ;
- MayCallMercury = proc_will_not_call_mercury,
- MayCallMercuryStr = "will_not_call_mercury"
- ),
- (
- ThreadSafe = proc_not_thread_safe,
- ThreadSafeStr = "not_thread_safe"
- ;
- ThreadSafe = proc_thread_safe,
- ThreadSafeStr = "thread_safe"
- ;
- ThreadSafe = proc_maybe_thread_safe,
- ThreadSafeStr = "maybe_thread_safe"
- ),
- (
- TabledForIO = proc_tabled_for_io,
- TabledForIOStr = "tabled_for_io"
- ;
- TabledForIO = proc_tabled_for_io_unitize,
- TabledForIOStr = "tabled_for_io_unitize"
- ;
- TabledForIO = proc_tabled_for_descendant_io,
- TabledForIOStr = "tabled_for_descendant_io"
- ;
- TabledForIO = proc_not_tabled_for_io,
- TabledForIOStr = "not_tabled_for_io"
- ),
- (
- Purity = purity_pure,
- PurityStrList = ["promise_pure"]
- ;
- Purity = purity_semipure,
- PurityStrList = ["promise_semipure"]
- ;
- Purity = purity_impure,
- PurityStrList = []
- ),
- (
- Terminates = proc_terminates,
- TerminatesStrList = ["terminates"]
- ;
- Terminates = proc_does_not_terminate,
- TerminatesStrList = ["does_not_terminate"]
- ;
- Terminates = depends_on_mercury_calls,
- 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"]
- ;
- Exceptions = default_exception_behaviour,
- ExceptionsStrList = []
- ),
- (
- OrdinaryDespiteDetism = yes,
- OrdinaryDespiteDetismStrList = ["ordinary_despite_detism"]
- ;
- OrdinaryDespiteDetism = no,
- OrdinaryDespiteDetismStrList = []
- ),
- (
- MayModifyTrail = proc_may_modify_trail,
- MayModifyTrailStrList = ["may_modify_trail"]
- ;
- MayModifyTrail = proc_will_not_modify_trail,
- MayModifyTrailStrList = ["will_not_modify_trail"]
- ),
- (
- MayCallMM_Tabled = may_call_mm_tabled,
- MayCallMM_TabledStrList = ["may_call_mm_tabled"]
- ;
- MayCallMM_Tabled = will_not_call_mm_tabled,
- MayCallMM_TabledStrList =["will_not_call_mm_tabled"]
- ;
- MayCallMM_Tabled = default_calls_mm_tabled,
- MayCallMM_TabledStrList = []
- ),
- (
- BoxPolicy = native_if_possible,
- BoxPolicyStrList = []
- ;
- BoxPolicy = always_boxed,
- BoxPolicyStrList = ["always_boxed"]
- ),
- (
- AffectsLiveness = proc_affects_liveness,
- AffectsLivenessStrList = ["affects_liveness"]
- ;
- AffectsLiveness = proc_does_not_affect_liveness,
- AffectsLivenessStrList = ["doesnt_affect_liveness"]
- ;
- AffectsLiveness = proc_default_affects_liveness,
- AffectsLivenessStrList = []
- ),
- (
- AllocatesMemory = proc_does_not_allocate_memory,
- AllocatesMemoryStrList =["doesnt_allocate_memory"]
- ;
- AllocatesMemory = proc_allocates_bounded_memory,
- AllocatesMemoryStrList = ["allocates_bounded_memory"]
- ;
- AllocatesMemory = proc_allocates_unbounded_memory,
- AllocatesMemoryStrList = ["allocates_unbounded_memory"]
- ;
- AllocatesMemory = proc_default_allocates_memory,
- AllocatesMemoryStrList = []
- ),
- (
- RegistersRoots = proc_registers_roots,
- RegistersRootsStrList = ["registers_roots"]
- ;
- RegistersRoots = proc_does_not_register_roots,
- RegistersRootsStrList =["doesnt_register_roots"]
- ;
- RegistersRoots = proc_does_not_have_roots,
- RegistersRootsStrList = ["doesnt_have_roots"]
- ;
- RegistersRoots = proc_default_registers_roots,
- RegistersRootsStrList = []
- ),
- (
- MaybeMayDuplicate = yes(MayDuplicate),
- (
- MayDuplicate = proc_may_duplicate,
- MayDuplicateStrList = ["may_duplicate"]
- ;
- MayDuplicate = proc_may_not_duplicate,
- MayDuplicateStrList = ["may_not_duplicate"]
- )
- ;
- MaybeMayDuplicate = no,
- MayDuplicateStrList = []
- ),
- StringList = [MayCallMercuryStr, ThreadSafeStr, TabledForIOStr |
- 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]).
-:- func extra_attribute_to_string(pragma_foreign_proc_extra_attribute)
- = string.
-
-extra_attribute_to_string(refers_to_llds_stack) = "refers_to_llds_stack".
-extra_attribute_to_string(backend(low_level_backend)) = "low_level_backend".
-extra_attribute_to_string(backend(high_level_backend)) = "high_level_backend".
-extra_attribute_to_string(max_stack_size(Size)) =
- "max_stack_size(" ++ string.int_to_string(Size) ++ ")".
-
%-----------------------------------------------------------------------------%
%
% Renaming
--------------------------------------------------------------------------
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