[m-rev.] for review: [CTGC] user annotated sharing
Nancy Mazur
Nancy.Mazur at cs.kuleuven.ac.be
Tue Jun 27 19:19:10 AEST 2006
Hi,
anybody in for reviewing this bit of code?
Nancy
===================================================================
Estimated hours taken: 30
Branches: main
Add the possibility of annotating foreign code with sharing information.
The sharing information is part of the foreign_proc pragma's, and must be
of the following format:
no_sharing % meaning that the procedure does not
% create any sharing.
unknown_sharing % meaning that the procedure creates any
% possible sharing;
sharing(MaybeTypeInformation, SharingList)
% meaning that the procedure creates at most
% the listed sharing.
where
MaybeTypes =
yes(Types)
no
where Types corresponds to the type-signature of the foreign proc (i.e. they
must be unifiable). The types are only needed when the typeselectors used in
specifying the sharing make use of type variables.
and
SharingList = list of SharingPair
and
SharingPair = cel(Var1, Typeselectors1) - cel(Var2, Typeselectors2)
where
Var1, Var2 correspond to head variables from the foreign proc;
Typeselectors1, Typeselectors2 correspond to a list of typeselectors,
i.e., a list of types possibly in terms of the types given in
MaybeTypes.
Example:
:- pred array.init_2(int::in, T::in, array(T)::array_uo) is det.
:- pragma foreign_proc("C",
array.init_2(Size::in, Item::in, Array::array_uo),
[will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
sharing(yes(int, T, array(T)), [cel(Item,[]) - cel(Array,[T])])],
"
ML_alloc_marray(Array, Size + 1, MR_PROC_LABEL);
ML_init_marray(Array, Size, Item);
").
The meaning: a call init_2(Size, Item, Array) may create
sharing between Item, and any terms of Array with the type T (i.e. the elements
of the array).
compiler/add_pragma.m:
compiler/prog_ctgc.m:
compiler/prog_io_pragma.m:
Parsing/Renaming routines for the user annotated sharing.
compiler/ctgc.util.m:
BUGFIX. The definition of "get_type_substitution" was actually doing
the wrong thing, as it was creating a substitution with which to
rename two type-lists "away" from each other... while the analysis
needs the substitution resulting from unifying the type-lists.
compiler/module_qual.m:
Module qualify the types that are part of the sharing declaration.
compiler/prog_data.m:
Types for recording user annotated sharing.
Change the definition of the public representation for
structure sharing.
compiler/structure_reuse.direct.detect_garbage.m:
compiler/structure_reuse.indirect.m:
compiler/structure_sharing.analysis.m:
compiler/structure_sharing.domain.m:
Use foreign_proc sharing information when computing the overall
sharing.
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.35
diff -u -d -r1.35 add_pragma.m
--- compiler/add_pragma.m 15 Jun 2006 19:36:57 -0000 1.35
+++ compiler/add_pragma.m 27 Jun 2006 08:28:49 -0000
@@ -1574,9 +1574,9 @@
pred_info_get_arg_types(!.PredInfo, ArgTypes),
pred_info_get_purity(!.PredInfo, Purity),
clauses_info_add_pragma_foreign_proc(Purity, Attributes,
- PredId, ProcId, ProgVarSet, PVars, ArgTypes, PragmaImpl,
- Context, PredOrFunc, PredName, Arity, Clauses0, Clauses,
- !ModuleInfo, !IO),
+ PredId, ProcId, ProgVarSet, PVars, ArgTypes,
+ PragmaImpl, Context, PredOrFunc, PredName, Arity,
+ Clauses0, Clauses, !ModuleInfo, !IO),
pred_info_set_clauses_info(Clauses, !PredInfo),
pred_info_update_goal_type(pragmas, !PredInfo),
map.det_update(Preds0, PredId, !.PredInfo, Preds),
@@ -2362,14 +2362,14 @@
%
:- pred clauses_info_add_pragma_foreign_proc(purity::in,
pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
- prog_varset::in, list(pragma_var)::in, list(mer_type)::in,
+ prog_varset::in, list(pragma_var)::in, list(mer_type)::in,
pragma_foreign_code_impl::in, prog_context::in, pred_or_func::in,
sym_name::in, arity::in, clauses_info::in, clauses_info::out,
module_info::in, module_info::out, io::di, io::uo) is det.
clauses_info_add_pragma_foreign_proc(Purity, Attributes0, PredId, ProcId,
- PVarSet, PVars, OrigArgTypes, PragmaImpl0, Context, PredOrFunc,
- PredName, Arity, !ClausesInfo, !ModuleInfo, !IO) :-
+ PVarSet, PVars, OrigArgTypes, PragmaImpl0, Context,
+ PredOrFunc, PredName, Arity, !ClausesInfo, !ModuleInfo, !IO) :-
!.ClausesInfo = clauses_info(VarSet0, ExplicitVarTypes, TVarNameMap,
InferredVarTypes, HeadVars, ClauseRep, RttiVarMaps,
@@ -2395,7 +2395,7 @@
%
foreign.extrude_pragma_implementation(BackendForeignLanguages,
PVars, PredName, PredOrFunc, Context, !ModuleInfo,
- Attributes0, Attributes, PragmaImpl0, PragmaImpl),
+ Attributes0, Attributes1, PragmaImpl0, PragmaImpl),
%
% Check for arguments occurring multiple times.
@@ -2437,6 +2437,9 @@
% Put the purity in the goal_info in case this foreign code is inlined.
add_goal_info_purity_feature(Purity, GoalInfo1, GoalInfo),
make_foreign_args(HeadVars, ArgInfo, OrigArgTypes, ForeignArgs),
+ % Perform some renaming in any user annotated sharing information.
+ maybe_rename_user_annotated_sharing_information(Args0, HeadVars,
+ OrigArgTypes, Attributes1, Attributes, !IO),
HldsGoal0 = foreign_proc(Attributes, PredId, ProcId, ForeignArgs, [],
PragmaImpl) - GoalInfo,
map.init(EmptyVarTypes),
@@ -2465,6 +2468,31 @@
HasForeignClauses)
).
+ % Rename any user annotated structure sharing information from the
+ % variables (incl. type variables) in terms of which that information
+ % is expressed, to the formal variables in terms of which the clause
+ % is expressed.
+ %
+:- pred maybe_rename_user_annotated_sharing_information(list(prog_var)::in,
+ list(prog_var)::in, list(mer_type)::in,
+ pragma_foreign_proc_attributes::in, pragma_foreign_proc_attributes::out,
+ io::di, io::uo) is det.
+
+maybe_rename_user_annotated_sharing_information(ActualHeadVars, FormalHeadVars,
+ FormalTypes, !Attributes, !IO):-
+ globals.io_lookup_bool_option(structure_sharing_analysis, SharingAnalysis,
+ !IO),
+ (
+ SharingAnalysis = no
+ ;
+ SharingAnalysis = yes,
+ rename_user_annotated_sharing(ActualHeadVars, FormalHeadVars,
+ FormalTypes, user_annotated_sharing(!.Attributes),
+ FormalUserSharing),
+ set_user_annotated_sharing(FormalUserSharing, !Attributes)
+ ).
+
+
:- func is_applicable_for_current_backend(backend,
list(pragma_foreign_proc_extra_attribute)) = bool.
Index: compiler/ctgc.util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ctgc.util.m,v
retrieving revision 1.6
diff -u -d -r1.6 ctgc.util.m
--- compiler/ctgc.util.m 29 May 2006 13:04:32 -0000 1.6
+++ compiler/ctgc.util.m 27 Jun 2006 08:28:49 -0000
@@ -47,9 +47,8 @@
% Same as above, but then in the context of the types of the called
% procedures.
%
-:- func get_type_substitution(module_info, pred_proc_id, list(mer_type),
- tvarset) = tsubst.
-
+:- func get_type_substitution(module_info, pred_proc_id,
+ list(mer_type), tvarset) = tsubst.
%-----------------------------------------------------------------------------%
@@ -101,25 +100,14 @@
proc_info_get_headvars(ProcInfo, FormalVars),
map.from_corresponding_lists(FormalVars, ActualArgs, VariableRenaming).
-get_type_substitution(ModuleInfo, PPId, ActualTypes, ActualTVarset) =
+get_type_substitution(ModuleInfo, PPId, ActualTypes, _TVarSet) =
TypeSubstitution :-
module_info_pred_proc_info(ModuleInfo, PPId, PredInfo, _ProcInfo),
% types of the head variables.
- pred_info_get_arg_types(PredInfo, FormalTVarset, _, FormalTypes),
-
- % (this is a bit that was inspired by the code for
- % arg_type_list_subsumes/6)
- tvarset_merge_renaming(ActualTVarset, FormalTVarset,_TVarSet1, Renaming),
- apply_variable_renaming_to_type_list(Renaming, FormalTypes,
- RenFormalTypes),
+ pred_info_get_arg_types(PredInfo, FormalTypes),
- ( type_list_subsumes(RenFormalTypes, ActualTypes, TypeSubstitution0) ->
- TypeSubstitution = TypeSubstitution0
- ;
- unexpected(this_file, "Types are supposed to be unifiable.")
- ).
-
+ type_list_subsumes_det(FormalTypes, ActualTypes, TypeSubstitution).
%-----------------------------------------------------------------------------%
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.137
diff -u -d -r1.137 module_qual.m
--- compiler/module_qual.m 15 Jun 2006 19:37:04 -0000 1.137
+++ compiler/module_qual.m 27 Jun 2006 08:28:52 -0000
@@ -1060,10 +1060,17 @@
qualify_pragma(X at foreign_decl(_, _, _), X, !Info, !IO).
qualify_pragma(X at foreign_code(_, _), X, !Info, !IO).
qualify_pragma(X at foreign_import_module(_, _), X, !Info, !IO).
-qualify_pragma(X, Y, !Info, !IO) :-
- PragmaVars0 = X ^ proc_vars,
- qualify_pragma_vars(PragmaVars0, PragmaVars, !Info, !IO),
- Y = X ^ proc_vars := PragmaVars.
+qualify_pragma(foreign_proc(Attrs0, Name, PredOrFunc, Vars0, Varset,
+ InstVarset, Impl), foreign_proc(Attrs, Name, PredOrFunc, Vars, Varset,
+ InstVarset, Impl), !Info, !IO) :-
+ qualify_pragma_vars(Vars0, Vars, !Info, !IO),
+ UserSharing0 = user_annotated_sharing(Attrs0),
+ qualify_user_sharing(UserSharing0, UserSharing, !Info, !IO),
+ set_user_annotated_sharing(UserSharing, Attrs0, Attrs).
+% qualify_pragma(X, Y, !Info, !IO) :-
+ % PragmaVars0 = X ^ proc_vars,
+ % qualify_pragma_vars(PragmaVars0, PragmaVars, !Info, !IO),
+ % Y = X ^ proc_vars := PragmaVars.
qualify_pragma(tabled(EvalMethod, Name, Arity, PredOrFunc, MModes0, Attrs),
tabled(EvalMethod, Name, Arity, PredOrFunc, MModes, Attrs),
!Info, !IO) :-
@@ -1347,6 +1354,25 @@
convert_simple_item_type(inst_id) = inst_item.
convert_simple_item_type(class_id) = typeclass_item.
+:- pred qualify_user_sharing(user_annotated_sharing::in,
+ user_annotated_sharing::out, mq_info::in, mq_info::out,
+ io::di, io::uo) is det.
+
+qualify_user_sharing(!UserSharing, !Info, !IO) :-
+ (
+ !.UserSharing = no_user_annotated_sharing
+ ;
+ !.UserSharing = user_sharing(Sharing, MaybeTypes0),
+ (
+ MaybeTypes0 = yes(user_type_info(Types0, TVarset))
+ ->
+ qualify_type_list(Types0, Types, !Info, !IO),
+ MaybeTypes = yes(user_type_info(Types, TVarset)),
+ !:UserSharing = user_sharing(Sharing, MaybeTypes)
+ ;
+ true
+ )
+ ).
%-----------------------------------------------------------------------------%
:- type id_type
Index: compiler/prog_ctgc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_ctgc.m,v
retrieving revision 1.10
diff -u -d -r1.10 prog_ctgc.m
--- compiler/prog_ctgc.m 15 Jun 2006 19:37:08 -0000 1.10
+++ compiler/prog_ctgc.m 27 Jun 2006 08:28:53 -0000
@@ -27,6 +27,7 @@
:- import_module map.
:- import_module maybe.
:- import_module term.
+:- import_module varset.
%-----------------------------------------------------------------------------%
%
@@ -51,6 +52,9 @@
:- func parse_structure_reuse_domain(term(T)) = structure_reuse_domain.
+:- pred parse_user_annotated_sharing(varset::in, term::in,
+ user_annotated_sharing::out) is semidet.
+
%-----------------------------------------------------------------------------%
%
% Printing routines
@@ -153,6 +157,10 @@
tsubst::in, structure_sharing_domain::in,
structure_sharing_domain::out) is det.
+:- pred rename_user_annotated_sharing(list(prog_var)::in, list(prog_var)::in,
+ list(mer_type)::in, user_annotated_sharing::in,
+ user_annotated_sharing::out) is det.
+
:- pred rename_structure_reuse_condition(map(prog_var, prog_var)::in,
tsubst::in, structure_reuse_condition::in,
structure_reuse_condition::out) is det.
@@ -175,11 +183,13 @@
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_io_util.
:- import_module parse_tree.prog_out.
+:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
:- import_module parse_tree.prog_util.
:- import_module string.
:- import_module pair.
+:- import_module set.
:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -331,14 +341,15 @@
Term = term.functor(term.atom(Cons), _, Context),
(
Cons = "[|]",
- SharingAs0 = real(parse_structure_sharing(Term))
+ SharingAs0 = structure_sharing_real(parse_structure_sharing(Term))
;
Cons = "bottom",
- SharingAs0 = bottom
+ SharingAs0 = structure_sharing_bottom
;
Cons = "top",
context_to_string(Context, ContextMsg),
- SharingAs0 = top(["imported top: " ++ ContextMsg ++ "."])
+ SharingAs0 = structure_sharing_top(["imported top: "
+ ++ ContextMsg ++ "."])
)
->
SharingAs = SharingAs0
@@ -415,6 +426,88 @@
"(term not a functor).")
).
+%-----------------------------------------------------------------------------%
+
+parse_user_annotated_sharing(Varset, Term, UserSharing) :-
+ (
+ Term = term.functor(term.atom("no_sharing"), [], _),
+ UserSharing = user_sharing(structure_sharing_bottom, no)
+ ;
+ Term = term.functor(term.atom("unknown_sharing"), [], Context),
+ context_to_string(Context, ContextString),
+ Msg = "user declared top(" ++ ContextString ++ ")",
+ UserSharing = user_sharing(structure_sharing_top([Msg]), no)
+ ;
+ Term = term.functor(term.atom("sharing"),
+ [TypesTerm, UserSharingTerm], _),
+ (
+ TypesTerm = term.functor(term.atom("yes"), ListTypeTerms, _),
+ parse_types(ListTypeTerms, ok(Types)),
+ term.vars_list(ListTypeTerms, TypeVars),
+ varset.select(Varset, set.list_to_set(TypeVars), Varset0),
+ MaybeUserTypes = yes(user_type_info(Types,
+ varset.coerce(Varset0)))
+ ;
+ TypesTerm = term.functor(term.atom("no"), _, _),
+ MaybeUserTypes = no
+ ),
+ parse_user_annotated_sharing_term(UserSharingTerm, Sharing),
+ UserSharing = user_sharing(Sharing, MaybeUserTypes)
+ ).
+
+:- pred parse_user_annotated_sharing_term(term::in,
+ structure_sharing_domain::out) is semidet.
+
+parse_user_annotated_sharing_term(SharingDomainUserTerm, SharingDomain) :-
+ get_list_term_arguments(SharingDomainUserTerm, SharingPairTerms),
+ (
+ SharingPairTerms = [],
+ SharingDomain = structure_sharing_bottom
+ ;
+ SharingPairTerms = [_|_],
+ list.map(parse_user_annotated_sharing_pair_term, SharingPairTerms,
+ SharingPairs),
+ SharingDomain = structure_sharing_real(SharingPairs)
+ ).
+
+:- pred get_list_term_arguments(term::in, list(term)::out) is semidet.
+
+get_list_term_arguments(ListTerm, ArgumentTerms) :-
+ ListTerm = term.functor(term.atom(Cons), Args, _),
+ (
+ Cons = "[|]",
+ Args = [FirstTerm, RestTerm],
+ get_list_term_arguments(RestTerm, RestList),
+ ArgumentTerms = [FirstTerm | RestList]
+ ;
+ Cons = "[]",
+ ArgumentTerms = []
+ ).
+
+:- pred parse_user_annotated_sharing_pair_term(term::in,
+ structure_sharing_pair::out) is semidet.
+
+parse_user_annotated_sharing_pair_term(Term, SharingPair) :-
+ Term = term.functor(term.atom("-"), [Left, Right], _),
+ parse_user_annotated_datastruct_term(Left, LeftData),
+ parse_user_annotated_datastruct_term(Right, RightData),
+ SharingPair = LeftData - RightData.
+
+:- pred parse_user_annotated_datastruct_term(term::in, datastruct::out)
+ is semidet.
+
+parse_user_annotated_datastruct_term(Term, Datastruct) :-
+ Term = term.functor(term.atom("cel"), [VarTerm, TypesTerm], _),
+ VarTerm = term.variable(GenericVar),
+ term.coerce_var(GenericVar, ProgVar),
+ get_list_term_arguments(TypesTerm, TypeTermsList),
+ parse_types(TypeTermsList, ok(Types)),
+ list.map(mer_type_to_typesel, Types, Selector),
+ Datastruct = selected_cel(ProgVar, Selector).
+
+:- pred mer_type_to_typesel(mer_type::in, unit_selector::out) is det.
+
+mer_type_to_typesel(Type, typesel(Type)).
%-----------------------------------------------------------------------------%
%
@@ -518,7 +611,7 @@
MaybeThreshold, Start, Separator, End, SharingAs, !IO) :-
io.write_string(Start, !IO),
(
- SharingAs = top(Msgs),
+ SharingAs = structure_sharing_top(Msgs),
(
VerboseTop = no,
io.write_string("top", !IO)
@@ -529,10 +622,10 @@
io.write_string("])", !IO)
)
;
- SharingAs = bottom,
+ SharingAs = structure_sharing_bottom,
io.write_string("bottom", !IO)
;
- SharingAs = real(SharingPairs),
+ SharingAs = structure_sharing_real(SharingPairs),
print_structure_sharing(ProgVarSet, TypeVarSet,
MaybeThreshold, "[", Separator, "]", SharingPairs, !IO)
),
@@ -628,11 +721,48 @@
rename_structure_sharing(Dict, TypeSubst, !List) :-
list.map(rename_structure_sharing_pair(Dict, TypeSubst), !List).
-rename_structure_sharing_domain(_, _, bottom, bottom).
-rename_structure_sharing_domain(_, _, X @ top(_), X).
-rename_structure_sharing_domain(Dict, TypeSubst, real(!.List), real(!:List)):-
+rename_structure_sharing_domain(_, _, X @ structure_sharing_bottom, X).
+rename_structure_sharing_domain(_, _, X @ structure_sharing_top(_), X).
+rename_structure_sharing_domain(Dict, TypeSubst,
+ structure_sharing_real(!.List), structure_sharing_real(!:List)):-
rename_structure_sharing(Dict, TypeSubst, !List).
+%-----------------------------------------------------------------------------%
+
+rename_user_annotated_sharing(HeadVars, NewHeadVars, NewTypes,
+ !UserSharing) :-
+ (
+ !.UserSharing = no_user_annotated_sharing
+ ;
+ !.UserSharing = user_sharing(Sharing, MaybeTypes),
+ some [!SharingDomain] (
+ !:SharingDomain = Sharing,
+ (
+ !.SharingDomain = structure_sharing_bottom
+ ;
+ !.SharingDomain = structure_sharing_top(_)
+ ;
+ !.SharingDomain = structure_sharing_real(SharingPairs),
+ map.from_corresponding_lists(HeadVars, NewHeadVars,
+ VarRenaming),
+ (
+ MaybeTypes = yes(user_type_info(UserSharingTypes,
+ _UserSharingTVarSet))
+ ->
+ type_list_subsumes_det(UserSharingTypes, NewTypes,
+ TypeSubst)
+ ;
+ TypeSubst = map.init
+ ),
+ rename_structure_sharing(VarRenaming, TypeSubst,
+ SharingPairs, NewSharingPairs),
+ !:SharingDomain = structure_sharing_real(NewSharingPairs)
+ ),
+ !:UserSharing = user_sharing(!.SharingDomain, no)
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
rename_structure_reuse_condition(Dict, TypeSubst,
structure_reuse_condition(DeadNodes, LiveNodes, Sharing),
structure_reuse_condition(RenDeadNodes, RenLiveNodes, RenSharing)) :-
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.167
diff -u -d -r1.167 prog_data.m
--- compiler/prog_data.m 15 Jun 2006 19:37:08 -0000 1.167
+++ compiler/prog_data.m 27 Jun 2006 08:28:56 -0000
@@ -328,9 +328,9 @@
% This is the public representation of the type "sharing_as".
%
:- type structure_sharing_domain
- ---> bottom
- ; real(structure_sharing)
- ; top(list(top_feedback)).
+ ---> structure_sharing_bottom
+ ; structure_sharing_real(structure_sharing)
+ ; structure_sharing_top(list(top_feedback)).
% Public representation of structure sharing.
%
@@ -364,6 +364,25 @@
---> termsel(cons_id, int) % term selector
; typesel(mer_type). % type selector
+ % Type to represent the sharing information that is manually added
+ % to procedures writtin in foreign code.
+ %
+:- type user_annotated_sharing
+ ---> no_user_annotated_sharing
+ ; user_sharing(
+ sharing :: structure_sharing_domain,
+ maybe_types :: maybe(user_sharing_type_information)
+ ).
+
+ % The user may have declared the sharing in terms of type variables. In
+ % that case, we record the types, and the type variable set.
+ %
+:- type user_sharing_type_information
+ ---> user_type_info(
+ types :: list(mer_type),
+ typevarset :: tvarset
+ ).
+
%-----------------------------------------------------------------------------%
%
% Stuff for the `structure_reuse_info' pragma.
@@ -657,6 +676,8 @@
:- func thread_safe(pragma_foreign_proc_attributes) = thread_safe.
:- func purity(pragma_foreign_proc_attributes) = purity.
:- func terminates(pragma_foreign_proc_attributes) = terminates.
+:- func user_annotated_sharing(pragma_foreign_proc_attributes) =
+ user_annotated_sharing.
:- func foreign_language(pragma_foreign_proc_attributes) = foreign_language.
:- func tabled_for_io(pragma_foreign_proc_attributes) = tabled_for_io.
:- func legacy_purity_behaviour(pragma_foreign_proc_attributes) = bool.
@@ -694,6 +715,10 @@
pragma_foreign_proc_attributes::in,
pragma_foreign_proc_attributes::out) is det.
+:- pred set_user_annotated_sharing(user_annotated_sharing::in,
+ pragma_foreign_proc_attributes::in,
+ pragma_foreign_proc_attributes::out) is det.
+
:- pred set_may_throw_exception(may_throw_exception::in,
pragma_foreign_proc_attributes::in,
pragma_foreign_proc_attributes::out) is det.
@@ -1463,6 +1488,7 @@
tabled_for_io :: tabled_for_io,
purity :: purity,
terminates :: terminates,
+ user_annotated_sharing :: user_annotated_sharing,
may_throw_exception :: may_throw_exception,
% There is some special case behaviour for pragma c_code
@@ -1479,8 +1505,9 @@
default_attributes(Language) =
attributes(Language, may_call_mercury, not_thread_safe,
not_tabled_for_io, purity_impure, depends_on_mercury_calls,
- default_exception_behaviour, no, no, may_modify_trail,
- default_calls_mm_tabled, native_if_possible, []).
+ no_user_annotated_sharing, default_exception_behaviour,
+ no, no, may_modify_trail, default_calls_mm_tabled,
+ native_if_possible, []).
set_may_call_mercury(MayCallMercury, Attrs0, Attrs) :-
Attrs = Attrs0 ^ may_call_mercury := MayCallMercury.
@@ -1494,6 +1521,8 @@
Attrs = Attrs0 ^ purity := Purity.
set_terminates(Terminates, Attrs0, Attrs) :-
Attrs = Attrs0 ^ terminates := Terminates.
+set_user_annotated_sharing(UserSharing, Attrs0, Attrs) :-
+ Attrs = Attrs0 ^ user_annotated_sharing := UserSharing.
set_may_throw_exception(MayThrowException, Attrs0, Attrs) :-
Attrs = Attrs0 ^ may_throw_exception := MayThrowException.
set_legacy_purity_behaviour(Legacy, Attrs0, Attrs) :-
@@ -1512,7 +1541,7 @@
% in the attribute list -- the foreign language specifier string
% is at the start of the pragma.
Attrs = attributes(_Lang, MayCallMercury, ThreadSafe, TabledForIO,
- Purity, Terminates, Exceptions, _LegacyBehaviour,
+ Purity, Terminates, _UserSharing, Exceptions, _LegacyBehaviour,
OrdinaryDespiteDetism, MayModifyTrail, MayCallMM_Tabled,
BoxPolicy, ExtraAttributes),
(
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.105
diff -u -d -r1.105 prog_io_pragma.m
--- compiler/prog_io_pragma.m 15 Jun 2006 19:37:10 -0000 1.105
+++ compiler/prog_io_pragma.m 27 Jun 2006 08:28:58 -0000
@@ -528,7 +528,7 @@
PTerms6 = [PredAndVarsTerm, FlagsTerm, FieldsTerm,
FirstTerm, LaterTerm, SharedTerm],
parse_pragma_foreign_proc_attributes_term(ForeignLanguage, Pragma,
- FlagsTerm, MaybeFlags),
+ VarSet, FlagsTerm, MaybeFlags),
( MaybeFlags = ok(Flags) ->
(
parse_pragma_keyword("local_vars", FieldsTerm, Fields,
@@ -619,7 +619,7 @@
PTerms3 = [PredAndVarsTerm, FlagsTerm, CodeTerm],
( CodeTerm = term.functor(term.string(Code), [], Context) ->
parse_pragma_foreign_proc_attributes_term(ForeignLanguage,
- Pragma, FlagsTerm, MaybeFlags),
+ Pragma, VarSet, FlagsTerm, MaybeFlags),
(
MaybeFlags = ok(Flags),
parse_pragma_foreign_code(ModuleName, Flags,
@@ -628,7 +628,7 @@
;
MaybeFlags = error(FlagsErr, FlagsErrTerm),
parse_pragma_foreign_proc_attributes_term(
- ForeignLanguage, Pragma, PredAndVarsTerm,
+ ForeignLanguage, Pragma, VarSet, PredAndVarsTerm,
MaybeFlags2),
(
MaybeFlags2 = ok(Flags),
@@ -713,7 +713,7 @@
Result = error(string.append(InvalidDeclStr, ErrMsg0), ErrorTerm)
).
-parse_pragma_type(ModuleName, "import", PragmaTerms, ErrorTerm, _VarSet,
+parse_pragma_type(ModuleName, "import", PragmaTerms, ErrorTerm, VarSet,
Result) :-
% XXX we assume all imports are C
ForeignLanguage = lang_c,
@@ -721,7 +721,7 @@
(
PragmaTerms = [PredAndModesTerm, FlagsTerm, FunctionTerm],
parse_pragma_foreign_proc_attributes_term(ForeignLanguage,
- "import", FlagsTerm, MaybeFlags),
+ "import", VarSet, FlagsTerm, MaybeFlags),
(
MaybeFlags = error(FlagError, ErrorTerm),
FlagsResult = error("invalid second argument in "
@@ -1384,7 +1384,7 @@
; thread_safe(thread_safe)
; tabled_for_io(tabled_for_io)
; purity(purity)
- ; aliasing
+ ; user_annotated_sharing(user_annotated_sharing)
; max_stack_size(int)
; backend(backend)
; terminates(terminates)
@@ -1395,11 +1395,11 @@
; box_policy(box_policy).
:- pred parse_pragma_foreign_proc_attributes_term(foreign_language::in,
- string::in, term::in, maybe1(pragma_foreign_proc_attributes)::out)
- is det.
+ string::in, varset::in, term::in,
+ maybe1(pragma_foreign_proc_attributes)::out) is det.
-parse_pragma_foreign_proc_attributes_term(ForeignLanguage, Pragma, Term,
- MaybeAttributes) :-
+parse_pragma_foreign_proc_attributes_term(ForeignLanguage, Pragma, Varset,
+ Term, MaybeAttributes) :-
Attributes0 = default_attributes(ForeignLanguage),
( ( Pragma = "c_code" ; Pragma = "import" ) ->
set_legacy_purity_behaviour(yes, Attributes0, Attributes1),
@@ -1436,7 +1436,7 @@
box_policy(native_if_possible) - box_policy(always_boxed)
],
(
- parse_pragma_foreign_proc_attributes_term0(Term, AttrList)
+ parse_pragma_foreign_proc_attributes_term0(Varset, Term, AttrList)
->
(
list.member(Conflict1 - Conflict2, ConflictingAttributes),
@@ -1486,10 +1486,8 @@
set_may_call_mm_tabled(MayCallTabled, !Attrs).
process_attribute(box_policy(BoxPolicy), !Attrs) :-
set_box_policy(BoxPolicy, !Attrs).
-
- % Aliasing is currently ignored in the main branch compiler.
- %
-process_attribute(aliasing, Attrs, Attrs).
+process_attribute(user_annotated_sharing(UserSharing), !Attrs) :-
+ set_user_annotated_sharing(UserSharing, !Attrs).
% Check whether all the required attributes have been set for
% a particular language
@@ -1514,11 +1512,11 @@
).
check_required_attributes(lang_java, Attrs, _Term) = ok(Attrs).
-:- pred parse_pragma_foreign_proc_attributes_term0(term::in,
+:- pred parse_pragma_foreign_proc_attributes_term0(varset::in, term::in,
list(collected_pragma_foreign_proc_attribute)::out) is semidet.
-parse_pragma_foreign_proc_attributes_term0(Term, Flags) :-
- ( parse_single_pragma_foreign_proc_attribute(Term, Flag) ->
+parse_pragma_foreign_proc_attributes_term0(Varset, Term, Flags) :-
+ ( parse_single_pragma_foreign_proc_attribute(Varset, Term, Flag) ->
Flags = [Flag]
;
(
@@ -1526,24 +1524,25 @@
Flags = []
;
Term = term.functor(term.atom("[|]"), [Head, Tail], _),
- parse_single_pragma_foreign_proc_attribute(Head, HeadFlag),
- parse_pragma_foreign_proc_attributes_term0(Tail, TailFlags),
+ parse_single_pragma_foreign_proc_attribute(Varset, Head, HeadFlag),
+ parse_pragma_foreign_proc_attributes_term0(Varset, Tail,
+ TailFlags),
Flags = [HeadFlag | TailFlags]
)
).
-:- pred parse_single_pragma_foreign_proc_attribute(term::in,
+:- pred parse_single_pragma_foreign_proc_attribute(varset::in, term::in,
collected_pragma_foreign_proc_attribute::out) is semidet.
-parse_single_pragma_foreign_proc_attribute(Term, Flag) :-
+parse_single_pragma_foreign_proc_attribute(Varset, Term, Flag) :-
( parse_may_call_mercury(Term, MayCallMercury) ->
Flag = may_call_mercury(MayCallMercury)
; parse_threadsafe(Term, ThreadSafe) ->
Flag = thread_safe(ThreadSafe)
; parse_tabled_for_io(Term, TabledForIo) ->
Flag = tabled_for_io(TabledForIo)
- ; parse_aliasing(Term) ->
- Flag = aliasing
+ ; parse_user_annotated_sharing(Varset, Term, UserSharing) ->
+ Flag = user_annotated_sharing(UserSharing)
; parse_max_stack_size(Term, Size) ->
Flag = max_stack_size(Size)
; parse_backend(Term, Backend) ->
@@ -1623,17 +1622,6 @@
Str = "not_tabled_for_io",
TabledForIo = not_tabled_for_io
).
-
- % XXX For the moment we just ignore the following attributes.
- % These attributes are used for aliasing on the reuse branch,
- % and ignoring them allows the main branch compiler to compile
- % the reuse branch.
- %
-:- pred parse_aliasing(term::in) is semidet.
-
-parse_aliasing(term.functor(term.atom("no_aliasing"), [], _)).
-parse_aliasing(term.functor(term.atom("unknown_aliasing"), [], _)).
-parse_aliasing(term.functor(term.atom("alias"), [_Types, _Alias], _)).
:- pred parse_max_stack_size(term::in, int::out) is semidet.
Index: compiler/structure_reuse.direct.detect_garbage.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/structure_reuse.direct.detect_garbage.m,v
retrieving revision 1.3
diff -u -d -r1.3 structure_reuse.direct.detect_garbage.m
--- compiler/structure_reuse.direct.detect_garbage.m 5 Jun 2006 05:23:27 -0000 1.3
+++ compiler/structure_reuse.direct.detect_garbage.m 27 Jun 2006 08:28:59 -0000
@@ -112,14 +112,11 @@
!:SharingAs = sharing_as_least_upper_bound(ModuleInfo, ProcInfo,
ThenSharingAs, ElseSharingAs)
;
- GoalExpr = foreign_proc(_Attrs, _ForeignPredId, _ForeignProcId,
+ GoalExpr = foreign_proc(Attributes, ForeignPredId, ForeignProcId,
_ForeignArgs, _, _),
- % XXX User annotated structure sharing information is not yet
- % supported.
goal_info_get_context(GoalInfo, Context),
- context_to_string(Context, ContextString),
- !:SharingAs = sharing_as_top_sharing_accumulate(
- "foreign_proc not handled yet (" ++ ContextString ++ ")",
+ !:SharingAs = add_foreign_code_sharing(ModuleInfo, ProcInfo,
+ proc(ForeignPredId, ForeignProcId), Attributes, Context,
!.SharingAs)
;
GoalExpr = shorthand(_),
Index: compiler/structure_reuse.indirect.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/structure_reuse.indirect.m,v
retrieving revision 1.3
diff -u -d -r1.3 structure_reuse.indirect.m
--- compiler/structure_reuse.indirect.m 15 Jun 2006 19:37:11 -0000 1.3
+++ compiler/structure_reuse.indirect.m 27 Jun 2006 08:29:00 -0000
@@ -262,6 +262,9 @@
io::di, io::uo) is det.
indirect_reuse_analyse_goal(BaseInfo, !Goal, !AnalysisInfo, !IO) :-
+ ModuleInfo = BaseInfo ^ module_info,
+ ProcInfo = BaseInfo ^ proc_info,
+ SharingTable = BaseInfo ^ sharing_table,
!.Goal = GoalExpr0 - GoalInfo0,
(
GoalExpr0 = conj(ConjType, Goals0),
@@ -273,9 +276,9 @@
GoalExpr0 = call(CalleePredId, CalleeProcId, CalleeArgs, _, _, _),
verify_indirect_reuse(BaseInfo, CalleePredId, CalleeProcId,
CalleeArgs, GoalInfo0, GoalInfo, !AnalysisInfo, !IO),
- lookup_sharing_and_comb(BaseInfo ^ module_info, BaseInfo ^ proc_info,
- BaseInfo ^ sharing_table, CalleePredId, CalleeProcId,
- CalleeArgs, !.AnalysisInfo ^ sharing_as, NewSharing),
+ lookup_sharing_and_comb(ModuleInfo, ProcInfo, SharingTable,
+ CalleePredId, CalleeProcId, CalleeArgs,
+ !.AnalysisInfo ^ sharing_as, NewSharing),
!:AnalysisInfo = !.AnalysisInfo ^ sharing_as := NewSharing,
GoalExpr = GoalExpr0,
!:Goal = GoalExpr - GoalInfo
@@ -298,8 +301,8 @@
true
),
!:AnalysisInfo = !.AnalysisInfo ^ sharing_as :=
- add_unify_sharing(BaseInfo ^ module_info, BaseInfo ^ proc_info,
- Unification, GoalInfo0, !.AnalysisInfo ^ sharing_as)
+ add_unify_sharing(ModuleInfo, ProcInfo, Unification,
+ GoalInfo0, !.AnalysisInfo ^ sharing_as)
;
GoalExpr0 = disj(Goals0),
list.map2_foldl2(
@@ -355,16 +358,13 @@
GoalExpr = if_then_else(A, IfGoal, ThenGoal, ElseGoal),
!:Goal = GoalExpr - GoalInfo0
;
- GoalExpr0 = foreign_proc(_Attrs, _ForeignPredId, _ForeignProcId,
+ GoalExpr0 = foreign_proc(Attributes, ForeignPredId, ForeignProcId,
_ForeignArgs, _, _),
- % XXX User annotated structure sharing information is not yet
- % supported.
goal_info_get_context(GoalInfo0, Context),
- context_to_string(Context, ContextString),
!:AnalysisInfo = !.AnalysisInfo ^ sharing_as :=
- sharing_as_top_sharing_accumulate(
- "foreign_proc not handled yet (" ++ ContextString ++ ")",
- !.AnalysisInfo ^ sharing_as)
+ add_foreign_code_sharing(ModuleInfo, ProcInfo,
+ proc(ForeignPredId, ForeignProcId), Attributes, Context,
+ !.AnalysisInfo ^ sharing_as)
;
GoalExpr0 = shorthand(_),
unexpected(this_file, "indirect_reuse_analyse_goal: shorthand goal.")
Index: compiler/structure_sharing.analysis.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/structure_sharing.analysis.m,v
retrieving revision 1.14
diff -u -d -r1.14 structure_sharing.analysis.m
--- compiler/structure_sharing.analysis.m 15 Jun 2006 19:37:12 -0000 1.14
+++ compiler/structure_sharing.analysis.m 27 Jun 2006 08:29:00 -0000
@@ -401,14 +401,11 @@
!:SharingAs = sharing_as_least_upper_bound(ModuleInfo, ProcInfo,
ThenSharingAs, ElseSharingAs)
;
- GoalExpr = foreign_proc(_Attrs, _ForeignPredId, _ForeignProcId,
+ GoalExpr = foreign_proc(Attributes, ForeignPredId, ForeignProcId,
_ForeignArgs, _, _),
- % XXX User annotated structure sharing information is not yet
- % supported.
goal_info_get_context(GoalInfo, Context),
- context_to_string(Context, ContextString),
- !:SharingAs = sharing_as_top_sharing_accumulate(
- "foreign_proc not handled yet (" ++ ContextString ++ ")",
+ !:SharingAs = add_foreign_code_sharing(ModuleInfo, ProcInfo,
+ proc(ForeignPredId, ForeignProcId), Attributes, Context,
!.SharingAs)
;
GoalExpr = shorthand(_),
Index: compiler/structure_sharing.domain.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/structure_sharing.domain.m,v
retrieving revision 1.10
diff -u -d -r1.10 structure_sharing.domain.m
--- compiler/structure_sharing.domain.m 5 Jun 2006 05:23:27 -0000 1.10
+++ compiler/structure_sharing.domain.m 27 Jun 2006 08:29:03 -0000
@@ -149,10 +149,13 @@
:- func add_unify_sharing(module_info, proc_info, unification, hlds_goal_info,
sharing_as) = sharing_as.
- % XXX Not yet implemented.
-% :- func add_foreign_code_sharing(module_info, pred_proc_id, goal_info
- % pragma_foreign_proc_attributes, list(foreign_arg),
- % sharing_as) = sharing_as.
+ % Add the sharing created by a call to some foreign code. This
+ % sharing corresponds to the sharing information with which the
+ % foreign code was manually annotated, or can be predicted to
+ % "bottom", and in the worst case to "top".
+ %
+:- func add_foreign_code_sharing(module_info, proc_info, pred_proc_id,
+ pragma_foreign_proc_attributes, prog_context, sharing_as) = sharing_as.
% Compare two sharing sets. A sharing set Set1 is subsumed by a sharing set
% Set2 iff the total set of sharing represented by Set1 is a subset of the
@@ -587,6 +590,59 @@
set.to_sorted_list(Deaths, DeathsList),
sharing_as_project_with_type(outproject, DeathsList, Sharing0, Sharing).
+add_foreign_code_sharing(ModuleInfo, ProcInfo, ForeignPPId,
+ Attributes, GoalContext, OldSharing) = NewSharing :-
+ ForeignSharing = sharing_as_for_foreign_proc(ModuleInfo,
+ Attributes, ForeignPPId, GoalContext),
+ NewSharing = sharing_as_comb(ModuleInfo, ProcInfo, ForeignSharing,
+ OldSharing).
+
+:- func sharing_as_for_foreign_proc(module_info,
+ pragma_foreign_proc_attributes, pred_proc_id, prog_context) = sharing_as.
+
+sharing_as_for_foreign_proc(ModuleInfo, Attributes, ForeignPPId,
+ ProgContext) = SharingAs :-
+ (
+ sharing_as_from_user_annotated_sharing(Attributes, SharingAs0)
+ ->
+ SharingAs = SharingAs0
+ ;
+ predict_called_pred_is_bottom(ModuleInfo, ForeignPPId)
+ ->
+ SharingAs = sharing_as_bottom
+ ;
+ context_to_string(ProgContext, ContextString),
+ Msg = "foreign proc with unknown sharing ("
+ ++ ContextString ++ ")",
+ SharingAs = sharing_as_top_sharing(Msg)
+ ).
+
+:- pred sharing_as_from_user_annotated_sharing(
+ pragma_foreign_proc_attributes::in, sharing_as::out) is semidet.
+
+sharing_as_from_user_annotated_sharing(Attributes, UserSharingAs) :-
+ UserSharing = user_annotated_sharing(Attributes),
+ UserSharing = user_sharing(SharingDomain, _MaybeTypes),
+ % Accept only the value "bottom" and "real" for the structure sharing.
+ % If the user has annotated the sharing with unknown sharing, we might
+ % try to predict bottom anyway.
+ some [!SharingAs] (
+ (
+ SharingDomain = structure_sharing_bottom,
+ !:SharingAs = sharing_as_bottom
+ ;
+ SharingDomain = structure_sharing_real(_SharingPairs),
+ !:SharingAs = from_structure_sharing_domain(SharingDomain)
+
+ % XXX
+ % I have the feeling that renaming should not be needed at this
+ % place anymore, assuming that every foreign_proc call is
+ ),
+ UserSharingAs = !.SharingAs
+ ).
+
+
sharing_as_is_subsumed_by(ModuleInfo, ProcInfo, Sharing1, Sharing2) :-
(
Sharing2 = sharing_as_top(_)
@@ -676,27 +732,28 @@
from_structure_sharing_domain(SharingDomain) = SharingAs :-
(
- SharingDomain = bottom,
+ SharingDomain = structure_sharing_bottom,
SharingAs = sharing_as_bottom
;
- SharingDomain = real(StructureSharing),
+ SharingDomain = structure_sharing_real(StructureSharing),
SharingSet = from_sharing_pair_list(StructureSharing),
wrap(SharingSet, SharingAs)
;
- SharingDomain = top(Msgs),
+ SharingDomain = structure_sharing_top(Msgs),
SharingAs = sharing_as_top(Msgs)
).
to_structure_sharing_domain(SharingAs) = SharingDomain :-
(
SharingAs = sharing_as_bottom,
- SharingDomain = bottom
+ SharingDomain = structure_sharing_bottom
;
SharingAs = sharing_as_real_as(SharingSet),
- SharingDomain = real(to_sharing_pair_list(SharingSet))
+ SharingDomain = structure_sharing_real(
+ to_sharing_pair_list(SharingSet))
;
SharingAs = sharing_as_top(Msgs),
- SharingDomain = top(Msgs)
+ SharingDomain = structure_sharing_top(Msgs)
).
%-----------------------------------------------------------------------------%
--
nancy.mazur at cs.kuleuven.ac.be ------------ Katholieke Universiteit Leuven -
tel: +32-16-327596 - fax: +32-16-327996 ------- Dept. of Computer Science -
Disclaimer: http://www.kuleuven.be/cwis/email_disclaimer.htm
--------------------------------------------------------------------------
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