mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-15 09:23:44 +00:00
d8a31e574e
compiler/inst_lookup.m:
compiler/inst_mode_type_prop.m:
compiler/inst_test.m:
compiler/inst_util.m:
compiler/mode_util.m:
compiler/type_util.m:
Move these modules from the check_hlds package to the hlds package.
The reason is that all the content of five of these modules, and
most of the content of one module (inst_util.m) is not used
exclusively during semantic checking passes. (A later diff
should deal with the exception.) Some are used by the pass that
builds the initial HLDS, and all are used by middle-end and backend
passes. The move therefore reduces the number of inappropriate imports
of the check_hlds package.
compiler/check_hlds.m:
compiler/hlds.m:
Effect the transfer.
compiler/*.m:
Conform to the changes above.
458 lines
18 KiB
Mathematica
458 lines
18 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 2002-2012 The University of Melbourne.
|
|
% Copyright (C) 2013-2025 The Mercury team.
|
|
% This file may only be copied under the terms of the GNU General
|
|
% Public License - see the file COPYING in the Mercury distribution.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% File: hlds_code_util.m.
|
|
%
|
|
% Various utilities routines for use during HLDS generation.
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module hlds.hlds_code_util.
|
|
:- interface.
|
|
|
|
:- import_module hlds.hlds_class.
|
|
:- import_module hlds.hlds_data.
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module parse_tree.
|
|
:- import_module parse_tree.prog_data.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module list.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Find out how a function symbol (constructor) is represented
|
|
% in the given type.
|
|
%
|
|
:- func cons_id_to_tag(module_info, cons_id) = cons_tag.
|
|
|
|
% Given a type_ctor, return the cons_id that represents its type_ctor_info.
|
|
%
|
|
:- func type_ctor_info_cons_id(type_ctor) = cons_id.
|
|
|
|
% Given a type_ctor, return the cons_id that represents its type_ctor_info.
|
|
%
|
|
:- func base_typeclass_info_cons_id(instance_table,
|
|
prog_constraint, instance_id, list(mer_type)) = cons_id.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% Find the procedure with argmodes which match the ones we want.
|
|
%
|
|
:- pred get_procedure_matching_argmodes(module_info::in, proc_table::in,
|
|
list(mer_mode)::in, proc_id::out, proc_info::out) is semidet.
|
|
|
|
% Find the procedure with declared argmodes which match the ones we want.
|
|
% If there was no mode declaration, then use the inferred argmodes.
|
|
% Allow for a renaming between the inst vars.
|
|
%
|
|
:- pred get_procedure_matching_declmodes_with_renaming(module_info::in,
|
|
assoc_list(proc_id, proc_info)::in, list(mer_mode)::in, proc_id::out)
|
|
is semidet.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module hlds.hlds_proc_util.
|
|
:- import_module hlds.mode_util.
|
|
:- import_module hlds.pred_name.
|
|
:- import_module hlds.type_util.
|
|
:- import_module libs.
|
|
:- import_module libs.globals.
|
|
:- import_module mdbcomp.
|
|
:- import_module mdbcomp.sym_name.
|
|
:- import_module parse_tree.prog_mode.
|
|
|
|
:- import_module char.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module pair.
|
|
:- import_module require.
|
|
:- import_module set.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
cons_id_to_tag(ModuleInfo, ConsId) = ConsTag:-
|
|
(
|
|
ConsId = some_int_const(IntConst),
|
|
(
|
|
IntConst = int_const(Int),
|
|
ConsTag = int_tag(int_tag_int(Int))
|
|
;
|
|
IntConst = uint_const(UInt),
|
|
ConsTag = int_tag(int_tag_uint(UInt))
|
|
;
|
|
IntConst = int8_const(Int8),
|
|
ConsTag = int_tag(int_tag_int8(Int8))
|
|
;
|
|
IntConst = uint8_const(UInt8),
|
|
ConsTag = int_tag(int_tag_uint8(UInt8))
|
|
;
|
|
IntConst = int16_const(Int16),
|
|
ConsTag = int_tag(int_tag_int16(Int16))
|
|
;
|
|
IntConst = uint16_const(UInt16),
|
|
ConsTag = int_tag(int_tag_uint16(UInt16))
|
|
;
|
|
IntConst = int32_const(Int32),
|
|
ConsTag = int_tag(int_tag_int32(Int32))
|
|
;
|
|
IntConst = uint32_const(UInt32),
|
|
ConsTag = int_tag(int_tag_uint32(UInt32))
|
|
;
|
|
IntConst = int64_const(Int64),
|
|
ConsTag = int_tag(int_tag_int64(Int64))
|
|
;
|
|
IntConst = uint64_const(UInt64),
|
|
ConsTag = int_tag(int_tag_uint64(UInt64))
|
|
)
|
|
;
|
|
ConsId = float_const(Float),
|
|
ConsTag = float_tag(Float)
|
|
;
|
|
ConsId = char_const(Char),
|
|
char.to_int(Char, CharCode),
|
|
ConsTag = int_tag(int_tag_int(CharCode))
|
|
;
|
|
ConsId = string_const(String),
|
|
ConsTag = string_tag(String)
|
|
;
|
|
ConsId = impl_defined_const(_),
|
|
unexpected($pred, "implementation_defined_const")
|
|
;
|
|
ConsId = closure_cons(ShroudedPredProcId),
|
|
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
ConsTag = closure_tag(PredId, ProcId)
|
|
;
|
|
ConsId = type_ctor_info_const(ModuleName, TypeName, Arity),
|
|
ConsTag = type_ctor_info_tag(ModuleName, TypeName, Arity)
|
|
;
|
|
ConsId = base_typeclass_info_const(ModuleName, ClassName,
|
|
_Instance, EncodedArgs),
|
|
ConsTag = base_typeclass_info_tag(ModuleName, ClassName, EncodedArgs)
|
|
;
|
|
( ConsId = type_info_cell_constructor(_)
|
|
; ConsId = typeclass_info_cell_constructor
|
|
),
|
|
ConsTag = remote_args_tag(remote_args_unshared(ptag(0u8)))
|
|
;
|
|
ConsId = type_info_const(TIConstNum),
|
|
ConsTag = type_info_const_tag(TIConstNum)
|
|
;
|
|
ConsId = typeclass_info_const(TCIConstNum),
|
|
ConsTag = typeclass_info_const_tag(TCIConstNum)
|
|
;
|
|
ConsId = ground_term_const(ConstNum, SubConsId),
|
|
SubConsTag = cons_id_to_tag(ModuleInfo, SubConsId),
|
|
ConsTag = ground_term_const_tag(ConstNum, SubConsTag)
|
|
;
|
|
ConsId = tabling_info_const(ShroudedPredProcId),
|
|
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
ConsTag = tabling_info_tag(PredId, ProcId)
|
|
;
|
|
ConsId = deep_profiling_proc_layout(ShroudedPredProcId),
|
|
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
ConsTag = deep_profiling_proc_layout_tag(PredId, ProcId)
|
|
;
|
|
ConsId = table_io_entry_desc(ShroudedPredProcId),
|
|
proc(PredId, ProcId) = unshroud_pred_proc_id(ShroudedPredProcId),
|
|
ConsTag = table_io_entry_tag(PredId, ProcId)
|
|
;
|
|
ConsId = tuple_cons(Arity),
|
|
% Tuples do not need a tag. Note that unary tuples are not treated
|
|
% as no_tag types. There is no reason why they couldn't be, it is
|
|
% just not worth the effort.
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
globals.get_target(Globals, TargetLang),
|
|
(
|
|
TargetLang = target_c,
|
|
( if Arity = 0 then
|
|
ConsTag = int_tag(int_tag_int(0))
|
|
else
|
|
ConsTag = remote_args_tag(remote_args_only_functor)
|
|
)
|
|
;
|
|
% For these target languages, converting arity-zero tuples into
|
|
% dummy integer tags results in invalid code being generated.
|
|
( TargetLang = target_csharp
|
|
; TargetLang = target_java
|
|
),
|
|
ConsTag = remote_args_tag(remote_args_only_functor)
|
|
)
|
|
;
|
|
ConsId = du_data_ctor(DuCtor),
|
|
get_cons_repn_defn_det(ModuleInfo, DuCtor, ConsRepn),
|
|
ConsTag = ConsRepn ^ cr_tag
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
type_ctor_info_cons_id(TypeCtor) = ConsId :-
|
|
type_ctor_module_name_arity(TypeCtor, ModuleName, Name, Arity),
|
|
ConsId = type_ctor_info_const(ModuleName, Name, Arity).
|
|
|
|
base_typeclass_info_cons_id(InstanceTable, Constraint, InstanceId,
|
|
InstanceTypes) = ConsId :-
|
|
Constraint = constraint(ClassName, ConstraintArgTypes),
|
|
ClassId = class_id(ClassName, list.length(ConstraintArgTypes)),
|
|
map.lookup(InstanceTable, ClassId, InstanceList),
|
|
InstanceId = instance_id(InstanceNum),
|
|
list.det_index1(InstanceList, InstanceNum, InstanceDefn),
|
|
InstanceModuleName = InstanceDefn ^ instdefn_module,
|
|
make_instance_string(InstanceTypes, InstanceString),
|
|
ConsId = base_typeclass_info_const(InstanceModuleName, ClassId,
|
|
InstanceNum, InstanceString).
|
|
|
|
%----------------------------------------------------------------------------%
|
|
|
|
get_procedure_matching_argmodes(ModuleInfo, ProcTable, Modes0,
|
|
MatchingProcId, MatchingProcInfo) :-
|
|
list.map(constrain_inst_vars_in_mode, Modes0, Modes),
|
|
map.to_assoc_list(ProcTable, ProcPairs),
|
|
get_procedure_matching_argmodes_loop(ModuleInfo, Modes, ProcPairs,
|
|
MatchingProcId, MatchingProcInfo).
|
|
|
|
:- pred get_procedure_matching_argmodes_loop(module_info::in,
|
|
list(mer_mode)::in, assoc_list(proc_id, proc_info)::in,
|
|
proc_id::out, proc_info::out) is semidet.
|
|
|
|
get_procedure_matching_argmodes_loop(ModuleInfo, Modes, [ProcPair | ProcPairs],
|
|
MatchingProcId, MatchingProcInfo) :-
|
|
ProcPair = ProcId - ProcInfo,
|
|
proc_info_get_argmodes(ProcInfo, ArgModes),
|
|
( if mode_list_matches(ModuleInfo, Modes, ArgModes) then
|
|
MatchingProcId = ProcId,
|
|
MatchingProcInfo = ProcInfo
|
|
else
|
|
get_procedure_matching_argmodes_loop(ModuleInfo, Modes, ProcPairs,
|
|
MatchingProcId, MatchingProcInfo)
|
|
).
|
|
|
|
:- pred mode_list_matches(module_info::in,
|
|
list(mer_mode)::in, list(mer_mode)::in) is semidet.
|
|
|
|
mode_list_matches(_, [], []).
|
|
mode_list_matches(ModuleInfo, [Mode1 | Modes1], [Mode2 | Modes2]) :-
|
|
% Use mode_get_insts_semidet instead of mode_get_insts to avoid
|
|
% aborting if there are undefined modes.
|
|
% XXX
|
|
mode_get_insts_semidet(ModuleInfo, Mode1, Inst1, Inst2),
|
|
mode_get_insts_semidet(ModuleInfo, Mode2, Inst1, Inst2),
|
|
mode_list_matches(ModuleInfo, Modes1, Modes2).
|
|
|
|
%----------------------------------------------------------------------------%
|
|
%----------------------------------------------------------------------------%
|
|
|
|
get_procedure_matching_declmodes_with_renaming(ModuleInfo, Procs, Modes0,
|
|
ProcId) :-
|
|
list.map(constrain_inst_vars_in_mode, Modes0, Modes),
|
|
get_procedure_matching_declmodes_with_renaming_2(ModuleInfo, Procs, Modes,
|
|
ProcId).
|
|
|
|
:- pred get_procedure_matching_declmodes_with_renaming_2(module_info::in,
|
|
assoc_list(proc_id, proc_info)::in, list(mer_mode)::in, proc_id::out)
|
|
is semidet.
|
|
|
|
get_procedure_matching_declmodes_with_renaming_2(ModuleInfo, [Proc | Procs],
|
|
Modes, MatchingProcId) :-
|
|
Proc = ProcId - ProcInfo,
|
|
proc_info_declared_argmodes(ProcInfo, ArgModes),
|
|
( if mode_list_matches_with_renaming(ModuleInfo, Modes, ArgModes) then
|
|
MatchingProcId = ProcId
|
|
else
|
|
get_procedure_matching_declmodes_with_renaming_2(ModuleInfo, Procs,
|
|
Modes, MatchingProcId)
|
|
).
|
|
|
|
:- type inst_var_renaming == map(inst_var, inst_var).
|
|
|
|
% Succeeds if two lists of modes match allowing for a renaming
|
|
% of inst variables between the two lists.
|
|
%
|
|
:- pred mode_list_matches_with_renaming(module_info::in,
|
|
list(mer_mode)::in, list(mer_mode)::in) is semidet.
|
|
|
|
mode_list_matches_with_renaming(ModuleInfo, ModesA, ModesB) :-
|
|
mode_list_matches_with_renaming(ModuleInfo, ModesA, ModesB, _).
|
|
|
|
:- pred mode_list_matches_with_renaming(module_info::in, list(mer_mode)::in,
|
|
list(mer_mode)::in, inst_var_renaming::out) is semidet.
|
|
|
|
mode_list_matches_with_renaming(ModuleInfo, ModesA, ModesB, Renaming) :-
|
|
mode_list_matches_with_renaming_2(ModuleInfo, ModesA, ModesB,
|
|
[], Renamings),
|
|
list.foldl(merge_inst_var_renamings, Renamings, map.init, Renaming).
|
|
|
|
:- pred mode_list_matches_with_renaming_2(module_info::in,
|
|
list(mer_mode)::in, list(mer_mode)::in,
|
|
list(inst_var_renaming)::in, list(inst_var_renaming)::out) is semidet.
|
|
|
|
mode_list_matches_with_renaming_2(_, [], [], !Renaming).
|
|
mode_list_matches_with_renaming_2(ModuleInfo,
|
|
[ModeA | ModesA], [ModeB | ModesB], !Substs) :-
|
|
% We use mode_get_insts_semidet instead of mode_get_insts to avoid
|
|
% aborting if there are undefined modes. (Undefined modes get
|
|
% reported later).
|
|
|
|
mode_get_insts_semidet(ModuleInfo, ModeA, InstAInitial, InstAFinal),
|
|
mode_get_insts_semidet(ModuleInfo, ModeB, InstBInitial, InstBFinal),
|
|
match_insts_with_renaming(ModuleInfo, InstAInitial, InstBInitial,
|
|
InitialSubst),
|
|
match_insts_with_renaming(ModuleInfo, InstAFinal, InstBFinal,
|
|
FinalSubst),
|
|
list.append([InitialSubst, FinalSubst], !Substs),
|
|
mode_list_matches_with_renaming_2(ModuleInfo, ModesA, ModesB, !Substs).
|
|
|
|
:- pred match_corresponding_inst_lists_with_renaming(module_info::in,
|
|
list(mer_inst)::in, list(mer_inst)::in,
|
|
inst_var_renaming::in, inst_var_renaming::out) is semidet.
|
|
|
|
match_corresponding_inst_lists_with_renaming(_, [], [], !Renaming).
|
|
match_corresponding_inst_lists_with_renaming(ModuleInfo, [A | As], [B | Bs],
|
|
!Renaming) :-
|
|
match_insts_with_renaming(ModuleInfo, A, B, Renaming0),
|
|
merge_inst_var_renamings(Renaming0, !Renaming),
|
|
match_corresponding_inst_lists_with_renaming(ModuleInfo, As, Bs,
|
|
!Renaming).
|
|
|
|
:- pred match_corresponding_bound_functor_lists_with_renaming(module_info::in,
|
|
list(bound_functor)::in, list(bound_functor)::in,
|
|
inst_var_renaming::in, inst_var_renaming::out) is semidet.
|
|
|
|
match_corresponding_bound_functor_lists_with_renaming(_, [], [], !Renaming).
|
|
match_corresponding_bound_functor_lists_with_renaming(ModuleInfo,
|
|
[A | As], [B | Bs], !Renaming) :-
|
|
A = bound_functor(ConsId, ArgsA),
|
|
B = bound_functor(ConsId, ArgsB),
|
|
match_corresponding_inst_lists_with_renaming(ModuleInfo, ArgsA, ArgsB,
|
|
map.init, Renaming0),
|
|
merge_inst_var_renamings(Renaming0, !Renaming),
|
|
match_corresponding_bound_functor_lists_with_renaming(ModuleInfo, As, Bs,
|
|
!Renaming).
|
|
|
|
:- pred match_insts_with_renaming(module_info::in, mer_inst::in, mer_inst::in,
|
|
map(inst_var, inst_var)::out) is semidet.
|
|
|
|
match_insts_with_renaming(ModuleInfo, InstA, InstB, Renaming) :-
|
|
(
|
|
InstA = not_reached,
|
|
InstB = not_reached,
|
|
map.init(Renaming)
|
|
;
|
|
InstA = free,
|
|
InstB = free,
|
|
map.init(Renaming)
|
|
;
|
|
InstA = any(Uniq, HOInstInfoA),
|
|
InstB = any(Uniq, HOInstInfoB),
|
|
match_ho_inst_infos_with_renaming(ModuleInfo, HOInstInfoA, HOInstInfoB,
|
|
Renaming)
|
|
;
|
|
InstA = ground(Uniq, HOInstInfoA),
|
|
InstB = ground(Uniq, HOInstInfoB),
|
|
match_ho_inst_infos_with_renaming(ModuleInfo, HOInstInfoA, HOInstInfoB,
|
|
Renaming)
|
|
;
|
|
InstA = bound(Uniq, _, BoundFunctorsA),
|
|
InstB = bound(Uniq, _, BoundFunctorsB),
|
|
match_corresponding_bound_functor_lists_with_renaming(ModuleInfo,
|
|
BoundFunctorsA, BoundFunctorsB, map.init, Renaming)
|
|
;
|
|
InstA = inst_var(VarA),
|
|
InstB = inst_var(VarB),
|
|
Renaming = map.singleton(VarA, VarB)
|
|
;
|
|
InstA = constrained_inst_vars(InstVarSetA, SpecInstA),
|
|
InstB = constrained_inst_vars(InstVarSetB, SpecInstB),
|
|
|
|
% We will deal with the specified inst first.
|
|
match_insts_with_renaming(ModuleInfo, SpecInstA, SpecInstB, Renaming0),
|
|
ListVarA = set.to_sorted_list(InstVarSetA),
|
|
ListVarB = set.to_sorted_list(InstVarSetB),
|
|
( if
|
|
ListVarA = [VarA0],
|
|
ListVarB = [VarB0]
|
|
then
|
|
VarA = VarA0,
|
|
VarB = VarB0
|
|
else
|
|
unexpected($pred, "non-singleton sets")
|
|
),
|
|
( if map.search(Renaming0, VarA, SpecVarB) then
|
|
% If VarA was already in the renaming then check that it is
|
|
% consistent with the renaming from the set of inst vars.
|
|
VarB = SpecVarB,
|
|
Renaming = Renaming0
|
|
else
|
|
map.det_insert(VarA, VarB, Renaming0, Renaming)
|
|
)
|
|
;
|
|
InstA = defined_inst(InstNameA),
|
|
InstB = defined_inst(InstNameB),
|
|
match_inst_names_with_renaming(ModuleInfo, InstNameA, InstNameB,
|
|
Renaming)
|
|
).
|
|
|
|
:- pred match_ho_inst_infos_with_renaming(module_info::in, ho_inst_info::in,
|
|
ho_inst_info::in, map(inst_var, inst_var)::out) is semidet.
|
|
|
|
match_ho_inst_infos_with_renaming(ModuleInfo, HOInstInfoA, HOInstInfoB,
|
|
Renaming) :-
|
|
(
|
|
HOInstInfoA = none_or_default_func,
|
|
HOInstInfoB = none_or_default_func,
|
|
Renaming = map.init
|
|
;
|
|
HOInstInfoA = higher_order(PredInstInfoA),
|
|
HOInstInfoB = higher_order(PredInstInfoB),
|
|
PredInstInfoA = pred_inst_info(PredOrFunc, ModesA, _, Detism),
|
|
PredInstInfoB = pred_inst_info(PredOrFunc, ModesB, _, Detism),
|
|
mode_list_matches_with_renaming(ModuleInfo, ModesA, ModesB, Renaming)
|
|
).
|
|
|
|
:- pred match_inst_names_with_renaming(module_info::in,
|
|
inst_name::in, inst_name::in, inst_var_renaming::out) is semidet.
|
|
|
|
match_inst_names_with_renaming(ModuleInfo, InstNameA, InstNameB, Renaming) :-
|
|
(
|
|
InstNameA = user_inst(Name, ArgsA),
|
|
InstNameB = user_inst(Name, ArgsB),
|
|
match_corresponding_inst_lists_with_renaming(ModuleInfo,
|
|
ArgsA, ArgsB, map.init, Renaming)
|
|
;
|
|
% XXX The rest of these are introduced by the compiler, it doesn't
|
|
% look like they need any special treatment.
|
|
( InstNameA = unify_inst(_, _, _, _)
|
|
; InstNameA = merge_inst(_, _)
|
|
; InstNameA = ground_inst(_, _, _, _)
|
|
; InstNameA = any_inst(_, _, _, _)
|
|
; InstNameA = shared_inst(_)
|
|
; InstNameA = mostly_uniq_inst(_)
|
|
),
|
|
InstNameB = InstNameA,
|
|
Renaming = map.init
|
|
).
|
|
|
|
:- pred merge_inst_var_renamings(inst_var_renaming::in,
|
|
inst_var_renaming::in, inst_var_renaming::out) is semidet.
|
|
|
|
merge_inst_var_renamings(RenamingA, RenamingB, Result) :-
|
|
map.union(merge_common_inst_vars, RenamingA, RenamingB, Result).
|
|
|
|
:- pred merge_common_inst_vars(inst_var::in, inst_var::in, inst_var::out)
|
|
is semidet.
|
|
|
|
merge_common_inst_vars(A, A, A).
|
|
|
|
%----------------------------------------------------------------------------%
|
|
:- end_module hlds.hlds_code_util.
|
|
%----------------------------------------------------------------------------%
|