[m-rev.] diff: [CTGC] existential subtype handling
Peter Wang
novalazy at gmail.com
Mon Aug 4 15:32:50 AEST 2008
Branches: main
compiler/ctgc.selector.m:
When checking if one selector subsumes another, throw an exception if
we'd need to know the type of a existentially typed node, instead of
aborting.
When applying type widening to a selector, if the selector selects an
existentially typed node, just leave the selector alone. Previously I
made it widen to the type of the node's parent, which actually doesn't
make sense.
Rename some predicates/functions to make sense without module
qualification.
compiler/structure_sharing.domain.m:
Fall back to `top' sharing if an exception is thrown when combining two
`sharing_as' structures.
Conform to renamings.
compiler/ctgc.datastruct.m:
Conform to renamings.
compiler/structure_reuse.domain.m:
compiler/type_util.m:
Cosmetic changes.
diff --git a/compiler/ctgc.datastruct.m b/compiler/ctgc.datastruct.m
index 348dc17..1db7a36 100644
--- a/compiler/ctgc.datastruct.m
+++ b/compiler/ctgc.datastruct.m
@@ -144,8 +144,8 @@ datastruct_subsumed_by_return_selector(ModuleInfo, ProcInfo, Data1, Data2,
Data2 = selected_cel(Var, Sel2),
proc_info_get_vartypes(ProcInfo, VarTypes),
map.lookup(VarTypes, Var, Type),
- selector.subsumed_by(ModuleInfo, already_normalized, Sel1, Sel2, Type,
- Extension).
+ selector_subsumed_by(ModuleInfo, already_normalized,
+ Sel1, Sel2, Type, Extension).
datastruct_subsumed_by(ModuleInfo, ProcInfo, Data1, Data2) :-
datastruct_subsumed_by_return_selector(ModuleInfo, ProcInfo, Data1, Data2,
diff --git a/compiler/ctgc.selector.m b/compiler/ctgc.selector.m
index 866db54..3aff069 100644
--- a/compiler/ctgc.selector.m
+++ b/compiler/ctgc.selector.m
@@ -23,6 +23,12 @@
%-----------------------------------------------------------------------------%
+ % An exception of this type is thrown a procedure would need to know the
+ % type of a existentially typed node to proceed.
+ %
+:- type encounter_existential_subtype
+ ---> encounter_existential_subtype.
+
:- type normalization
---> need_normalization
; already_normalized.
@@ -38,7 +44,8 @@
%
:- pred selector_termshift(selector::in, selector::in, selector::out) is det.
- % subsumed_by(ModuleInfo, Selector1, Selector2, Type, Extension).
+ % selector_subsumed_by(ModuleInfo, Normalization,
+ % Selector1, Selector2, Type, Extension).
%
% Succeeds iff Selector1 is subsumed by Selector2. This means that
% Selector2 is more general than Selector1, hence, there exists an
@@ -46,7 +53,7 @@
%
% The type specifies the type of the term to which the selectors refer.
%
-:- pred subsumed_by(module_info::in, normalization::in,
+:- pred selector_subsumed_by(module_info::in, normalization::in,
selector::in, selector::in, mer_type::in, selector::out) is semidet.
% Using the type information of the variable to which the given selector
@@ -80,6 +87,7 @@
:- import_module assoc_list.
:- import_module bool.
+:- import_module exception.
:- import_module map.
:- import_module pair.
:- import_module queue.
@@ -119,7 +127,7 @@ selector_init_from_list(Types)
selector_termshift(S1, S2, S) :-
list.append(S1, S2, S).
-subsumed_by(ModuleInfo, Normalization, S1, S2, MainType, Extension):-
+selector_subsumed_by(ModuleInfo, Normalization, S1, S2, MainType, Extension) :-
% First make sure that both selectors are in a normalized form.
(
Normalization = already_normalized,
@@ -137,9 +145,9 @@ subsumed_by(ModuleInfo, Normalization, S1, S2, MainType, Extension):-
only_term_selectors(NormS2)
->
% Easy case.
- selector_subsumed_by(NormS1, NormS2, Extension)
+ term_selector_subsumed_by(NormS1, NormS2, Extension)
;
- subsumed_by_2(ModuleInfo, NormS1, NormS2, MainType, Extension)
+ selector_subsumed_by_2(ModuleInfo, NormS1, NormS2, MainType, Extension)
).
:- pred only_term_selectors(selector::in) is semidet.
@@ -151,19 +159,19 @@ only_term_selectors([H | T]) :-
% Both selectors must only contain term selectors.
%
-:- pred selector_subsumed_by(selector::in, selector::in, selector::out)
+:- pred term_selector_subsumed_by(selector::in, selector::in, selector::out)
is semidet.
-selector_subsumed_by(S1, S2, Extension):-
+term_selector_subsumed_by(S1, S2, Extension) :-
list.append(S2, Extension, S1).
- % The general case of subsumed_by, where either selector may contain type
- % selectors.
+ % The general case of selector_subsumed_by, where either selector may
+ % contain type selectors.
%
-:- pred subsumed_by_2(module_info::in, selector::in, selector::in,
+:- pred selector_subsumed_by_2(module_info::in, selector::in, selector::in,
mer_type::in, selector::out) is semidet.
-subsumed_by_2(ModuleInfo, A, B, Type, Extension) :-
+selector_subsumed_by_2(ModuleInfo, A, B, Type, Extension) :-
(
B = [],
Extension = A
@@ -179,7 +187,7 @@ subsumed_by_2(ModuleInfo, A, B, Type, Extension) :-
ConsIdA = ConsIdB,
IndexA = IndexB,
SubType = det_select_subtype(ModuleInfo, Type, ConsIdA, IndexA),
- subsumed_by_2(ModuleInfo, AT, BT, SubType, Extension)
+ selector_subsumed_by_2(ModuleInfo, AT, BT, SubType, Extension)
;
% If one selector has a term selector at the current position but
% the other has a type selector, we select the node dictated by the
@@ -190,10 +198,10 @@ subsumed_by_2(ModuleInfo, A, B, Type, Extension) :-
SubTypeA = det_select_subtype(ModuleInfo, Type, ConsIdA, IndexA),
( SubTypeA = SubTypeB ->
% Both selectors agree on the subtype to select.
- subsumed_by_2(ModuleInfo, AT, BT, SubTypeA, Extension)
+ selector_subsumed_by_2(ModuleInfo, AT, BT, SubTypeA, Extension)
;
type_contains_subtype(ModuleInfo, SubTypeA, SubTypeB),
- subsumed_by_2(ModuleInfo, AT, B, SubTypeA, Extension)
+ selector_subsumed_by_2(ModuleInfo, AT, B, SubTypeA, Extension)
)
;
% Symmetric with the previous case.
@@ -202,10 +210,10 @@ subsumed_by_2(ModuleInfo, A, B, Type, Extension) :-
SubTypeB = det_select_subtype(ModuleInfo, Type, ConsIdB, IndexB),
( SubTypeA = SubTypeB ->
% Both selectors agree on the subtype to select.
- subsumed_by_2(ModuleInfo, AT, BT, SubTypeB, Extension)
+ selector_subsumed_by_2(ModuleInfo, AT, BT, SubTypeB, Extension)
;
type_contains_subtype(ModuleInfo, SubTypeB, SubTypeA),
- subsumed_by_2(ModuleInfo, A, BT, SubTypeB, Extension)
+ selector_subsumed_by_2(ModuleInfo, A, BT, SubTypeB, Extension)
)
;
AH = typesel(SubTypeA),
@@ -215,12 +223,12 @@ subsumed_by_2(ModuleInfo, A, B, Type, Extension) :-
->
% Both selectors begin with type selectors and agree on the
% subtype to select.
- subsumed_by_2(ModuleInfo, AT, BT, SubTypeB, Extension)
+ selector_subsumed_by_2(ModuleInfo, AT, BT, SubTypeB, Extension)
;
% Assume we select node according to the B selector, then check
% that the rest of B subsumes A.
type_contains_subtype(ModuleInfo, SubTypeB, SubTypeA),
- subsumed_by_2(ModuleInfo, A, BT, SubTypeB, Extension0)
+ selector_subsumed_by_2(ModuleInfo, A, BT, SubTypeB, Extension0)
->
% Don't succeed for something like:
% A = [typesel(foo)],
@@ -234,7 +242,7 @@ subsumed_by_2(ModuleInfo, A, B, Type, Extension) :-
% Assume we select node according to the A selector, then check
% that B subsumes the rest of A.
type_contains_subtype(ModuleInfo, SubTypeA, SubTypeB),
- subsumed_by_2(ModuleInfo, AT, B, SubTypeA, Extension)
+ selector_subsumed_by_2(ModuleInfo, AT, B, SubTypeA, Extension)
)
)
).
@@ -304,7 +312,7 @@ type_of_node(ModuleInfo, StartType, Selector, SubType) :-
SubType = StartType
).
- % det_select_subtype(ModuleInfo, Type, ConsID, Position) = SubType.
+ % select_subtype(ModuleInfo, Type, ConsID, Position) = SubType.
% Determine the type of the type node selected from the type tree Type,
% selecting the specific constructor (ConsId), at position Position.
% Position counts starting from 1.
@@ -315,7 +323,7 @@ det_select_subtype(ModuleInfo, Type, ConsID, Position) = SubType :-
( select_subtype(ModuleInfo, Type, ConsID, Position, SubType0) ->
SubType = SubType0
;
- unexpected(this_file, "select_subtype: existential subtype")
+ throw(encounter_existential_subtype)
).
:- pred select_subtype(module_info::in, mer_type::in, cons_id::in, int::in,
@@ -430,11 +438,9 @@ selector_apply_widening(ModuleInfo, MainType, Selector0, Selector) :-
( type_of_node(ModuleInfo, MainType, Selector0, SubType) ->
Selector = [typesel(SubType)]
;
- % The node is existentially typed. Try for the type of the node's
- % parent instead.
- list.det_split_last(Selector0, ParentSelector, _),
- selector_apply_widening(ModuleInfo, MainType, ParentSelector,
- Selector)
+ % The node is existentially typed. Let's just leave the selector
+ % as-is.
+ Selector = Selector0
)
).
diff --git a/compiler/structure_reuse.domain.m b/compiler/structure_reuse.domain.m
index b726fec..b83eef9 100644
--- a/compiler/structure_reuse.domain.m
+++ b/compiler/structure_reuse.domain.m
@@ -392,14 +392,15 @@ reuse_condition_subsumed_by(ModuleInfo, ProcInfo, Cond1, Cond2) :-
%
set.subset(Nodes1, Nodes2),
- datastructs_subsumed_by_list(ModuleInfo, ProcInfo, LocalUse1,
- LocalUse2),
- sharing_as_is_subsumed_by(ModuleInfo,
- ProcInfo, LocalSharing1, LocalSharing2)
+ datastructs_subsumed_by_list(ModuleInfo, ProcInfo,
+ LocalUse1, LocalUse2),
+ sharing_as_is_subsumed_by(ModuleInfo, ProcInfo,
+ LocalSharing1, LocalSharing2)
).
:- pred reuse_condition_subsumed_by_list(module_info::in, proc_info::in,
reuse_condition::in, reuse_conditions::in) is semidet.
+
reuse_condition_subsumed_by_list(ModuleInfo, ProcInfo, Cond, [Cond1|Rest]) :-
(
reuse_condition_subsumed_by(ModuleInfo, ProcInfo, Cond, Cond1)
@@ -409,6 +410,7 @@ reuse_condition_subsumed_by_list(ModuleInfo, ProcInfo, Cond, [Cond1|Rest]) :-
:- pred reuse_conditions_subsume_reuse_condition(module_info::in,
proc_info::in, reuse_conditions::in, reuse_condition::in) is semidet.
+
reuse_conditions_subsume_reuse_condition(ModuleInfo, ProcInfo, Conds, Cond):-
reuse_condition_subsumed_by_list(ModuleInfo, ProcInfo, Cond, Conds).
@@ -448,7 +450,6 @@ reuse_as_short_description(unconditional) = "uncond".
reuse_as_short_description(conditional(Conds)) = "cond(" ++ Size ++ ")" :-
Size = string.int_to_string(list.length(Conds)).
-
reuse_as_subsumed_by(ModuleInfo, ProcInfo, FirstReuseAs, SecondReuseAs) :-
(
FirstReuseAs = no_reuse
diff --git a/compiler/structure_sharing.domain.m b/compiler/structure_sharing.domain.m
index 17ff275..c393370 100644
--- a/compiler/structure_sharing.domain.m
+++ b/compiler/structure_sharing.domain.m
@@ -313,13 +313,16 @@
:- import_module transform_hlds.ctgc.util.
:- import_module assoc_list.
+:- import_module exception.
:- import_module int.
:- import_module maybe.
:- import_module pair.
-:- import_module string.
:- import_module solutions.
+:- import_module string.
:- import_module svmap.
:- import_module svset.
+:- import_module unit.
+:- import_module univ.
:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -417,8 +420,24 @@ sharing_as_comb(ModuleInfo, ProcInfo, NewSharing, OldSharing) = ResultSharing :-
NewSharing = sharing_as_real_as(NewSharingSet),
(
OldSharing = sharing_as_real_as(OldSharingSet),
- ResultSharing = wrap(sharing_set_comb(ModuleInfo, ProcInfo,
- NewSharingSet, OldSharingSet))
+ promise_equivalent_solutions [MaybeExcp] (
+ try((pred(CombSet::out) is det :-
+ CombSet = sharing_set_comb(ModuleInfo, ProcInfo,
+ NewSharingSet, OldSharingSet)
+ ), MaybeExcp)
+ ),
+ (
+ MaybeExcp = succeeded(SharingSet),
+ ResultSharing = wrap(SharingSet)
+ ;
+ MaybeExcp = exception(Excp),
+ ( univ_to_type(Excp, encounter_existential_subtype) ->
+ Reason = top_cannot_improve("existential subtype"),
+ ResultSharing = sharing_as_top_sharing(Reason)
+ ;
+ rethrow(MaybeExcp)
+ )
+ )
;
OldSharing = sharing_as_bottom,
ResultSharing = NewSharing
@@ -715,9 +734,24 @@ sharing_as_least_upper_bound(ModuleInfo, ProcInfo, Sharing1, Sharing2)
Sharing = Sharing2
;
Sharing2 = sharing_as_real_as(SharingSet2),
- Sharing = sharing_as_real_as(
- sharing_set_least_upper_bound(ModuleInfo,
- ProcInfo, SharingSet1, SharingSet2))
+ promise_equivalent_solutions [MaybeExcp] (
+ try((pred(SharingSet3::out) is det :-
+ SharingSet3 = sharing_set_least_upper_bound(ModuleInfo,
+ ProcInfo, SharingSet1, SharingSet2)
+ ), MaybeExcp)
+ ),
+ (
+ MaybeExcp = succeeded(SharingSet),
+ Sharing = sharing_as_real_as(SharingSet)
+ ;
+ MaybeExcp = exception(Excp),
+ ( univ_to_type(Excp, encounter_existential_subtype) ->
+ Reason = top_cannot_improve("existential subtype"),
+ Sharing = sharing_as_top_sharing(Reason)
+ ;
+ rethrow(MaybeExcp)
+ )
+ )
)
).
@@ -1496,7 +1530,7 @@ sharing_set_subsumes_sharing_pair(ModuleInfo, ProcInfo, SharingSet,
] (
check_normalized(ModuleInfo, Type1, Sel)
),
- selector.subsumed_by(ModuleInfo, already_normalized,
+ selector_subsumed_by(ModuleInfo, already_normalized,
Sel1, Sel, Type1, Extension),
map.search(SelSharingMap, Sel, datastructures(_, DatastructureSet)),
@@ -1510,7 +1544,7 @@ sharing_set_subsumes_sharing_pair(ModuleInfo, ProcInfo, SharingSet,
] (
check_normalized(ModuleInfo, Type2, DatastructureSel)
),
- selector.subsumed_by(ModuleInfo, already_normalized,
+ selector_subsumed_by(ModuleInfo, already_normalized,
Sel2, DatastructureSel, Type2, Extension)
)
).
@@ -1558,7 +1592,7 @@ sharing_set_subsumed_subset(ModuleInfo, ProcInfo, SharingSet, SharingPair,
] (
check_normalized(ModuleInfo, Type1, Selector)
),
- selector.subsumed_by(ModuleInfo, already_normalized,
+ selector_subsumed_by(ModuleInfo, already_normalized,
Selector, Sel1, Type1, Extension),
map.search(SelSharingMap, Selector, Dataset),
Dataset = datastructures(_, Datastructs),
@@ -1572,7 +1606,7 @@ sharing_set_subsumed_subset(ModuleInfo, ProcInfo, SharingSet, SharingPair,
] (
check_normalized(ModuleInfo, Type2, DSel)
),
- selector.subsumed_by(ModuleInfo, already_normalized,
+ selector_subsumed_by(ModuleInfo, already_normalized,
DSel, Sel2, Type2, Extension),
Pair = datastruct_init_with_selector(Var1, Selector)
- D
@@ -1897,8 +1931,8 @@ basic_closure(ModuleInfo, ProcInfo, Type, NewDataSet, OldDataSet,
(
% NewSel <= OldSel ie, \exists Extension: OldSel.Extension = NewSel.
- selector.subsumed_by(ModuleInfo, already_normalized, NewSel, OldSel,
- Type, Extension)
+ selector_subsumed_by(ModuleInfo, already_normalized,
+ NewSel, OldSel, Type, Extension)
->
data_set_termshift(ModuleInfo, ProcInfo, OldDataSet, Extension,
TermShiftedOldDataSet),
@@ -1906,8 +1940,8 @@ basic_closure(ModuleInfo, ProcInfo, Type, NewDataSet, OldDataSet,
NewDataSet)
;
% OldSel <= NewSel ie, \exists Extension: NewSel.Extension = OldSel.
- selector.subsumed_by(ModuleInfo, already_normalized, OldSel, NewSel,
- Type, Extension)
+ selector_subsumed_by(ModuleInfo, already_normalized,
+ OldSel, NewSel, Type, Extension)
->
data_set_termshift(ModuleInfo, ProcInfo, NewDataSet, Extension,
TermShiftedNewDataSet),
@@ -1936,8 +1970,8 @@ selector_sharing_set_extend_datastruct_2(ModuleInfo, ProcInfo, VarType,
% to all the datastructs associated with Selector, and add them
% to the set of datastructs collected.
(
- selector.subsumed_by(ModuleInfo, need_normalization, BaseSelector,
- Selector, VarType, Extension)
+ selector_subsumed_by(ModuleInfo, need_normalization,
+ BaseSelector, Selector, VarType, Extension)
->
data_set_termshift(ModuleInfo, ProcInfo, Dataset0, Extension, Dataset),
Dataset = datastructures(_, Data),
diff --git a/compiler/type_util.m b/compiler/type_util.m
index 74478c9..8ead00d 100644
--- a/compiler/type_util.m
+++ b/compiler/type_util.m
@@ -200,7 +200,7 @@
:- pred get_cons_id_arg_types(module_info::in, mer_type::in,
cons_id::in, list(mer_type)::out) is det.
- % The same as gget_cons_id_arg_types except that it fails rather than
+ % The same as get_cons_id_arg_types except that it fails rather than
% aborting if the functor is existentially typed.
%
:- pred get_cons_id_non_existential_arg_types(module_info::in,
--------------------------------------------------------------------------
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