mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-15 05:44:58 +00:00
672f77c4ec
Estimated hours taken: 20 Branches: main Add a new compiler option. --inform-ite-instead-of-switch. If this is enabled, the compiler will generate informational messages about if-then-elses that it thinks should be converted to switches for the sake of program reliability. Act on the output generated by this option. compiler/simplify.m: Implement the new option. Fix an old bug that could cause us to generate warnings about code that was OK in one duplicated copy but not in another (where a switch arm's code is duplicated due to the case being selected for more than one cons_id). compiler/options.m: Add the new option. Add a way to test for the bug fix in simplify. doc/user_guide.texi: Document the new option. NEWS: Mention the new option. library/*.m: mdbcomp/*.m: browser/*.m: compiler/*.m: deep_profiler/*.m: Convert if-then-elses to switches at most of the sites suggested by the new option. At the remaining sites, switching to switches would have nontrivial downsides. This typically happens with the switched-on type has many functors, and we treat one or two specially (e.g. cons/2 in the cons_id type). Perform misc cleanups in the vicinity of the if-then-else to switch conversions. In a few cases, improve the error messages generated. compiler/accumulator.m: compiler/hlds_goal.m: (Rename and) move insts for particular kinds of goal from accumulator.m to hlds_goal.m, to allow them to be used in other modules. Using these insts allowed us to eliminate some if-then-elses entirely. compiler/exprn_aux.m: Instead of fixing some if-then-elses, delete the predicates containing them, since they aren't used, and (as pointed out by the new option) would need considerable other fixing if they were ever needed again. compiler/lp_rational.m: Add prefixes to the names of the function symbols on some types, since without those prefixes, it was hard to figure out what type the switch corresponding to an old if-then-else was switching on. tests/invalid/reserve_tag.err_exp: Expect a new, improved error message.
823 lines
33 KiB
Mathematica
823 lines
33 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1993-2007 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: add_type.m.
|
|
%
|
|
% This submodule of make_hlds handles the declarations of new types.
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module hlds.make_hlds.add_type.
|
|
:- interface.
|
|
|
|
:- import_module hlds.hlds_data.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module hlds.make_hlds.make_hlds_passes.
|
|
:- import_module mdbcomp.prim_data.
|
|
:- import_module parse_tree.error_util.
|
|
:- import_module parse_tree.prog_data.
|
|
|
|
:- import_module bool.
|
|
:- import_module list.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% We allow more than one "definition" for a given type so
|
|
% long all of them except one are actually just declarations,
|
|
% e.g. `:- type t.', which is parsed as an type definition for
|
|
% t which defines t as an abstract_type.
|
|
%
|
|
:- pred module_add_type_defn(tvarset::in, sym_name::in, list(type_param)::in,
|
|
type_defn::in, condition::in, prog_context::in, item_status::in,
|
|
module_info::in, module_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
% Add the constructors and special preds for a type to the HLDS.
|
|
%
|
|
:- pred process_type_defn(type_ctor::in, hlds_type_defn::in,
|
|
bool::in, bool::out, module_info::in, module_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
:- pred make_status_abstract(import_status::in, import_status::out) is det.
|
|
|
|
:- pred combine_status(import_status::in, import_status::in,
|
|
import_status::out) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module backend_libs.
|
|
:- import_module backend_libs.foreign.
|
|
:- import_module hlds.make_hlds.add_special_pred.
|
|
:- import_module hlds.make_hlds.make_hlds_error.
|
|
:- import_module hlds.make_hlds.make_hlds_passes.
|
|
:- import_module hlds.make_tags.
|
|
:- import_module hlds.hlds_code_util.
|
|
:- import_module hlds.hlds_out.
|
|
:- import_module libs.compiler_util.
|
|
:- import_module libs.globals.
|
|
:- import_module libs.options.
|
|
:- import_module parse_tree.module_qual.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_util.
|
|
|
|
:- import_module int.
|
|
:- import_module map.
|
|
:- import_module multi_map.
|
|
:- import_module string.
|
|
:- import_module svmap.
|
|
:- import_module svmulti_map.
|
|
:- import_module term.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
module_add_type_defn(TVarSet, Name, Args, TypeDefn, _Cond, Context,
|
|
item_status(Status0, NeedQual), !ModuleInfo, !Specs) :-
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
list.length(Args, Arity),
|
|
TypeCtor = type_ctor(Name, Arity),
|
|
convert_type_defn(TypeDefn, TypeCtor, Globals, Body0),
|
|
module_info_get_type_table(!.ModuleInfo, Types0),
|
|
(
|
|
(
|
|
Body0 = hlds_abstract_type(_)
|
|
;
|
|
Body0 = hlds_du_type(_, _, _, _, _, _, _),
|
|
string.suffix(term.context_file(Context), ".int2")
|
|
% If the type definition comes from a .int2 file then
|
|
% we need to treat it as abstract. The constructors
|
|
% may only be used by the mode system for comparing
|
|
% `bound' insts to `ground'.
|
|
)
|
|
->
|
|
make_status_abstract(Status0, Status1)
|
|
;
|
|
Status1 = Status0
|
|
),
|
|
(
|
|
% Discriminated unions whose definition consists of a single
|
|
% zero-arity constructor are dummy types. Dummy types are not allowed
|
|
% to have user-defined equality or comparison.
|
|
%
|
|
TypeDefn = parse_tree_du_type(Ctors, MaybeUserUC),
|
|
Ctors = [Constructor],
|
|
list.length(Constructor ^ cons_args, 0),
|
|
MaybeUserUC = yes(_),
|
|
% Only report errors for types defined in this module.
|
|
status_defined_in_this_module(Status0) = yes
|
|
->
|
|
DummyMainPieces = [
|
|
words("Error: the type"),
|
|
sym_name_and_arity(Name / Arity),
|
|
words("is not allowed to have user-defined equality"),
|
|
words("or comparison.")
|
|
],
|
|
DummyVerbosePieces = [
|
|
words("Discriminated unions whose body consists of a single"),
|
|
words("zero-arity constructor cannot have user-defined"),
|
|
words("equality or comparison.")
|
|
],
|
|
DummyMsg = simple_msg(Context,
|
|
[always(DummyMainPieces), verbose_only(DummyVerbosePieces)]),
|
|
DummySpec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[DummyMsg]),
|
|
!:Specs = [DummySpec | !.Specs]
|
|
;
|
|
true
|
|
),
|
|
(
|
|
% The type is exported if *any* occurrence is exported,
|
|
% even a previous abstract occurrence.
|
|
map.search(Types0, TypeCtor, OldDefn0)
|
|
->
|
|
hlds_data.get_type_defn_status(OldDefn0, OldStatus),
|
|
combine_status(Status1, OldStatus, Status),
|
|
hlds_data.get_type_defn_body(OldDefn0, OldBody0),
|
|
combine_is_solver_type(OldBody0, OldBody, Body0, Body),
|
|
( is_solver_type_is_inconsistent(OldBody, Body) ->
|
|
% The existing definition has an is_solver_type annotation
|
|
% which is different to the current definition.
|
|
SolverPieces = [words("In definition of type"),
|
|
sym_name_and_arity(Name / Arity), suffix(":"), nl,
|
|
words("error: all definitions of a type must have"),
|
|
words("consistent `solver' annotations")],
|
|
SolverMsg = simple_msg(Context, [always(SolverPieces)]),
|
|
SolverSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[SolverMsg]),
|
|
!:Specs = [SolverSpec | !.Specs],
|
|
MaybeOldDefn = no
|
|
;
|
|
hlds_data.set_type_defn_body(OldBody, OldDefn0, OldDefn),
|
|
MaybeOldDefn = yes(OldDefn)
|
|
)
|
|
;
|
|
MaybeOldDefn = no,
|
|
Status = Status1,
|
|
Body = Body0
|
|
),
|
|
% XXX kind inference:
|
|
% We set the kinds to `star'. This will be different when we have a
|
|
% kind system.
|
|
map.init(KindMap),
|
|
hlds_data.set_type_defn(TVarSet, Args, KindMap, Body, Status, no,
|
|
NeedQual, Context, T),
|
|
(
|
|
MaybeOldDefn = no,
|
|
Body = hlds_foreign_type(_)
|
|
->
|
|
ForeignDeclPieces = [
|
|
words("Error: type "), sym_name_and_arity(Name / Arity),
|
|
words("defined as foreign_type without being declared.")
|
|
],
|
|
ForeignDeclMsg = simple_msg(Context, [always(ForeignDeclPieces)]),
|
|
ForeignDeclSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[ForeignDeclMsg]),
|
|
!:Specs = [ForeignDeclSpec | !.Specs]
|
|
;
|
|
MaybeOldDefn = yes(OldDefn1),
|
|
Body = hlds_foreign_type(_),
|
|
hlds_data.get_type_defn_status(OldDefn1, OldStatus1),
|
|
hlds_data.get_type_defn_body(OldDefn1, OldBody1),
|
|
OldBody1 = hlds_abstract_type(_),
|
|
status_is_exported_to_non_submodules(OldStatus1) = no,
|
|
status_is_exported_to_non_submodules(Status0) = yes
|
|
->
|
|
ForeignVisPieces = [
|
|
words("Error: pragma foreign_type "),
|
|
sym_name_and_arity(Name / Arity),
|
|
words("must have the same visibility as the type declaration.")
|
|
],
|
|
ForeignVisMsg = simple_msg(Context, [always(ForeignVisPieces)]),
|
|
ForeignVisSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[ForeignVisMsg]),
|
|
!:Specs = [ForeignVisSpec | !.Specs]
|
|
;
|
|
% If there was an existing non-abstract definition for the type, ...
|
|
MaybeOldDefn = yes(T2),
|
|
hlds_data.get_type_defn_tvarset(T2, TVarSet_2),
|
|
hlds_data.get_type_defn_tparams(T2, Params_2),
|
|
hlds_data.get_type_defn_kind_map(T2, KindMap_2),
|
|
hlds_data.get_type_defn_body(T2, Body_2),
|
|
hlds_data.get_type_defn_context(T2, OrigContext),
|
|
hlds_data.get_type_defn_status(T2, OrigStatus),
|
|
hlds_data.get_type_defn_in_exported_eqv(T2, OrigInExportedEqv),
|
|
hlds_data.get_type_defn_need_qualifier(T2, OrigNeedQual),
|
|
Body_2 \= hlds_abstract_type(_)
|
|
->
|
|
globals.get_target(Globals, Target),
|
|
globals.lookup_bool_option(Globals, make_optimization_interface,
|
|
MakeOptInt),
|
|
( Body = hlds_foreign_type(_) ->
|
|
module_info_set_contains_foreign_type(!ModuleInfo)
|
|
;
|
|
true
|
|
),
|
|
(
|
|
% ... then if this definition was abstract, ignore it
|
|
% (but update the status of the old defn if necessary).
|
|
Body = hlds_abstract_type(_)
|
|
->
|
|
( Status = OrigStatus ->
|
|
true
|
|
;
|
|
hlds_data.set_type_defn(TVarSet_2, Params_2, KindMap_2,
|
|
Body_2, Status, OrigInExportedEqv, OrigNeedQual,
|
|
OrigContext, T3),
|
|
map.det_update(Types0, TypeCtor, T3, Types),
|
|
module_info_set_type_table(Types, !ModuleInfo)
|
|
)
|
|
;
|
|
merge_foreign_type_bodies(Target, MakeOptInt, Body, Body_2,
|
|
NewBody)
|
|
->
|
|
( check_foreign_type_visibility(OrigStatus, Status1) ->
|
|
hlds_data.set_type_defn(TVarSet_2, Params_2, KindMap_2,
|
|
NewBody, Status, OrigInExportedEqv, NeedQual, Context, T3),
|
|
map.det_update(Types0, TypeCtor, T3, Types),
|
|
module_info_set_type_table(Types, !ModuleInfo)
|
|
;
|
|
module_info_incr_errors(!ModuleInfo),
|
|
DiffVisPieces = [words("In definition of type"),
|
|
sym_name_and_arity(Name / Arity), suffix(":"), nl,
|
|
words("error: all definitions of a type"),
|
|
words("must have the same visibility")],
|
|
DiffVisMsg = simple_msg(Context, [always(DiffVisPieces)]),
|
|
DiffVisSpec = error_spec(severity_error,
|
|
phase_parse_tree_to_hlds, [DiffVisMsg]),
|
|
!:Specs = [DiffVisSpec | !.Specs]
|
|
)
|
|
;
|
|
% ..., otherwise issue an error message if the second
|
|
% definition wasn't read while reading .opt files.
|
|
Status = status_opt_imported
|
|
->
|
|
true
|
|
;
|
|
module_info_incr_errors(!ModuleInfo),
|
|
multiple_def_error(Status, Name, Arity, "type", Context,
|
|
OrigContext, [], !Specs)
|
|
)
|
|
;
|
|
map.set(Types0, TypeCtor, T, Types),
|
|
module_info_set_type_table(Types, !ModuleInfo),
|
|
(
|
|
% XXX We can't handle abstract exported polymorphic equivalence
|
|
% types with monomorphic bodies, because the compiler stuffs up
|
|
% the type_info handling -- the caller passes type_infos,
|
|
% but the callee expects no type_infos.
|
|
Body = hlds_eqv_type(EqvType),
|
|
Status = status_abstract_exported,
|
|
list.member(Var, Args),
|
|
\+ type_contains_var(EqvType, Var)
|
|
->
|
|
PolyEqvPieces = [words("Sorry, not implemented:"),
|
|
words("polymorphic equivalence type,"),
|
|
words("with monomorphic definition,"),
|
|
words("exported as abstract type.")],
|
|
PolyEqvMsg = simple_msg(Context,
|
|
[always(PolyEqvPieces),
|
|
verbose_only(abstract_monotype_workaround)]),
|
|
PolyEqvSpec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[PolyEqvMsg]),
|
|
!:Specs = [PolyEqvSpec | !.Specs]
|
|
;
|
|
true
|
|
)
|
|
).
|
|
|
|
:- func abstract_monotype_workaround = list(format_component).
|
|
|
|
abstract_monotype_workaround = [
|
|
words("A quick work-around is to just export the type as a concrete,"),
|
|
words("type by putting the type definition in the interface section."),
|
|
words("A better work-around is to use a ""wrapper"" type, with just one"),
|
|
words("functor that has just one arg, instead of an equivalence type."),
|
|
words("(There's no performance penalty for this -- the compiler will"),
|
|
words("optimize the wrapper away.)")
|
|
].
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% We do not have syntax for adding `solver' annotations to
|
|
% `:- pragma foreign_type' declarations, so foreign_type bodies
|
|
% default to having an is_solver_type field of `non_solver_type'.
|
|
% If another declaration for the type has a `solver' annotation then
|
|
% we must update the foreign_type body to reflect this.
|
|
%
|
|
% rafe: XXX think it should be an error for foreign types to
|
|
% be solver types.
|
|
%
|
|
:- pred combine_is_solver_type(hlds_type_body::in, hlds_type_body::out,
|
|
hlds_type_body::in, hlds_type_body::out) is det.
|
|
|
|
combine_is_solver_type(OldBody, OldBody, Body, Body).
|
|
|
|
% Succeed iff the two type bodies have inconsistent is_solver_type
|
|
% annotations.
|
|
:- pred is_solver_type_is_inconsistent(hlds_type_body::in, hlds_type_body::in)
|
|
is semidet.
|
|
|
|
is_solver_type_is_inconsistent(OldBody, Body) :-
|
|
maybe_get_body_is_solver_type(OldBody, OldIsSolverType),
|
|
maybe_get_body_is_solver_type(Body, IsSolverType),
|
|
OldIsSolverType \= IsSolverType.
|
|
|
|
:- pred maybe_get_body_is_solver_type(hlds_type_body::in, is_solver_type::out)
|
|
is semidet.
|
|
|
|
maybe_get_body_is_solver_type(hlds_abstract_type(IsSolverType), IsSolverType).
|
|
maybe_get_body_is_solver_type(hlds_solver_type(_, _), solver_type).
|
|
|
|
% check_foreign_type_visibility(OldStatus, NewDefnStatus).
|
|
%
|
|
% Check that the visibility of the new definition for
|
|
% a foreign type matches that of previous definitions.
|
|
%
|
|
:- pred check_foreign_type_visibility(import_status::in, import_status::in)
|
|
is semidet.
|
|
|
|
check_foreign_type_visibility(OldStatus, NewDefnStatus) :-
|
|
( OldStatus = status_abstract_exported ->
|
|
% If OldStatus is abstract_exported, the previous
|
|
% definitions were local.
|
|
status_is_exported_to_non_submodules(NewDefnStatus) = no
|
|
; OldStatus = status_exported ->
|
|
NewDefnStatus = status_exported
|
|
;
|
|
status_is_exported_to_non_submodules(OldStatus) = no,
|
|
status_is_exported_to_non_submodules(NewDefnStatus) = no
|
|
).
|
|
|
|
process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !Specs) :-
|
|
get_type_defn_context(TypeDefn, Context),
|
|
get_type_defn_tvarset(TypeDefn, TVarSet),
|
|
get_type_defn_tparams(TypeDefn, Args),
|
|
get_type_defn_body(TypeDefn, Body),
|
|
get_type_defn_status(TypeDefn, Status),
|
|
get_type_defn_need_qualifier(TypeDefn, NeedQual),
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
(
|
|
Body = hlds_du_type(ConsList, _, _, UserEqCmp, ReservedTag, _, _),
|
|
module_info_get_cons_table(!.ModuleInfo, Ctors0),
|
|
module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
|
|
module_info_get_ctor_field_table(!.ModuleInfo, CtorFields0),
|
|
ctors_add(ConsList, TypeCtor, TVarSet, NeedQual, PQInfo,
|
|
Context, Status, CtorFields0, CtorFields, Ctors0, Ctors,
|
|
[], CtorAddSpecs),
|
|
module_info_set_cons_table(Ctors, !ModuleInfo),
|
|
module_info_set_ctor_field_table(CtorFields, !ModuleInfo),
|
|
|
|
(
|
|
CtorAddSpecs = [],
|
|
NewFoundError = no
|
|
;
|
|
CtorAddSpecs = [_ | _],
|
|
NewFoundError = yes,
|
|
!:Specs = CtorAddSpecs ++ !.Specs
|
|
),
|
|
|
|
(
|
|
type_with_constructors_should_be_no_tag(Globals, TypeCtor,
|
|
ReservedTag, ConsList, UserEqCmp, Name, CtorArgType, _)
|
|
->
|
|
NoTagType = no_tag_type(Args, Name, CtorArgType),
|
|
module_info_get_no_tag_types(!.ModuleInfo, NoTagTypes0),
|
|
map.set(NoTagTypes0, TypeCtor, NoTagType, NoTagTypes),
|
|
module_info_set_no_tag_types(NoTagTypes, !ModuleInfo)
|
|
;
|
|
true
|
|
)
|
|
;
|
|
( Body = hlds_abstract_type(_)
|
|
; Body = hlds_solver_type(_, _)
|
|
; Body = hlds_eqv_type(_)
|
|
),
|
|
NewFoundError = no
|
|
;
|
|
Body = hlds_foreign_type(ForeignTypeBody),
|
|
check_foreign_type(TypeCtor, ForeignTypeBody, Context,
|
|
NewFoundError, !ModuleInfo, !Specs)
|
|
),
|
|
!:FoundError = !.FoundError `or` NewFoundError,
|
|
(
|
|
!.FoundError = yes
|
|
;
|
|
!.FoundError = no,
|
|
(
|
|
% Equivalence types are fully expanded on the IL and Java backends,
|
|
% so the special predicates aren't required.
|
|
are_equivalence_types_expanded(!.ModuleInfo),
|
|
Body = hlds_eqv_type(_)
|
|
->
|
|
true
|
|
;
|
|
% XXX kind inference:
|
|
% We set the kinds to `star'. This will be different when we have
|
|
% a kind system.
|
|
prog_type.var_list_to_type_list(map.init, Args, ArgTypes),
|
|
construct_type(TypeCtor, ArgTypes, Type),
|
|
add_special_preds(TVarSet, Type, TypeCtor, Body, Context, Status,
|
|
!ModuleInfo)
|
|
)
|
|
).
|
|
|
|
% Check_foreign_type ensures that if we are generating code for a specific
|
|
% backend that the foreign type has a representation on that backend.
|
|
%
|
|
:- pred check_foreign_type(type_ctor::in, foreign_type_body::in,
|
|
prog_context::in, bool::out, module_info::in, module_info::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
check_foreign_type(TypeCtor, ForeignTypeBody, Context, FoundError, !ModuleInfo,
|
|
!Specs) :-
|
|
TypeCtor = type_ctor(Name, Arity),
|
|
module_info_get_globals(!.ModuleInfo, Globals),
|
|
globals.get_target(Globals, Target),
|
|
( have_foreign_type_for_backend(Target, ForeignTypeBody, yes) ->
|
|
FoundError = no
|
|
;
|
|
( Target = target_c, LangStr = "C"
|
|
; Target = target_il, LangStr = "IL"
|
|
; Target = target_java, LangStr = "Java"
|
|
; Target = target_asm, LangStr = "C"
|
|
; Target = target_x86_64, LangStr = "C"
|
|
; Target = target_erlang, LangStr = "Erlang"
|
|
),
|
|
MainPieces = [words("Error: no"), fixed(LangStr),
|
|
fixed("`pragma foreign_type'"), words("declaration for"),
|
|
sym_name_and_arity(Name/Arity), nl],
|
|
VerbosePieces = [words("There are representations for this type"),
|
|
words("on other back-ends, but none for this back-end."), nl],
|
|
Msg = simple_msg(Context,
|
|
[always(MainPieces),
|
|
option_is_set(very_verbose, yes, [always(VerbosePieces)])]),
|
|
Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[Msg]),
|
|
!:Specs = [Spec | !.Specs],
|
|
FoundError = yes
|
|
).
|
|
|
|
:- pred merge_foreign_type_bodies(compilation_target::in, bool::in,
|
|
hlds_type_body::in, hlds_type_body::in, hlds_type_body::out)
|
|
is semidet.
|
|
|
|
% Ignore Mercury definitions if we've got a foreign type
|
|
% declaration suitable for this back-end and we aren't making the
|
|
% optimization interface. We need to keep the Mercury definition
|
|
% if we are making the optimization interface so that it gets
|
|
% output in the .opt file.
|
|
%
|
|
merge_foreign_type_bodies(Target, MakeOptInterface,
|
|
hlds_foreign_type(ForeignTypeBody0), Body1, Body) :-
|
|
MaybeForeignTypeBody1 = Body1 ^ du_type_is_foreign_type,
|
|
(
|
|
MaybeForeignTypeBody1 = yes(ForeignTypeBody1)
|
|
;
|
|
MaybeForeignTypeBody1 = no,
|
|
ForeignTypeBody1 = foreign_type_body(no, no, no, no)
|
|
),
|
|
merge_foreign_type_bodies_2(ForeignTypeBody0, ForeignTypeBody1,
|
|
ForeignTypeBody),
|
|
(
|
|
have_foreign_type_for_backend(Target, ForeignTypeBody, yes),
|
|
MakeOptInterface = no
|
|
->
|
|
Body = hlds_foreign_type(ForeignTypeBody)
|
|
;
|
|
Body = Body1 ^ du_type_is_foreign_type := yes(ForeignTypeBody)
|
|
).
|
|
merge_foreign_type_bodies(Target, MakeOptInterface,
|
|
Body0 @ hlds_du_type(_, _, _, _, _, _, _),
|
|
Body1 @ hlds_foreign_type(_), Body) :-
|
|
merge_foreign_type_bodies(Target, MakeOptInterface, Body1, Body0, Body).
|
|
merge_foreign_type_bodies(_, _, hlds_foreign_type(Body0),
|
|
hlds_foreign_type(Body1), hlds_foreign_type(Body)) :-
|
|
merge_foreign_type_bodies_2(Body0, Body1, Body).
|
|
|
|
:- pred merge_foreign_type_bodies_2(foreign_type_body::in,
|
|
foreign_type_body::in, foreign_type_body::out) is semidet.
|
|
|
|
merge_foreign_type_bodies_2(
|
|
foreign_type_body(MaybeILA, MaybeCA, MaybeJavaA, MaybeErlangA),
|
|
foreign_type_body(MaybeILB, MaybeCB, MaybeJavaB, MaybeErlangB),
|
|
foreign_type_body(MaybeIL, MaybeC, MaybeJava, MaybeErlang)) :-
|
|
merge_maybe(MaybeILA, MaybeILB, MaybeIL),
|
|
merge_maybe(MaybeCA, MaybeCB, MaybeC),
|
|
merge_maybe(MaybeJavaA, MaybeJavaB, MaybeJava),
|
|
merge_maybe(MaybeErlangA, MaybeErlangB, MaybeErlang).
|
|
|
|
:- pred merge_maybe(maybe(T)::in, maybe(T)::in, maybe(T)::out) is semidet.
|
|
|
|
merge_maybe(no, no, no).
|
|
merge_maybe(yes(T), no, yes(T)).
|
|
merge_maybe(no, yes(T), yes(T)).
|
|
|
|
make_status_abstract(Status, AbstractStatus) :-
|
|
( Status = status_exported ->
|
|
AbstractStatus = status_abstract_exported
|
|
; Status = status_imported(_) ->
|
|
AbstractStatus = status_abstract_imported
|
|
;
|
|
AbstractStatus = Status
|
|
).
|
|
|
|
combine_status(StatusA, StatusB, Status) :-
|
|
( combine_status_2(StatusA, StatusB, CombinedStatus) ->
|
|
Status = CombinedStatus
|
|
;
|
|
unexpected(this_file, "unexpected status for type definition")
|
|
).
|
|
|
|
:- pred combine_status_2(import_status::in, import_status::in,
|
|
import_status::out) is semidet.
|
|
|
|
combine_status_2(status_imported(_), Status2, Status) :-
|
|
combine_status_imported(Status2, Status).
|
|
combine_status_2(status_local, Status2, Status) :-
|
|
combine_status_local(Status2, Status).
|
|
combine_status_2(status_exported, _Status2, status_exported).
|
|
combine_status_2(status_exported_to_submodules, Status2, Status) :-
|
|
combine_status_local(Status2, Status3),
|
|
( Status3 = status_local ->
|
|
Status = status_exported_to_submodules
|
|
;
|
|
Status = Status3
|
|
).
|
|
combine_status_2(status_opt_imported, _Status2, status_opt_imported).
|
|
combine_status_2(status_abstract_imported, Status2, Status) :-
|
|
combine_status_abstract_imported(Status2, Status).
|
|
combine_status_2(status_abstract_exported, Status2, Status) :-
|
|
combine_status_abstract_exported(Status2, Status).
|
|
|
|
:- pred combine_status_imported(import_status::in, import_status::out)
|
|
is semidet.
|
|
|
|
combine_status_imported(status_imported(Section), status_imported(Section)).
|
|
combine_status_imported(status_local,
|
|
status_imported(import_locn_implementation)).
|
|
combine_status_imported(status_exported, status_exported).
|
|
combine_status_imported(status_opt_imported, status_opt_imported).
|
|
combine_status_imported(status_abstract_imported,
|
|
status_imported(import_locn_interface)).
|
|
combine_status_imported(status_abstract_exported, status_abstract_exported).
|
|
|
|
:- pred combine_status_local(import_status::in, import_status::out) is semidet.
|
|
|
|
combine_status_local(status_exported_to_submodules,
|
|
status_exported_to_submodules).
|
|
combine_status_local(status_imported(_), status_local).
|
|
combine_status_local(status_local, status_local).
|
|
combine_status_local(status_exported, status_exported).
|
|
combine_status_local(status_opt_imported, status_local).
|
|
combine_status_local(status_abstract_imported, status_local).
|
|
combine_status_local(status_abstract_exported, status_abstract_exported).
|
|
|
|
:- pred combine_status_abstract_exported(import_status::in, import_status::out)
|
|
is det.
|
|
|
|
combine_status_abstract_exported(Status2, Status) :-
|
|
( Status2 = status_exported ->
|
|
Status = status_exported
|
|
;
|
|
Status = status_abstract_exported
|
|
).
|
|
|
|
:- pred combine_status_abstract_imported(import_status::in, import_status::out)
|
|
is det.
|
|
|
|
combine_status_abstract_imported(Status2, Status) :-
|
|
( Status2 = status_imported(Section) ->
|
|
Status = status_imported(Section)
|
|
;
|
|
Status = status_abstract_imported
|
|
).
|
|
|
|
:- pred convert_type_defn(type_defn::in, type_ctor::in, globals::in,
|
|
hlds_type_body::out) is det.
|
|
|
|
convert_type_defn(parse_tree_du_type(Body, MaybeUserEqComp), TypeCtor, Globals,
|
|
HLDSBody) :-
|
|
% Initially, when we first see the `:- type' definition,
|
|
% we assign the constructor tags assuming that there is no
|
|
% `:- pragma reserve_tag' declaration for this type.
|
|
% (If it turns out that there was one, then we will recompute the
|
|
% constructor tags by calling assign_constructor_tags again,
|
|
% with ReservedTagPragma = uses_reserved_tag, when processing the pragma.)
|
|
ReservedTagPragma = does_not_use_reserved_tag,
|
|
assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor, ReservedTagPragma,
|
|
Globals, CtorTags, ReservedAddr, IsEnum),
|
|
IsForeign = no,
|
|
HLDSBody = hlds_du_type(Body, CtorTags, IsEnum, MaybeUserEqComp,
|
|
ReservedTagPragma, ReservedAddr, IsForeign).
|
|
convert_type_defn(parse_tree_eqv_type(Body), _, _, hlds_eqv_type(Body)).
|
|
convert_type_defn(parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp),
|
|
_, _, hlds_solver_type(SolverTypeDetails, MaybeUserEqComp)).
|
|
convert_type_defn(parse_tree_abstract_type(IsSolverType), _, _,
|
|
hlds_abstract_type(IsSolverType)).
|
|
convert_type_defn(parse_tree_foreign_type(ForeignType, MaybeUserEqComp,
|
|
Assertions), _, _, hlds_foreign_type(Body)) :-
|
|
(
|
|
ForeignType = il(ILForeignType),
|
|
Data = foreign_type_lang_data(ILForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(yes(Data), no, no, no)
|
|
;
|
|
ForeignType = c(CForeignType),
|
|
Data = foreign_type_lang_data(CForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, yes(Data), no, no)
|
|
;
|
|
ForeignType = java(JavaForeignType),
|
|
Data = foreign_type_lang_data(JavaForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, no, yes(Data), no)
|
|
;
|
|
ForeignType = erlang(ErlangForeignType),
|
|
Data = foreign_type_lang_data(ErlangForeignType, MaybeUserEqComp,
|
|
Assertions),
|
|
Body = foreign_type_body(no, no, no, yes(Data))
|
|
).
|
|
|
|
:- pred ctors_add(list(constructor)::in, type_ctor::in, tvarset::in,
|
|
need_qualifier::in, partial_qualifier_info::in, prog_context::in,
|
|
import_status::in, ctor_field_table::in, ctor_field_table::out,
|
|
cons_table::in, cons_table::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
ctors_add([], _, _, _, _, _, _, !FieldNameTable, !Ctors, !Specs).
|
|
ctors_add([Ctor | Rest], TypeCtor, TVarSet, NeedQual, PQInfo, _Context,
|
|
ImportStatus, !FieldNameTable, !Ctors, !Specs) :-
|
|
Ctor = ctor(ExistQVars, Constraints, Name, Args, Context),
|
|
QualifiedConsId = make_cons_id(Name, Args, TypeCtor),
|
|
ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, TypeCtor,
|
|
Context),
|
|
%
|
|
% Insert the fully-qualified version of this cons_id into the
|
|
% cons_table.
|
|
% Also check that there is at most one definition of a given
|
|
% cons_id in each type.
|
|
%
|
|
( map.search(!.Ctors, QualifiedConsId, QualifiedConsDefns0) ->
|
|
QualifiedConsDefns1 = QualifiedConsDefns0
|
|
;
|
|
QualifiedConsDefns1 = []
|
|
),
|
|
(
|
|
list.member(OtherConsDefn, QualifiedConsDefns1),
|
|
OtherConsDefn = hlds_cons_defn(_, _, _, TypeCtor, _)
|
|
->
|
|
QualifiedConsIdStr = cons_id_to_string(QualifiedConsId),
|
|
TypeCtorStr = type_ctor_to_string(TypeCtor),
|
|
Pieces = [words("Error: constructor"), quote(QualifiedConsIdStr),
|
|
words("for type"), quote(TypeCtorStr), words("multiply defined.")],
|
|
Msg = simple_msg(Context, [always(Pieces)]),
|
|
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
|
|
!:Specs = [Spec | !.Specs],
|
|
QualifiedConsDefns = QualifiedConsDefns1
|
|
;
|
|
QualifiedConsDefns = [ConsDefn | QualifiedConsDefns1]
|
|
),
|
|
svmap.set(QualifiedConsId, QualifiedConsDefns, !Ctors),
|
|
|
|
( QualifiedConsId = cons(qualified(Module, ConsName), Arity) ->
|
|
% Add the unqualified version of the cons_id to the cons_table,
|
|
% if appropriate.
|
|
(
|
|
NeedQual = may_be_unqualified,
|
|
UnqualifiedConsId = cons(unqualified(ConsName), Arity),
|
|
svmulti_map.set(UnqualifiedConsId, ConsDefn, !Ctors)
|
|
;
|
|
NeedQual = must_be_qualified
|
|
),
|
|
|
|
% Add partially qualified versions of the cons_id.
|
|
get_partial_qualifiers(Module, PQInfo, PartialQuals),
|
|
list.map_foldl(add_ctor(ConsName, Arity, ConsDefn),
|
|
PartialQuals, _PartiallyQualifiedConsIds, !Ctors),
|
|
|
|
FieldNames = list.map(func(C) = C ^ arg_field_name, Args),
|
|
|
|
FirstField = 1,
|
|
|
|
add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
|
|
QualifiedConsId, Context, ImportStatus, FirstField,
|
|
!FieldNameTable, !Specs)
|
|
;
|
|
unexpected(this_file, "ctors_add: cons_id not qualified")
|
|
),
|
|
ctors_add(Rest, TypeCtor, TVarSet, NeedQual, PQInfo, Context,
|
|
ImportStatus, !FieldNameTable, !Ctors, !Specs).
|
|
|
|
:- pred add_ctor(string::in, int::in, hlds_cons_defn::in, module_name::in,
|
|
cons_id::out, cons_table::in, cons_table::out) is det.
|
|
|
|
add_ctor(ConsName, Arity, ConsDefn, ModuleQual, ConsId, CtorsIn, CtorsOut) :-
|
|
ConsId = cons(qualified(ModuleQual, ConsName), Arity),
|
|
multi_map.set(CtorsIn, ConsId, ConsDefn, CtorsOut).
|
|
|
|
:- pred add_ctor_field_names(list(maybe(ctor_field_name))::in,
|
|
need_qualifier::in, list(module_name)::in, type_ctor::in, cons_id::in,
|
|
prog_context::in, import_status::in, int::in,
|
|
ctor_field_table::in, ctor_field_table::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
add_ctor_field_names([], _, _, _, _, _, _, _, !FieldNameTable, !Specs).
|
|
add_ctor_field_names([MaybeFieldName | FieldNames], NeedQual,
|
|
PartialQuals, TypeCtor, ConsId, Context, ImportStatus,
|
|
FieldNumber, !FieldNameTable, !Specs) :-
|
|
(
|
|
MaybeFieldName = yes(FieldName),
|
|
FieldDefn = hlds_ctor_field_defn(Context, ImportStatus, TypeCtor,
|
|
ConsId, FieldNumber),
|
|
add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
|
|
!FieldNameTable, !Specs)
|
|
;
|
|
MaybeFieldName = no
|
|
),
|
|
add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
|
|
ConsId, Context, ImportStatus, FieldNumber + 1,
|
|
!FieldNameTable, !Specs).
|
|
|
|
:- pred add_ctor_field_name(ctor_field_name::in, hlds_ctor_field_defn::in,
|
|
need_qualifier::in, list(module_name)::in,
|
|
ctor_field_table::in, ctor_field_table::out,
|
|
list(error_spec)::in, list(error_spec)::out) is det.
|
|
|
|
add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
|
|
!FieldNameTable, !Specs) :-
|
|
(
|
|
FieldName = qualified(FieldModule0, _),
|
|
FieldModule = FieldModule0
|
|
;
|
|
FieldName = unqualified(_),
|
|
unexpected(this_file, "add_ctor_field_name: unqualified field name")
|
|
),
|
|
(
|
|
% Field names must be unique within a module, not just within
|
|
% a type because the function names for user-defined override functions
|
|
% for the builtin field access functions must be unique within a
|
|
% module.
|
|
%
|
|
map.search(!.FieldNameTable, FieldName, ConflictingDefns)
|
|
->
|
|
( ConflictingDefns = [ConflictingDefn] ->
|
|
ConflictingDefn = hlds_ctor_field_defn(OrigContext, _, _, _, _)
|
|
;
|
|
unexpected(this_file,
|
|
"add_ctor_field_name: multiple conflicting fields")
|
|
),
|
|
|
|
% XXX We should record each error.
|
|
% using module_info_incr_errors
|
|
FieldDefn = hlds_ctor_field_defn(Context, _, _, _, _),
|
|
FieldString = sym_name_to_string(FieldName),
|
|
Pieces = [words("Error: field"), quote(FieldString),
|
|
words("multiply defined.")],
|
|
Msg1 = simple_msg(Context, [always(Pieces)]),
|
|
PrevPieces = [words("Here is the previous definition of field"),
|
|
quote(FieldString), suffix(".")],
|
|
Msg2 = simple_msg(OrigContext, [always(PrevPieces)]),
|
|
Spec = error_spec(severity_error, phase_parse_tree_to_hlds,
|
|
[Msg1, Msg2]),
|
|
!:Specs = [Spec | !.Specs]
|
|
;
|
|
UnqualFieldName = unqualify_name(FieldName),
|
|
|
|
% Add an unqualified version of the field name to the table,
|
|
% if appropriate.
|
|
(
|
|
NeedQual = may_be_unqualified,
|
|
svmulti_map.set(unqualified(UnqualFieldName), FieldDefn,
|
|
!FieldNameTable)
|
|
;
|
|
NeedQual = must_be_qualified
|
|
),
|
|
|
|
% Add partially qualified versions of the cons_id
|
|
list.foldl(do_add_ctor_field(UnqualFieldName, FieldDefn),
|
|
[FieldModule | PartialQuals], !FieldNameTable)
|
|
).
|
|
|
|
:- pred do_add_ctor_field(string::in, hlds_ctor_field_defn::in,
|
|
module_name::in, ctor_field_table::in, ctor_field_table::out) is det.
|
|
|
|
do_add_ctor_field(FieldName, FieldNameDefn, ModuleName, !FieldNameTable) :-
|
|
svmulti_map.set(qualified(ModuleName, FieldName), FieldNameDefn,
|
|
!FieldNameTable).
|
|
|
|
%----------------------------------------------------------------------------%
|
|
|
|
:- func this_file = string.
|
|
|
|
this_file = "add_type.m".
|
|
|
|
%----------------------------------------------------------------------------%
|