mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-19 11:23:46 +00:00
0d7c8a7654
*/*.m:
As above.
configure.ac:
Require the installed compiler to support this capability.
554 lines
20 KiB
Mathematica
554 lines
20 KiB
Mathematica
%---------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%---------------------------------------------------------------------------%
|
|
% Copyright (C) 2005-2006,2008-2012 The University of Melbourne.
|
|
% This file may only be copied under the terms of the GNU General
|
|
% Public License - see the file COPYING in the Mercury distribution.
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% File: ctgc.selector.m.
|
|
% Main author: nancy.
|
|
%
|
|
% Definition of predicates and functions for the manipulation of selectors.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- module transform_hlds.ctgc.selector.
|
|
:- interface.
|
|
|
|
:- import_module hlds.
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module parse_tree.
|
|
:- import_module parse_tree.prog_data.
|
|
:- import_module parse_tree.prog_data_pragma.
|
|
|
|
:- import_module io.
|
|
:- import_module list.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
% 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.
|
|
|
|
% Create a selector as either the top selector, a term selector,
|
|
% or a type selector.
|
|
%
|
|
:- func top_selector = selector.
|
|
:- func selector_init(cons_id, int) = selector.
|
|
:- func selector_init_from_list(list(mer_type)) = selector.
|
|
|
|
% Perform a termshift operation.
|
|
%
|
|
:- pred selector_termshift(selector::in, selector::in, selector::out) is det.
|
|
|
|
% 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
|
|
% Extension, such that Selector2.Extension = Selector1.
|
|
%
|
|
% The type specifies the type of the term to which the selectors refer.
|
|
%
|
|
:- pred selector_subsumed_by(module_info::in, normalization::in,
|
|
selector::in, selector::in, mer_type::in, selector::out) is semidet.
|
|
|
|
% As above but fail if the subtype would be an existential type instead of
|
|
% aborting.
|
|
%
|
|
:- pred type_of_node(module_info::in, mer_type::in, selector::in,
|
|
mer_type::out) is semidet.
|
|
|
|
% Using the type information of the variable to which the given selector
|
|
% belongs, normalize that selector.
|
|
% S2 is the normalized form of S1 iff:
|
|
% * type of the node selected by S2 = type of the node selected by S1.
|
|
% * a path of selectors can be constructed which leads from S2 to S1.
|
|
%
|
|
:- pred normalize_selector_with_type_information(module_info::in, mer_type::in,
|
|
selector::in, selector::out) is det.
|
|
|
|
% Abbreviate a selector to the type of the node it selects.
|
|
%
|
|
:- pred selector_apply_widening(module_info::in, mer_type::in,
|
|
selector::in, selector::out) is det.
|
|
|
|
% Reset memoisation tables used by this module.
|
|
%
|
|
:- pred reset_tables(io::di, io::uo) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module check_hlds.
|
|
:- import_module check_hlds.type_util.
|
|
:- import_module parse_tree.prog_type.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module bool.
|
|
:- import_module exception.
|
|
:- import_module map.
|
|
:- import_module pair.
|
|
:- import_module queue.
|
|
:- import_module require.
|
|
:- import_module set.
|
|
:- import_module solutions.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
top_selector = [].
|
|
|
|
selector_init(ConsId, Index) = [TermSel] :-
|
|
(
|
|
( ConsId = cons(_, _, _)
|
|
; ConsId = tuple_cons(_)
|
|
),
|
|
TermSel = termsel(ConsId, Index)
|
|
;
|
|
( ConsId = closure_cons(_, _)
|
|
; ConsId = some_int_const(_)
|
|
; ConsId = float_const(_)
|
|
; ConsId = char_const(_)
|
|
; ConsId = string_const(_)
|
|
; ConsId = impl_defined_const(_)
|
|
; ConsId = type_ctor_info_const(_, _, _)
|
|
; ConsId = base_typeclass_info_const(_, _, _, _)
|
|
; ConsId = type_info_cell_constructor(_)
|
|
; ConsId = typeclass_info_cell_constructor
|
|
; ConsId = type_info_const(_)
|
|
; ConsId = typeclass_info_const(_)
|
|
; ConsId = ground_term_const(_, _)
|
|
; ConsId = tabling_info_const(_)
|
|
; ConsId = table_io_entry_desc(_)
|
|
; ConsId = deep_profiling_proc_layout(_)
|
|
),
|
|
unexpected($pred, "cannot handle cons_id")
|
|
).
|
|
|
|
selector_init_from_list(Types)
|
|
= list.map((func(T) = typesel(T)), Types).
|
|
|
|
selector_termshift(S1, S2, S) :-
|
|
list.append(S1, S2, S).
|
|
|
|
selector_subsumed_by(ModuleInfo, Normalization, S1, S2, MainType, Extension) :-
|
|
% First make sure that both selectors are in a normalized form.
|
|
(
|
|
Normalization = already_normalized,
|
|
NormS1 = S1,
|
|
NormS2 = S2
|
|
;
|
|
Normalization = need_normalization,
|
|
normalize_selector_with_type_information(ModuleInfo, MainType,
|
|
S1, NormS1),
|
|
normalize_selector_with_type_information(ModuleInfo, MainType,
|
|
S2, NormS2)
|
|
),
|
|
( if
|
|
only_term_selectors(NormS1),
|
|
only_term_selectors(NormS2)
|
|
then
|
|
% Easy case.
|
|
term_selector_subsumed_by(NormS1, NormS2, Extension)
|
|
else
|
|
selector_subsumed_by_2(ModuleInfo, NormS1, NormS2, MainType, Extension)
|
|
).
|
|
|
|
:- pred only_term_selectors(selector::in) is semidet.
|
|
|
|
only_term_selectors([]).
|
|
only_term_selectors([H | T]) :-
|
|
H = termsel(_, _),
|
|
only_term_selectors(T).
|
|
|
|
% Both selectors must only contain term selectors.
|
|
%
|
|
:- pred term_selector_subsumed_by(selector::in, selector::in, selector::out)
|
|
is semidet.
|
|
|
|
term_selector_subsumed_by(S1, S2, Extension) :-
|
|
list.append(S2, Extension, S1).
|
|
|
|
% The general case of selector_subsumed_by, where either selector may
|
|
% contain type selectors.
|
|
%
|
|
:- pred selector_subsumed_by_2(module_info::in, selector::in, selector::in,
|
|
mer_type::in, selector::out) is semidet.
|
|
|
|
selector_subsumed_by_2(ModuleInfo, A, B, Type, Extension) :-
|
|
(
|
|
B = [],
|
|
Extension = A
|
|
;
|
|
A = [AH | AT],
|
|
B = [BH | BT],
|
|
( if
|
|
AH = termsel(ConsIdA, IndexA),
|
|
BH = termsel(ConsIdB, IndexB)
|
|
then
|
|
ConsIdA = ConsIdB,
|
|
IndexA = IndexB,
|
|
( if
|
|
Type = type_variable(_, _),
|
|
AT = BT
|
|
then
|
|
% XXX Avoid an assertion failure when trying to index arguments
|
|
% of a type variable. This is probably a hack.
|
|
Extension = []
|
|
else
|
|
% If both selectors begin with term selectors, clearly
|
|
% they must agree on the node to select for the selectors
|
|
% to be comparable.
|
|
SubType = det_select_subtype(ModuleInfo, Type, ConsIdA,
|
|
IndexA),
|
|
selector_subsumed_by_2(ModuleInfo, AT, BT, SubType, Extension)
|
|
)
|
|
else
|
|
% 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
|
|
% term selector. We also verify that the type of that node
|
|
% contains within it a node selectable by the type selector.
|
|
AH = termsel(ConsIdA, IndexA),
|
|
BH = typesel(SubTypeB),
|
|
SubTypeA = det_select_subtype(ModuleInfo, Type, ConsIdA, IndexA),
|
|
( if SubTypeA = SubTypeB then
|
|
% Both selectors agree on the subtype to select.
|
|
selector_subsumed_by_2(ModuleInfo, AT, BT, SubTypeA, Extension)
|
|
else
|
|
type_contains_subtype(ModuleInfo, SubTypeA, SubTypeB),
|
|
selector_subsumed_by_2(ModuleInfo, AT, B, SubTypeA, Extension)
|
|
)
|
|
;
|
|
% Symmetric with the previous case.
|
|
AH = typesel(SubTypeA),
|
|
BH = termsel(ConsIdB, IndexB),
|
|
SubTypeB = det_select_subtype(ModuleInfo, Type, ConsIdB, IndexB),
|
|
( if SubTypeA = SubTypeB then
|
|
% Both selectors agree on the subtype to select.
|
|
selector_subsumed_by_2(ModuleInfo, AT, BT, SubTypeB, Extension)
|
|
else
|
|
type_contains_subtype(ModuleInfo, SubTypeB, SubTypeA),
|
|
selector_subsumed_by_2(ModuleInfo, A, BT, SubTypeB, Extension)
|
|
)
|
|
;
|
|
AH = typesel(SubTypeA),
|
|
BH = typesel(SubTypeB),
|
|
( if
|
|
SubTypeA = SubTypeB
|
|
then
|
|
% Both selectors begin with type selectors and agree on the
|
|
% subtype to select.
|
|
selector_subsumed_by_2(ModuleInfo, AT, BT, SubTypeB, Extension)
|
|
else if
|
|
% Assume we select node according to the B selector, then check
|
|
% that the rest of B subsumes A.
|
|
type_contains_subtype(ModuleInfo, SubTypeB, SubTypeA),
|
|
selector_subsumed_by_2(ModuleInfo, A, BT, SubTypeB, Extension0)
|
|
then
|
|
% Don't succeed for something like:
|
|
% A = [typesel(foo)],
|
|
% B = [typesel(bar)],
|
|
% Ext = [typesel(foo)]
|
|
% i.e.
|
|
% [typesel(bar), typesel(foo)] = [typesel(bar)]
|
|
Extension0 \= A,
|
|
Extension = Extension0
|
|
else
|
|
% Assume we select node according to the A selector, then check
|
|
% that B subsumes the rest of A.
|
|
type_contains_subtype(ModuleInfo, SubTypeA, SubTypeB),
|
|
selector_subsumed_by_2(ModuleInfo, AT, B, SubTypeA, Extension)
|
|
)
|
|
)
|
|
).
|
|
|
|
% type_contains_subtype(ModuleInfo, FromType, ToType).
|
|
%
|
|
% Succeed iff starting from FromType we can reach a node ToType.
|
|
%
|
|
% XXX I didn't think about type variables when writing this.
|
|
%
|
|
:- pred type_contains_subtype(module_info::in, mer_type::in, mer_type::in)
|
|
is semidet.
|
|
|
|
type_contains_subtype(ModuleInfo, FromType, ToType) :-
|
|
( if FromType = ToType then
|
|
true
|
|
else
|
|
type_contains_subtype_1(ModuleInfo, FromType, ToType, Contains),
|
|
Contains = yes
|
|
).
|
|
|
|
:- pred type_contains_subtype_1(module_info::in, mer_type::in, mer_type::in,
|
|
bool::out) is det.
|
|
|
|
% We assume that type definitions for a module don't change for the
|
|
% duration of the analysis.
|
|
%
|
|
:- pragma memo(pred(type_contains_subtype_1/4),
|
|
[allow_reset, disable_warning_if_ignored,
|
|
specified([promise_implied, value, value, output])]).
|
|
|
|
type_contains_subtype_1(ModuleInfo, FromType, ToType, Contains) :-
|
|
queue.put(FromType, queue.init, Queue0),
|
|
type_contains_subtype_2(ModuleInfo, ToType, Queue0, _Queue,
|
|
set.init, _SeenTypes, Contains).
|
|
|
|
% We perform a breadth-first search, keeping track of the types that
|
|
% already seen, to avoid some really bad performance when performing
|
|
% structure sharing analysis on some modules.
|
|
%
|
|
:- pred type_contains_subtype_2(module_info::in, mer_type::in,
|
|
queue(mer_type)::in, queue(mer_type)::out,
|
|
set(mer_type)::in, set(mer_type)::out, bool::out) is det.
|
|
|
|
type_contains_subtype_2(ModuleInfo, ToType, !Queue, !SeenTypes, Contains) :-
|
|
( if queue.get(FromType, !Queue) then
|
|
( if set.contains(!.SeenTypes, FromType) then
|
|
disable_warning [suspicious_recursion] (
|
|
type_contains_subtype_2(ModuleInfo, ToType,
|
|
!Queue, !SeenTypes, Contains)
|
|
)
|
|
else
|
|
set.insert(FromType, !SeenTypes),
|
|
type_arg_types(ModuleInfo, FromType, ArgTypes),
|
|
( if list.member(ToType, ArgTypes) then
|
|
Contains = yes
|
|
else
|
|
queue.put_list(ArgTypes, !Queue),
|
|
disable_warning [suspicious_recursion] (
|
|
type_contains_subtype_2(ModuleInfo, ToType,
|
|
!Queue, !SeenTypes, Contains)
|
|
)
|
|
)
|
|
)
|
|
else
|
|
Contains = no
|
|
).
|
|
|
|
:- pred type_arg_types(module_info::in, mer_type::in, list(mer_type)::out)
|
|
is det.
|
|
|
|
:- pragma memo(pred(type_arg_types/3),
|
|
[allow_reset, disable_warning_if_ignored,
|
|
specified([promise_implied, value, output])]).
|
|
|
|
type_arg_types(ModuleInfo, Type, ArgTypes) :-
|
|
solutions(
|
|
( pred(ConsIdArgTypes::out) is nondet :-
|
|
cons_id_arg_types(ModuleInfo, Type, _ConsId, ConsIdArgTypes)
|
|
), ArgTypesLists),
|
|
list.condense(ArgTypesLists, ArgTypes).
|
|
|
|
type_of_node(ModuleInfo, StartType, Selector, SubType) :-
|
|
(
|
|
Selector = [UnitSelector | RestSelector],
|
|
(
|
|
UnitSelector = termsel(ConsId, Index),
|
|
select_subtype(ModuleInfo, StartType, ConsId, Index, SubType0)
|
|
;
|
|
UnitSelector = typesel(SubType0)
|
|
),
|
|
type_of_node(ModuleInfo, SubType0, RestSelector, SubType)
|
|
;
|
|
Selector = [],
|
|
SubType = StartType
|
|
).
|
|
|
|
% 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.
|
|
%
|
|
:- func det_select_subtype(module_info, mer_type, cons_id, int) = mer_type.
|
|
|
|
det_select_subtype(ModuleInfo, Type, ConsID, Position) = SubType :-
|
|
( if select_subtype(ModuleInfo, Type, ConsID, Position, SubType0) then
|
|
SubType = SubType0
|
|
else
|
|
throw(encounter_existential_subtype)
|
|
).
|
|
|
|
:- pred select_subtype(module_info::in, mer_type::in, cons_id::in, int::in,
|
|
mer_type::out) is semidet.
|
|
|
|
select_subtype(ModuleInfo, Type, ConsID, Position, SubType) :-
|
|
( if
|
|
get_cons_id_non_existential_arg_types(ModuleInfo, Type, ConsID,
|
|
ArgTypes)
|
|
then
|
|
SubType = list.det_index1(ArgTypes, Position)
|
|
else if
|
|
get_existq_cons_defn(ModuleInfo, Type, ConsID, CtorDefn)
|
|
then
|
|
CtorDefn = ctor_defn(_TVarSet, _KindMap, MaybeExistConstraints,
|
|
ArgTypes, _RetType),
|
|
(
|
|
MaybeExistConstraints = no_exist_constraints,
|
|
% XXX Should be able to optimise following test.
|
|
ExistQVars = []
|
|
;
|
|
MaybeExistConstraints = exist_constraints(
|
|
cons_exist_constraints(ExistQVars, _, _, _))
|
|
),
|
|
SubType = list.det_index1(ArgTypes, Position),
|
|
not (
|
|
SubType = type_variable(TVar, _),
|
|
list.member(TVar, ExistQVars)
|
|
)
|
|
else
|
|
unexpected($pred, "type is both existential and non-existential")
|
|
).
|
|
|
|
:- pragma memo(pred(normalize_selector_with_type_information/4),
|
|
[allow_reset, disable_warning_if_ignored,
|
|
specified([promise_implied, value, value, output])]).
|
|
|
|
normalize_selector_with_type_information(ModuleInfo, Type, !Selector) :-
|
|
( if is_introduced_type_info_type(Type) then
|
|
true
|
|
else
|
|
branch_map_init(BranchMap0),
|
|
branch_map_insert(Type, top_selector, BranchMap0, BranchMap1),
|
|
do_normalize_selector(ModuleInfo, Type, BranchMap1, top_selector,
|
|
!Selector)
|
|
).
|
|
|
|
:- pred do_normalize_selector(module_info::in, mer_type::in,
|
|
branch_map::in, selector::in, selector::in, selector::out) is det.
|
|
|
|
do_normalize_selector(ModuleInfo, VarType, BranchMap0,
|
|
SelectorAcc0, !Selector) :-
|
|
(
|
|
!.Selector = [UnitSelector | SelRest],
|
|
CtorCat = classify_type(ModuleInfo, VarType),
|
|
( if CtorCat = ctor_cat_user(CatUser) then
|
|
(
|
|
( CatUser = cat_user_general
|
|
; CatUser = cat_user_notag
|
|
; CatUser = cat_user_abstract_notag
|
|
)
|
|
;
|
|
CatUser = cat_user_direct_dummy,
|
|
% We should not be producing selectors for dummy types.
|
|
unexpected($pred, "cat_user_direct_dummy")
|
|
;
|
|
CatUser = cat_user_abstract_dummy,
|
|
% We should not be producing selectors for dummy types.
|
|
unexpected($pred, "cat_user_abstract_dummy")
|
|
),
|
|
|
|
% If it is either a term-selector of a non-existentially typed
|
|
% functor or is a type-selector, construct the branch map and
|
|
% proceed with normalization. If it is a term-selector of an
|
|
% existentially typed functor, then normalization stops.
|
|
( if
|
|
(
|
|
UnitSelector = termsel(ConsId, Index),
|
|
get_cons_id_non_existential_arg_types(ModuleInfo,
|
|
VarType, ConsId, ArgTypes),
|
|
( if list.index1(ArgTypes, Index, SubType) then
|
|
CType = SubType
|
|
else
|
|
unexpected($pred, "accessing nonexistent index")
|
|
)
|
|
;
|
|
UnitSelector = typesel(CType)
|
|
)
|
|
then
|
|
!:Selector = SelRest,
|
|
( if branch_map_search(BranchMap0, CType, BranchSelector) then
|
|
do_normalize_selector(ModuleInfo, CType, BranchMap0,
|
|
BranchSelector, !Selector)
|
|
else
|
|
selector_termshift(SelectorAcc0, [UnitSelector],
|
|
SelectorAcc1),
|
|
branch_map_insert(CType, SelectorAcc1,
|
|
BranchMap0, BranchMap1),
|
|
do_normalize_selector(ModuleInfo, CType, BranchMap1,
|
|
SelectorAcc1, !Selector)
|
|
)
|
|
else
|
|
% Existentially typed functor.
|
|
% XXX awaiting confirmation on this from Nancy but it seems
|
|
% right to me --pw
|
|
append(SelectorAcc0, [UnitSelector], !:Selector)
|
|
)
|
|
else
|
|
% If it is not a user type, SelRest is empty anyhow, and
|
|
% normalization stops.
|
|
% Resulting selector = accumulator.sel0
|
|
append(SelectorAcc0, !Selector)
|
|
)
|
|
;
|
|
!.Selector = [],
|
|
!:Selector = SelectorAcc0
|
|
).
|
|
|
|
selector_apply_widening(ModuleInfo, MainType, Selector0, Selector) :-
|
|
(
|
|
Selector0 = [],
|
|
Selector = []
|
|
;
|
|
Selector0 = [_ | _],
|
|
( if type_of_node(ModuleInfo, MainType, Selector0, SubType) then
|
|
Selector = [typesel(SubType)]
|
|
else
|
|
% The node is existentially typed. Let's just leave the selector
|
|
% as-is.
|
|
Selector = Selector0
|
|
)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%
|
|
% BRANCH_MAP : copy/pasted from wimvh/bta_reduce.m
|
|
%
|
|
|
|
:- type branch_map == assoc_list(mer_type, selector).
|
|
|
|
:- pred branch_map_init(branch_map::out) is det.
|
|
|
|
branch_map_init([]).
|
|
|
|
:- pred branch_map_insert(mer_type::in, selector::in,
|
|
branch_map::in, branch_map::out) is det.
|
|
|
|
branch_map_insert(Type, Sel, TypeSels, [Type - Sel | TypeSels]).
|
|
|
|
:- pred branch_map_search(branch_map::in, mer_type::in, selector::out)
|
|
is semidet.
|
|
|
|
branch_map_search([Type - Sel | TypeSels], KeyType, ValueSel):-
|
|
map.init(Empty),
|
|
% The two types are considered equal if they unify under an
|
|
% empty substitution.
|
|
( if
|
|
type_unify(Type, KeyType, [], Empty, Subst),
|
|
map.is_empty(Subst)
|
|
then
|
|
ValueSel = Sel
|
|
else
|
|
branch_map_search(TypeSels, KeyType, ValueSel)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
reset_tables(!IO) :-
|
|
table_reset_for_type_contains_subtype_1_4(!IO),
|
|
table_reset_for_type_arg_types_3(!IO),
|
|
table_reset_for_normalize_selector_with_type_information_4(!IO).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
:- end_module transform_hlds.ctgc.selector.
|
|
%---------------------------------------------------------------------------%
|