mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-20 08:19:28 +00:00
Code Issues Projects Releases Wiki Activity
Files
dae82a8409d4e589e2004c97d713494cc01b7d2c
mercury/compiler/equiv_type.m
Ralph Becket e47e33cf2a Ensure that equivalence types and insts in mutable items are properly 
Estimated hours taken: 4
Branches: main

Ensure that equivalence types and insts in mutable items are properly
expanded.

compiler/equiv_type.m
	Make replace_in_item handle mutable/5 items.

compiler/make_hlds_passes.m
	Delete an out-of-date comment.

compiler/modules.m
	Fix a comment typo.

compiler/recompilation.m
compiler/recompilation.usage.m
	Add a new item_type for mutables (the equiv_type.m transformation
	needs to track the items where expansions occurr).
2005-11-11 05:06:50 +00:00

1055 lines
39 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1996-2005 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.
%-----------------------------------------------------------------------------%
% This module contains a parse-tree to parse-tree transformation
% that expands equivalence types. It also expands away `with_type`
% and `with_inst` annotations on predicate and function type declarations.
% main author: fjh
:- module parse_tree__equiv_type.
:- interface.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
:- import_module recompilation.
:- import_module bool.
:- import_module io.
:- import_module list.
:- import_module map.
:- import_module std_util.
%-----------------------------------------------------------------------------%
% expand_eqv_types(ModuleName, Items0, Items,
% CircularTypes, EqvMap, MaybeRecompInfo0, MaybeRecompInfo).
%
% First it builds up a map from type_ctor to the equivalent type.
% Then it traverses through the list of items, expanding all types.
% This has the effect of eliminating all the equivalence types
% from the source code.
%
% `with_type` and `with_inst` annotations on predicate and
% function type declarations are also expaneded.
%
% Error messages are generated for any circular equivalence types
% and invalid `with_type` and `with_inst` annotations.
%
% For items not defined in the current module, the items expanded
% while processing each item are recorded in the recompilation_info,
% for use by smart recompilation.
%
:- pred expand_eqv_types(module_name::in,
list(item_and_context)::in, list(item_and_context)::out,
bool::out, eqv_map::out,
maybe(recompilation_info)::in, maybe(recompilation_info)::out,
io::di, io::uo) is det.
% Replace equivalence types in a given type.
% The bool output is `yes' if anything changed.
%
:- pred replace_in_type(eqv_map::in, mer_type::in, mer_type::out,
bool::out, tvarset::in, tvarset::out,
equiv_type_info::in, equiv_type_info::out) is det.
:- pred replace_in_type_list(eqv_map::in,
list(mer_type)::in, list(mer_type)::out, bool::out,
tvarset::in, tvarset::out,
equiv_type_info::in, equiv_type_info::out) is det.
:- pred replace_in_prog_constraints(eqv_map::in,
prog_constraints::in, prog_constraints::out,
tvarset::in, tvarset::out, equiv_type_info::in, equiv_type_info::out)
is det.
:- pred replace_in_prog_constraint(eqv_map::in,
prog_constraint::in, prog_constraint::out, tvarset::in, tvarset::out,
equiv_type_info::in, equiv_type_info::out) is det.
:- pred replace_in_ctors(eqv_map::in,
list(constructor)::in, list(constructor)::out,
tvarset::in, tvarset::out, equiv_type_info::in, equiv_type_info::out)
is det.
:- type eqv_type_body ---> eqv_type_body(tvarset, list(type_param), mer_type).
:- type eqv_map == map(type_ctor, eqv_type_body).
:- type equiv_type_info == maybe(expanded_item_set).
:- type expanded_item_set.
% For smart recompilation we need to record which items were
% expanded in each declaration. Any items which depend on
% that declaration also depend on the expanded items.
%
:- pred maybe_record_expanded_items(module_name::in, sym_name::in,
maybe(recompilation_info)::in, equiv_type_info::out) is det.
% Record all the expanded items in the recompilation_info.
%
:- pred finish_recording_expanded_items(item_id::in,
equiv_type_info::in, maybe(recompilation_info)::in,
maybe(recompilation_info)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module libs.compiler_util.
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_util.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_subst.
:- import_module assoc_list.
:- import_module bool.
:- import_module map.
:- import_module require.
:- import_module set.
:- import_module std_util.
:- import_module svmap.
:- import_module term.
:- import_module varset.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
% First we build up a mapping which records the equivalence type
% definitions. Then we go through the item list and replace them.
%
expand_eqv_types(ModuleName, Items0, Items, Error, EqvMap, !Info, !IO) :-
map__init(EqvMap0),
map__init(EqvInstMap0),
build_eqv_map(Items0, EqvMap0, EqvMap, EqvInstMap0, EqvInstMap),
replace_in_item_list(ModuleName, Items0, EqvMap, EqvInstMap,
[], RevItems, [], ErrorList, !Info),
list__reverse(RevItems, Items),
(
ErrorList = [],
Error = no
;
ErrorList = [_ | _],
list__foldl(report_error, list__reverse(ErrorList), !IO),
Error = yes,
io__set_exit_status(1, !IO)
).
% We need to expand equivalence insts in
% `:- pred p `with_inst` i' declarations.
:- type eqv_inst_body
---> eqv_inst_body(
inst_varset,
list(inst_var),
mer_inst
).
:- type eqv_inst_map == map(inst_id, eqv_inst_body).
:- type pred_or_func_decl_type
---> type_decl
; mode_decl.
:- type eqv_error == pair(eqv_error_type, prog_context).
:- type eqv_error_type
---> circular_equivalence(item)
; invalid_with_type(sym_name, pred_or_func)
; invalid_with_inst(pred_or_func_decl_type,
sym_name, maybe(pred_or_func))
; non_matching_with_type_with_inst(sym_name, pred_or_func).
:- pred build_eqv_map(list(item_and_context)::in,
eqv_map::in, eqv_map::out, eqv_inst_map::in, eqv_inst_map::out) is det.
build_eqv_map([], !EqvMap, !EqvInstMap).
build_eqv_map([Item - _Context | Items0], !EqvMap, !EqvInstMap) :-
( Item = module_defn(_, abstract_imported) ->
skip_abstract_imported_items(Items0, Items)
; Item = type_defn(VarSet, Name, Args, eqv_type(Body), _Cond) ->
Items = Items0,
list__length(Args, Arity),
svmap__set(Name - Arity, eqv_type_body(VarSet, Args, Body), !EqvMap)
; Item = inst_defn(VarSet, Name, Args, eqv_inst(Body), _) ->
Items = Items0,
list__length(Args, Arity),
svmap__set(Name - Arity, eqv_inst_body(VarSet, Args, Body),
!EqvInstMap)
;
Items = Items0
),
build_eqv_map(Items, !EqvMap, !EqvInstMap).
:- pred skip_abstract_imported_items(list(item_and_context)::in,
list(item_and_context)::out) is det.
skip_abstract_imported_items([], []).
skip_abstract_imported_items([Item - _ | Items0], Items) :-
(
Item = module_defn(_, Defn),
is_section_defn(Defn) = yes,
Defn \= abstract_imported
->
Items = Items0
;
skip_abstract_imported_items(Items0, Items)
).
:- func is_section_defn(module_defn) = bool.
is_section_defn(module(_)) = yes.
is_section_defn(end_module(_)) = yes.
is_section_defn(interface) = yes.
is_section_defn(implementation) = yes.
is_section_defn(private_interface) = yes.
is_section_defn(imported(_)) = yes.
is_section_defn(used(_)) = yes.
is_section_defn(abstract_imported) = yes.
is_section_defn(opt_imported) = yes.
is_section_defn(transitively_imported) = yes.
is_section_defn(external(_, _)) = no.
is_section_defn(export(_)) = no.
is_section_defn(import(_)) = no.
is_section_defn(use(_)) = no.
is_section_defn(include_module(_)) = no.
is_section_defn(version_numbers(_, _)) = no.
% The following predicate replace_in_item_list
% performs substititution of equivalence types on a list
% of items. Similarly the replace_in_<foo> predicates that
% follow perform substitution of equivalence types on <foo>s.
%
:- pred replace_in_item_list(module_name::in,
list(item_and_context)::in, eqv_map::in, eqv_inst_map::in,
list(item_and_context)::in, list(item_and_context)::out,
list(eqv_error)::in, list(eqv_error)::out,
maybe(recompilation_info)::in, maybe(recompilation_info)::out) is det.
replace_in_item_list(_, [], _, _, !Items, !Errors, !Info).
replace_in_item_list(ModuleName, [ItemAndContext0 | Items0],
EqvMap, EqvInstMap, !ReplItems, !Errors, !Info) :-
ItemAndContext0 = Item0 - Context,
(
replace_in_item(ModuleName, Item0, Context, EqvMap,
EqvInstMap, Item, NewErrors, !Info)
->
ItemAndContext = Item - Context,
% Discard the item if there were any errors.
(
NewErrors = [],
!:ReplItems = [ItemAndContext | !.ReplItems]
;
NewErrors = [_ | _]
),
!:Errors = NewErrors ++ !.Errors
;
ItemAndContext = ItemAndContext0,
!:ReplItems = [ItemAndContext | !.ReplItems]
),
replace_in_item_list(ModuleName, Items0, EqvMap,
EqvInstMap, !ReplItems, !Errors, !Info).
:- pred replace_in_item(module_name::in, item::in,
prog_context::in, eqv_map::in, eqv_inst_map::in, item::out,
list(eqv_error)::out,
maybe(recompilation_info)::in, maybe(recompilation_info)::out) is semidet.
replace_in_item(ModuleName,
type_defn(VarSet0, Name, TArgs, TypeDefn0, Cond) @ Item,
Context, EqvMap, _EqvInstMap,
type_defn(VarSet, Name, TArgs, TypeDefn, Cond),
Error, !Info) :-
list__length(TArgs, Arity),
maybe_record_expanded_items(ModuleName, Name,
!.Info, UsedTypeCtors0),
replace_in_type_defn(EqvMap, Name - Arity, TypeDefn0,
TypeDefn, ContainsCirc, VarSet0, VarSet,
UsedTypeCtors0, UsedTypeCtors),
(
ContainsCirc = yes,
Error = [circular_equivalence(Item) - Context]
;
ContainsCirc = no,
Error = []
),
finish_recording_expanded_items(
item_id(type_body_item, Name - Arity), UsedTypeCtors, !Info).
replace_in_item(ModuleName,
pred_or_func(TypeVarSet0, InstVarSet, ExistQVars, PredOrFunc,
PredName, TypesAndModes0, MaybeWithType0,
MaybeWithInst0, Det0, Cond, Purity, ClassContext0),
Context, EqvMap, EqvInstMap,
pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
PredName, TypesAndModes, MaybeWithType,
MaybeWithInst, Det, Cond, Purity, ClassContext),
Errors, !Info) :-
maybe_record_expanded_items(ModuleName, PredName,
!.Info, ExpandedItems0),
replace_in_pred_type(PredName, PredOrFunc, Context, EqvMap,
EqvInstMap, ClassContext0, ClassContext,
TypesAndModes0, TypesAndModes, TypeVarSet0, TypeVarSet,
MaybeWithType0, MaybeWithType, MaybeWithInst0, MaybeWithInst,
Det0, Det, ExpandedItems0, ExpandedItems, Errors),
ItemType = pred_or_func_to_item_type(PredOrFunc),
list__length(TypesAndModes, Arity),
adjust_func_arity(PredOrFunc, OrigArity, Arity),
finish_recording_expanded_items(
item_id(ItemType, PredName - OrigArity), ExpandedItems, !Info).
replace_in_item(ModuleName,
pred_or_func_mode(InstVarSet, MaybePredOrFunc0, PredName,
Modes0, WithInst0, Det0, Cond),
Context, _EqvMap, EqvInstMap,
pred_or_func_mode(InstVarSet, MaybePredOrFunc, PredName,
Modes, WithInst, Det, Cond),
Errors, !Info) :-
maybe_record_expanded_items(ModuleName, PredName,
!.Info, ExpandedItems0),
replace_in_pred_mode(PredName, length(Modes0), Context,
mode_decl, EqvInstMap, MaybePredOrFunc0, MaybePredOrFunc,
ExtraModes, WithInst0, WithInst, Det0, Det,
ExpandedItems0, ExpandedItems, Errors),
(
ExtraModes = [],
Modes = Modes0
;
ExtraModes = [_ | _],
Modes = Modes0 ++ ExtraModes
),
(
MaybePredOrFunc = yes(PredOrFunc),
ItemType = pred_or_func_to_item_type(PredOrFunc),
list__length(Modes, Arity),
adjust_func_arity(PredOrFunc, OrigArity, Arity),
finish_recording_expanded_items(
item_id(ItemType, PredName - OrigArity), ExpandedItems, !Info)
;
MaybePredOrFunc = no
).
replace_in_item(ModuleName,
typeclass(Constraints0, FunDeps, ClassName, Vars,
ClassInterface0, VarSet0),
_Context, EqvMap, EqvInstMap,
typeclass(Constraints, FunDeps, ClassName, Vars,
ClassInterface, VarSet),
Errors, !Info) :-
list__length(Vars, Arity),
maybe_record_expanded_items(ModuleName, ClassName,
!.Info, ExpandedItems0),
replace_in_prog_constraint_list(EqvMap,
Constraints0, Constraints, VarSet0, VarSet,
ExpandedItems0, ExpandedItems1),
(
ClassInterface0 = abstract,
ClassInterface = abstract,
ExpandedItems = ExpandedItems1,
Errors = []
;
ClassInterface0 = concrete(Methods0),
replace_in_class_interface(Methods0, EqvMap, EqvInstMap,
Methods, [], Errors, ExpandedItems1, ExpandedItems),
ClassInterface = concrete(Methods)
),
finish_recording_expanded_items(item_id(typeclass_item, ClassName - Arity),
ExpandedItems, !Info).
replace_in_item(ModuleName,
instance(Constraints0, ClassName, Ts0, InstanceBody, VarSet0, ModName),
_Context, EqvMap, _EqvInstMap,
instance(Constraints, ClassName, Ts, InstanceBody, VarSet, ModName),
[], !Info) :-
(
( !.Info = no
; ModName = ModuleName
)
->
UsedTypeCtors0 = no
;
UsedTypeCtors0 = yes(ModuleName - set__init)
),
replace_in_prog_constraint_list(EqvMap,
Constraints0, Constraints, VarSet0, VarSet1,
UsedTypeCtors0, UsedTypeCtors1),
replace_in_type_list(EqvMap, Ts0, Ts, _, _,
VarSet1, VarSet, UsedTypeCtors1, UsedTypeCtors),
list__length(Ts0, Arity),
finish_recording_expanded_items(
item_id(typeclass_item, ClassName - Arity), UsedTypeCtors, !Info).
replace_in_item(ModuleName,
pragma(Origin, type_spec(PredName, B, Arity, D, E,
Subst0, VarSet0, ItemIds0)),
_Context, EqvMap, _EqvInstMap,
pragma(Origin, type_spec(PredName, B, Arity, D, E,
Subst, VarSet, ItemIds)),
[], !Info) :-
(
( !.Info = no
; PredName = qualified(ModuleName, _)
)
->
ExpandedItems0 = no
;
ExpandedItems0 = yes(ModuleName - ItemIds0)
),
replace_in_subst(EqvMap, Subst0, Subst, VarSet0, VarSet,
ExpandedItems0, ExpandedItems),
(
ExpandedItems = no,
ItemIds = ItemIds0
;
ExpandedItems = yes(_ - ItemIds)
).
replace_in_item(ModuleName,
mutable(MutName, Type0, InitValue, Inst0, Attrs),
_Context, EqvMap, EqvInstMap,
mutable(MutName, Type, InitValue, Inst, Attrs),
[], !Info) :-
QualName = qualified(ModuleName, MutName),
maybe_record_expanded_items(ModuleName, QualName, !.Info, ExpandedItems0),
TVarSet0 = varset__init,
replace_in_type(EqvMap, Type0, Type, _TypeChanged, TVarSet0, _TVarSet,
ExpandedItems0, ExpandedItems1),
replace_in_inst(Inst0, EqvInstMap, Inst,
ExpandedItems1, ExpandedItems),
finish_recording_expanded_items(
item_id(mutable_item, QualName - 0), ExpandedItems, !Info).
:- pred replace_in_type_defn(eqv_map::in, type_ctor::in,
type_defn::in, type_defn::out, bool::out, tvarset::in, tvarset::out,
equiv_type_info::in, equiv_type_info::out) is semidet.
replace_in_type_defn(EqvMap, TypeCtor, eqv_type(TBody0),
eqv_type(TBody), ContainsCirc, !VarSet, !Info) :-
replace_in_type_2(EqvMap, [TypeCtor], TBody0, TBody,
_, ContainsCirc, !VarSet, !Info).
replace_in_type_defn(EqvMap, _,
du_type(TBody0, EqPred),
du_type(TBody, EqPred), no, !VarSet, !Info) :-
replace_in_ctors(EqvMap, TBody0, TBody, !VarSet, !Info).
replace_in_type_defn(EqvMap, TypeCtor,
solver_type(SolverTypeDetails0, MaybeUserEqComp),
solver_type(SolverTypeDetails, MaybeUserEqComp),
ContainsCirc, !VarSet, !Info) :-
SolverTypeDetails0 = solver_type_details(RepresentationType0, InitPred,
GroundInst, AnyInst),
replace_in_type_2(EqvMap, [TypeCtor],
RepresentationType0, RepresentationType,
_, ContainsCirc, !VarSet, !Info),
SolverTypeDetails = solver_type_details(RepresentationType, InitPred,
GroundInst, AnyInst).
%-----------------------------------------------------------------------------%
replace_in_prog_constraints(EqvMap, Cs0, Cs, !VarSet, !Info) :-
Cs0 = constraints(UnivCs0, ExistCs0),
Cs = constraints(UnivCs, ExistCs),
replace_in_prog_constraint_list(EqvMap, UnivCs0, UnivCs, !VarSet, !Info),
replace_in_prog_constraint_list(EqvMap, ExistCs0, ExistCs, !VarSet, !Info).
:- pred replace_in_prog_constraint_list(eqv_map::in,
list(prog_constraint)::in, list(prog_constraint)::out,
tvarset::in, tvarset::out, equiv_type_info::in, equiv_type_info::out)
is det.
replace_in_prog_constraint_list(EqvMap, !Cs, !VarSet, !Info) :-
list__map_foldl2(replace_in_prog_constraint(EqvMap), !Cs, !VarSet, !Info).
replace_in_prog_constraint(EqvMap, Constraint0, Constraint, !VarSet, !Info) :-
Constraint0 = constraint(ClassName, Ts0),
replace_in_type_list(EqvMap, Ts0, Ts, _, _, !VarSet, !Info),
Constraint = constraint(ClassName, Ts).
%-----------------------------------------------------------------------------%
:- pred replace_in_class_interface(list(class_method)::in,
eqv_map::in, eqv_inst_map::in, list(class_method)::out,
list(eqv_error)::in, list(eqv_error)::out,
equiv_type_info::in, equiv_type_info::out) is det.
replace_in_class_interface(ClassInterface0, EqvMap, EqvInstMap,
ClassInterface, !Errors, !Info) :-
list__map_foldl2(replace_in_class_method(EqvMap, EqvInstMap),
ClassInterface0, ClassInterface, !Errors, !Info).
:- pred replace_in_class_method(eqv_map::in, eqv_inst_map::in,
class_method::in, class_method::out,
list(eqv_error)::in, list(eqv_error)::out,
equiv_type_info::in, equiv_type_info::out) is det.
replace_in_class_method(EqvMap, EqvInstMap,
pred_or_func(TypeVarSet0, InstVarSet, ExistQVars, PredOrFunc,
PredName, TypesAndModes0, WithType0, WithInst0,
Det0, Cond, Purity, ClassContext0, Context),
pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
PredName, TypesAndModes, WithType, WithInst,
Det, Cond, Purity, ClassContext, Context),
!Errors, !Info) :-
replace_in_pred_type(PredName, PredOrFunc, Context, EqvMap,
EqvInstMap, ClassContext0, ClassContext,
TypesAndModes0, TypesAndModes, TypeVarSet0, TypeVarSet,
WithType0, WithType, WithInst0, WithInst, Det0, Det, !Info, NewErrors),
!:Errors = NewErrors ++ !.Errors.
replace_in_class_method(_, EqvInstMap,
pred_or_func_mode(InstVarSet, MaybePredOrFunc0, PredName,
Modes0, WithInst0, Det0, Cond, Context),
pred_or_func_mode(InstVarSet, MaybePredOrFunc, PredName,
Modes, WithInst, Det, Cond, Context),
!Errors, !Info) :-
replace_in_pred_mode(PredName, length(Modes0), Context,
mode_decl, EqvInstMap, MaybePredOrFunc0, MaybePredOrFunc,
ExtraModes, WithInst0, WithInst, Det0, Det, !Info, NewErrors),
(
ExtraModes = [],
Modes = Modes0
;
ExtraModes = [_ | _],
Modes = Modes0 ++ ExtraModes
),
!:Errors = NewErrors ++ !.Errors.
%-----------------------------------------------------------------------------%
:- pred replace_in_subst(eqv_map::in,
assoc_list(tvar, mer_type)::in, assoc_list(tvar, mer_type)::out,
tvarset::in, tvarset::out, equiv_type_info::in, equiv_type_info::out)
is det.
replace_in_subst(_EqvMap, [], [], !VarSet, !Info).
replace_in_subst(EqvMap, [Var - Type0 | Subst0],
[Var - Type | Subst], !VarSet, !Info) :-
replace_in_type(EqvMap, Type0, Type, _, !VarSet, !Info),
replace_in_subst(EqvMap, Subst0, Subst, !VarSet, !Info).
%-----------------------------------------------------------------------------%
replace_in_ctors(EqvMap, !Ctors, !VarSet, !Info) :-
list__map_foldl2(replace_in_ctor(EqvMap), !Ctors, !VarSet, !Info).
:- pred replace_in_ctor(eqv_map::in,
constructor::in, constructor::out, tvarset::in, tvarset::out,
equiv_type_info::in, equiv_type_info::out) is det.
replace_in_ctor(EqvMap,
ctor(ExistQVars, Constraints0, TName, Targs0),
ctor(ExistQVars, Constraints, TName, Targs), !VarSet, !Info) :-
replace_in_ctor_arg_list(EqvMap, Targs0, Targs, _, !VarSet, !Info),
replace_in_prog_constraint_list(EqvMap,
Constraints0, Constraints, !VarSet, !Info).
%-----------------------------------------------------------------------------%
replace_in_type_list(EqvMap, !Ts, Changed, !VarSet, !Info) :-
replace_in_type_list_2(EqvMap, [], !Ts, Changed, no, _, !VarSet, !Info).
:- pred replace_in_type_list(eqv_map::in,
list(mer_type)::in, list(mer_type)::out, bool::out, bool::out,
tvarset::in, tvarset::out, equiv_type_info::in, equiv_type_info::out)
is det.
replace_in_type_list(EqvMap, !Ts, Changed, ContainsCirc, !VarSet, !Info) :-
replace_in_type_list_2(EqvMap, [], !Ts, Changed, no,
ContainsCirc, !VarSet, !Info).
:- pred replace_in_type_list_2(eqv_map::in, list(type_ctor)::in,
list(mer_type)::in, list(mer_type)::out, bool::out, bool::in, bool::out,
tvarset::in, tvarset::out, equiv_type_info::in, equiv_type_info::out)
is det.
replace_in_type_list_2(_EqvMap, _Seen, [], [], no,
!ContainsCirc, !VarSet, !Info).
replace_in_type_list_2(EqvMap, Seen, List0 @ [T0 | Ts0], List,
Changed, !Circ, !VarSet, !Info) :-
replace_in_type_2(EqvMap, Seen, T0, T, Changed0, ContainsCirc,
!VarSet, !Info),
!:Circ = ContainsCirc `or` !.Circ,
replace_in_type_list_2(EqvMap, Seen, Ts0, Ts,
Changed1, !Circ, !VarSet, !Info),
(
( Changed0 = yes
; Changed1 = yes
)
->
Changed = yes,
List = [T | Ts]
;
Changed = no,
List = List0
).
%-----------------------------------------------------------------------------%
:- pred replace_in_ctor_arg_list(eqv_map::in,
list(constructor_arg)::in, list(constructor_arg)::out, bool::out,
tvarset::in, tvarset::out, equiv_type_info::in, equiv_type_info::out)
is det.
replace_in_ctor_arg_list(EqvMap, !As, ContainsCirc, !VarSet, !Info) :-
replace_in_ctor_arg_list_2(EqvMap, [], !As, no, ContainsCirc,
!VarSet, !Info).
:- pred replace_in_ctor_arg_list_2(eqv_map::in, list(type_ctor)::in,
list(constructor_arg)::in, list(constructor_arg)::out,
bool::in, bool::out, tvarset::in, tvarset::out,
equiv_type_info::in, equiv_type_info::out) is det.
replace_in_ctor_arg_list_2(_EqvMap, _Seen, [], [],
!Circ, !VarSet, !Info).
replace_in_ctor_arg_list_2(EqvMap, Seen, [N - T0 | As0], [N - T | As],
!Circ, !VarSet, !Info) :-
replace_in_type_2(EqvMap, Seen, T0, T, _, ContainsCirc, !VarSet, !Info),
!:Circ = !.Circ `or` ContainsCirc,
replace_in_ctor_arg_list_2(EqvMap, Seen, As0, As, !Circ, !VarSet, !Info).
%-----------------------------------------------------------------------------%
replace_in_type(EqvMap, Type0, Type, Changed, !VarSet, !Info) :-
replace_in_type_2(EqvMap, [], Type0, Type, Changed, _,
!VarSet, !Info).
% Replace all equivalence types in a given type, detecting
% any circularities.
%
:- pred replace_in_type_2(eqv_map::in, list(type_ctor)::in,
mer_type::in, mer_type::out, bool::out, bool::out,
tvarset::in, tvarset::out, equiv_type_info::in, equiv_type_info::out)
is det.
replace_in_type_2(EqvMap, TypeCtorsAlreadyExpanded, Type0, Type,
Changed, Circ, !VarSet, !Info) :-
(
Type0 = variable(Var, Kind),
Type = variable(Var, Kind),
Changed = no,
Circ = no
;
Type0 = defined(SymName, TArgs0, Kind),
replace_in_type_list_2(EqvMap, TypeCtorsAlreadyExpanded,
TArgs0, TArgs, ArgsChanged, no, Circ0, !VarSet, !Info),
Arity = list__length(TArgs),
TypeCtor = SymName - Arity,
replace_type_ctor(EqvMap, TypeCtorsAlreadyExpanded,
Type0, TypeCtor, TArgs, Kind, Type, ArgsChanged, Changed,
Circ0, Circ, !VarSet, !Info)
;
Type0 = builtin(_),
Type = Type0,
Changed = no,
Circ = no
;
Type0 = higher_order(Args0, MaybeRet0, Purity, EvalMethod),
replace_in_type_list_2(EqvMap, TypeCtorsAlreadyExpanded,
Args0, Args, ArgsChanged, no, ArgsCirc, !VarSet, !Info),
(
MaybeRet0 = yes(Ret0),
replace_in_type_2(EqvMap, TypeCtorsAlreadyExpanded,
Ret0, Ret, RetChanged, RetCirc, !VarSet, !Info),
MaybeRet = yes(Ret),
Changed = bool__or(ArgsChanged, RetChanged),
Circ = bool__or(ArgsCirc, RetCirc)
;
MaybeRet0 = no,
MaybeRet = no,
Changed = ArgsChanged,
Circ = ArgsCirc
),
(
Changed = yes,
Type = higher_order(Args, MaybeRet, Purity, EvalMethod)
;
Changed = no,
Type = Type0
)
;
Type0 = tuple(Args0, Kind),
replace_in_type_list_2(EqvMap, TypeCtorsAlreadyExpanded,
Args0, Args, Changed, no, Circ, !VarSet, !Info),
(
Changed = yes,
Type = tuple(Args, Kind)
;
Changed = no,
Type = Type0
)
;
Type0 = apply_n(Var, Args0, Kind),
replace_in_type_list_2(EqvMap, TypeCtorsAlreadyExpanded,
Args0, Args, Changed, no, Circ, !VarSet, !Info),
(
Changed = yes,
Type = apply_n(Var, Args, Kind)
;
Changed = no,
Type = Type0
)
;
Type0 = kinded(RawType0, Kind),
replace_in_type_2(EqvMap, TypeCtorsAlreadyExpanded,
RawType0, RawType, Changed, Circ, !VarSet, !Info),
(
Changed = yes,
Type = kinded(RawType, Kind)
;
Changed = no,
Type = Type0
)
).
:- pred replace_type_ctor(eqv_map::in, list(type_ctor)::in,
mer_type::in, type_ctor::in, list(mer_type)::in, kind::in, mer_type::out,
bool::in, bool::out, bool::in, bool::out, tvarset::in, tvarset::out,
equiv_type_info::in, equiv_type_info::out) is det.
replace_type_ctor(EqvMap, TypeCtorsAlreadyExpanded, Type0,
TypeCtor, TArgs, Kind, Type, !Changed, !Circ, !VarSet, !Info) :-
( list__member(TypeCtor, TypeCtorsAlreadyExpanded) ->
AlreadyExpanded = yes
;
AlreadyExpanded = no
),
(
map__search(EqvMap, TypeCtor, eqv_type_body(EqvVarSet, Args0, Body0)),
% Don't merge in the variable names from the type declaration to
% avoid creating multiple variables with the same name so that
% `varset__create_name_var_map' can be used on the resulting
% tvarset. make_hlds uses `varset__create_name_var_map' to match
% up type variables in `:- pragma type_spec' declarations and
% explicit type qualifications with the type variables in the
% predicate's declaration.
tvarset_merge_renaming_without_names(!.VarSet, EqvVarSet, !:VarSet,
Renaming),
!.Circ = no,
AlreadyExpanded = no
->
!:Changed = yes,
map__apply_to_list(Args0, Renaming, Args),
apply_variable_renaming_to_type(Renaming, Body0, Body1),
record_expanded_item(item_id(type_item, TypeCtor), !Info),
map__from_corresponding_lists(Args, TArgs, Subst),
apply_subst_to_type(Subst, Body1, Body),
replace_in_type_2(EqvMap, [TypeCtor | TypeCtorsAlreadyExpanded], Body,
Type, _, !:Circ, !VarSet, !Info)
;
(
!.Changed = yes,
TypeCtor = SymName - _Arity,
Type = defined(SymName, TArgs, Kind)
;
!.Changed = no,
Type = Type0
),
bool__or(AlreadyExpanded, !Circ)
).
:- pred replace_in_inst(mer_inst::in, eqv_inst_map::in, mer_inst::out,
equiv_type_info::in, equiv_type_info::out) is det.
replace_in_inst(Inst0, EqvInstMap, Inst, !Info) :-
replace_in_inst(Inst0, EqvInstMap, set__init, Inst, !Info).
:- pred replace_in_inst(mer_inst::in, eqv_inst_map::in,
set(inst_id)::in, mer_inst::out,
equiv_type_info::in, equiv_type_info::out) is det.
replace_in_inst(Inst0, EqvInstMap, ExpandedInstIds, Inst, !Info) :-
( Inst0 = defined_inst(user_inst(SymName, ArgInsts)) ->
InstId = SymName - length(ArgInsts),
(
set__member(InstId, ExpandedInstIds)
->
Inst = Inst0
;
map__search(EqvInstMap, InstId,
eqv_inst_body(_, EqvInstParams, EqvInst))
->
inst_substitute_arg_list(EqvInstParams, ArgInsts, EqvInst, Inst1),
record_expanded_item(item_id(inst_item, InstId), !Info),
replace_in_inst(Inst1, EqvInstMap,
set__insert(ExpandedInstIds, InstId), Inst, !Info)
;
Inst = Inst0
)
;
Inst = Inst0
).
%-----------------------------------------------------------------------------%
:- pred replace_in_pred_type(sym_name::in, pred_or_func::in,
prog_context::in, eqv_map::in, eqv_inst_map::in,
prog_constraints::in, prog_constraints::out,
list(type_and_mode)::in, list(type_and_mode)::out,
tvarset::in, tvarset::out,
maybe(mer_type)::in, maybe(mer_type)::out,
maybe(mer_inst)::in, maybe(mer_inst)::out,
maybe(determinism)::in, maybe(determinism)::out,
equiv_type_info::in, equiv_type_info::out, list(eqv_error)::out) is det.
replace_in_pred_type(PredName, PredOrFunc, Context, EqvMap, EqvInstMap,
ClassContext0, ClassContext, TypesAndModes0, TypesAndModes,
!TypeVarSet, MaybeWithType0, MaybeWithType,
MaybeWithInst0, MaybeWithInst, Det0, Det, !Info, Errors) :-
replace_in_prog_constraints(EqvMap, ClassContext0, ClassContext,
!TypeVarSet, !Info),
replace_in_tms(EqvMap, TypesAndModes0, TypesAndModes1, !TypeVarSet, !Info),
(
MaybeWithType0 = yes(WithType0),
replace_in_type(EqvMap, WithType0, WithType, _, !TypeVarSet, !Info),
(
type_is_higher_order(WithType, _Purity, PredOrFunc,
_EvalMethod, ExtraTypes0)
->
ExtraTypes = ExtraTypes0,
Errors0 = []
;
ExtraTypes = [],
Errors0 = [invalid_with_type(PredName, PredOrFunc) - Context]
)
;
MaybeWithType0 = no,
ExtraTypes = [],
Errors0 = []
),
replace_in_pred_mode(PredName, length(TypesAndModes0),
Context, type_decl, EqvInstMap, yes(PredOrFunc), _, ExtraModes,
MaybeWithInst0, _, Det0, Det, !Info, ModeErrors),
Errors1 = Errors0 ++ ModeErrors,
( Errors1 = [_ | _] ->
Errors = Errors1,
ExtraTypesAndModes = []
; ExtraModes = [] ->
Errors = Errors1,
ExtraTypesAndModes = list__map((func(Type) = type_only(Type)),
ExtraTypes)
; length(ExtraTypes) `with_type` int = length(ExtraModes) ->
Errors = Errors1,
assoc_list__from_corresponding_lists(ExtraTypes, ExtraModes,
ExtraTypesModes),
ExtraTypesAndModes = list__map(
(func(Type - Mode) = type_and_mode(Type, Mode)),
ExtraTypesModes)
;
Errors = [non_matching_with_type_with_inst(PredName, PredOrFunc)
- Context | Errors1],
ExtraTypesAndModes = []
),
(
Errors = [],
MaybeWithType = no,
MaybeWithInst = no
;
Errors = [_ | _],
% Leave the `with_type` and `with_inst` fields so that make_hlds knows
% to discard this declaration.
MaybeWithType = MaybeWithType0,
MaybeWithInst = MaybeWithInst0
),
(
ExtraTypesAndModes = [],
TypesAndModes = TypesAndModes1
;
ExtraTypesAndModes = [_ | _],
OrigItemId = item_id(pred_or_func_to_item_type(PredOrFunc),
PredName - list__length(TypesAndModes0)),
record_expanded_item(OrigItemId, !Info),
TypesAndModes = TypesAndModes1 ++ ExtraTypesAndModes
).
:- pred replace_in_pred_mode(sym_name::in, arity::in,
prog_context::in, pred_or_func_decl_type::in, eqv_inst_map::in,
maybe(pred_or_func)::in, maybe(pred_or_func)::out,
list(mer_mode)::out, maybe(mer_inst)::in, maybe(mer_inst)::out,
maybe(determinism)::in, maybe(determinism)::out,
equiv_type_info::in, equiv_type_info::out, list(eqv_error)::out) is det.
replace_in_pred_mode(PredName, OrigArity, Context, DeclType,
EqvInstMap, MaybePredOrFunc0, MaybePredOrFunc, ExtraModes,
MaybeWithInst0, MaybeWithInst, Det0, Det, !Info, Errors) :-
(
MaybeWithInst0 = yes(WithInst0),
replace_in_inst(WithInst0, EqvInstMap, WithInst, !Info),
(
WithInst = ground(_, higher_order(pred_inst_info(
PredOrFunc, ExtraModes0, DetPrime))),
( MaybePredOrFunc0 = no
; MaybePredOrFunc0 = yes(PredOrFunc)
)
->
Det = yes(DetPrime),
MaybeWithInst = no,
MaybePredOrFunc = yes(PredOrFunc),
Errors = [],
ExtraModes = ExtraModes0,
(
MaybePredOrFunc0 = no,
RecordedPredOrFunc = predicate
;
MaybePredOrFunc0 = yes(RecordedPredOrFunc)
),
OrigItemId = item_id(pred_or_func_to_item_type(RecordedPredOrFunc),
PredName - OrigArity),
record_expanded_item(OrigItemId, !Info)
;
ExtraModes = [],
MaybePredOrFunc = MaybePredOrFunc0,
% Leave the `with_inst` fields so that make_hlds
% knows to discard this declaration.
MaybeWithInst = MaybeWithInst0,
Det = Det0,
Errors = [invalid_with_inst(DeclType, PredName, MaybePredOrFunc0)
- Context]
)
;
MaybeWithInst0 = no,
MaybeWithInst = MaybeWithInst0,
MaybePredOrFunc = MaybePredOrFunc0,
Errors = [],
Det = Det0,
ExtraModes = []
).
:- pred replace_in_tms(eqv_map::in,
list(type_and_mode)::in, list(type_and_mode)::out,
tvarset::in, tvarset::out, equiv_type_info::in, equiv_type_info::out)
is det.
replace_in_tms(EqvMap, !TMs, !VarSet, !Info) :-
list__map_foldl2(replace_in_tm(EqvMap), !TMs, !VarSet, !Info).
:- pred replace_in_tm(eqv_map::in,
type_and_mode::in, type_and_mode::out, tvarset::in, tvarset::out,
equiv_type_info::in, equiv_type_info::out) is det.
replace_in_tm(EqvMap, type_only(Type0),
type_only(Type), !VarSet, !Info) :-
replace_in_type(EqvMap, Type0, Type, _, !VarSet, !Info).
replace_in_tm(EqvMap, type_and_mode(Type0, Mode),
type_and_mode(Type, Mode), !VarSet, !Info) :-
replace_in_type(EqvMap, Type0, Type, _, !VarSet, !Info).
%-----------------------------------------------------------------------------%
:- type expanded_item_set == pair(module_name, set(item_id)).
maybe_record_expanded_items(_, _, no, no).
maybe_record_expanded_items(ModuleName, SymName, yes(_),
MaybeInfo) :-
( SymName = qualified(ModuleName, _) ->
MaybeInfo = no
;
MaybeInfo = yes(ModuleName - set__init)
).
:- pred record_expanded_item(item_id::in,
equiv_type_info::in, equiv_type_info::out) is det.
record_expanded_item(Item, !Info) :-
map_maybe(record_expanded_item_2(Item), !Info).
:- pred record_expanded_item_2(item_id::in,
pair(module_name, set(item_id))::in,
pair(module_name, set(item_id))::out) is det.
record_expanded_item_2(ItemId, ModuleName - Items0,
ModuleName - Items) :-
ItemId = item_id(_, ItemName),
( ItemName = qualified(ModuleName, _) - _ ->
% We don't need to record local types.
Items = Items0
;
Items = set__insert(Items0, ItemId)
).
finish_recording_expanded_items(_, no, no, no).
finish_recording_expanded_items(_, no, yes(Info), yes(Info)).
finish_recording_expanded_items(_, yes(_), no, _) :-
error("finish_recording_expanded_items").
finish_recording_expanded_items(Item, yes(_ - ExpandedItems),
yes(Info0), yes(Info)) :-
recompilation__record_expanded_items(Item, ExpandedItems, Info0, Info).
%-----------------------------------------------------------------------------%
:- pred report_error(eqv_error::in,
io::di, io::uo) is det.
report_error(circular_equivalence(Item) - Context, !IO) :-
(
Item = type_defn(_, SymName, Params, TypeDefn, _),
TypeDefn = eqv_type(_)
->
Pieces = [words("Error: circular equivalence type"),
fixed(describe_sym_name_and_arity(SymName / length(Params))),
suffix(".")],
write_error_pieces(Context, 0, Pieces, !IO)
;
unexpected(this_file, "report_error: invalid item")
).
report_error(invalid_with_type(SymName, PredOrFunc) - Context, !IO) :-
Pieces = [words("In type declaration for"),
words(error_util__pred_or_func_to_string(PredOrFunc)),
fixed(error_util__describe_sym_name(SymName)),
suffix(":"), nl,
words("error: expected higher order"),
words(error_util__pred_or_func_to_string(PredOrFunc)),
words("type after `with_type`.")],
write_error_pieces(Context, 0, Pieces, !IO).
report_error(invalid_with_inst(DeclType, SymName, MaybePredOrFunc) - Context,
!IO) :-
( DeclType = type_decl, DeclStr = "declaration"
; DeclType = mode_decl, DeclStr = "mode declaration"
),
(
MaybePredOrFunc = no, PredOrFuncStr = ""
;
MaybePredOrFunc = yes(PredOrFunc),
PredOrFuncStr = error_util__pred_or_func_to_string(PredOrFunc)
),
Pieces = [words("In"), words(DeclStr), words("for"), words(PredOrFuncStr),
fixed(error_util__describe_sym_name(SymName)), suffix(":"), nl,
words("error: expected higher order "), words(PredOrFuncStr),
words("inst after `with_inst`.")],
write_error_pieces(Context, 0, Pieces, !IO).
report_error(non_matching_with_type_with_inst(SymName, PredOrFunc) - Context,
!IO) :-
Pieces = [words("In type declaration for"),
words(error_util__pred_or_func_to_string(PredOrFunc)),
fixed(error_util__describe_sym_name(SymName)),
suffix(":"), nl,
words("error: the `with_type` and `with_inst`"),
words("annotations are incompatible.")],
write_error_pieces(Context, 0, Pieces, !IO).
%-----------------------------------------------------------------------------%
:- func this_file = string.
this_file = "equiv_type.m".
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink