mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-16 09:53:36 +00:00
625ec287f1
compiler/prog_type_construct.m:
New module for constructing types.
compiler/prog_type_repn.m:
New module for testing things related to type representation.
compiler/prog_type_scan.m:
New module for gather type vars in types.
compiler/prog_type_test.m:
New module containing simple tests on types.
compiler/prog_type_unify.m:
New module for testing whether two types unify, or whether
one type subsumes another.
compiler/prog_type.m:
Delete the code moved to the new modules.
compiler/parse_tree.m:
Include the new modules.
compiler/notes/compiler_design.html:
Document the new modules.
compiler/*.m:
Conform to the changes above, by adjusting imports as needed,
and by deleting any explicit module qualifications that
this diff makes obsolete.
555 lines
20 KiB
Mathematica
555 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 parse_tree.prog_type_unify.
|
|
|
|
:- 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.
|
|
%---------------------------------------------------------------------------%
|