%---------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et %---------------------------------------------------------------------------% % Copyright (C) 1994-2012 The University of Melbourne. % Copyright (C) 2015 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: mode_util.m. % Main author: fjh. % % This module contains utility predicates for dealing with modes and insts. % %---------------------------------------------------------------------------% :- module check_hlds.mode_util. :- interface. :- import_module hlds. :- import_module hlds.hlds_goal. :- import_module hlds.hlds_module. :- import_module hlds.hlds_pred. :- import_module hlds.instmap. :- import_module hlds.vartypes. :- import_module parse_tree. :- import_module parse_tree.prog_data. :- import_module list. :- import_module map. %---------------------------------------------------------------------------% % XXX Group related declarations together. % XXX Put the groups in a logical order. % XXX Reorder the predicate definitions to match the declaration order. %---------------------------------------------------------------------------% :- func from_to_insts_to_mode(from_to_insts) = mer_mode. :- func mode_to_from_to_insts(module_info, mer_mode) = from_to_insts. :- func from_to_insts_to_init_inst(from_to_insts) = mer_inst. :- func from_to_insts_to_final_inst(from_to_insts) = mer_inst. :- pred unify_mode_to_lhs_rhs_from_to_insts(unify_mode::in, from_to_insts::out, from_to_insts::out) is det. %---------------------------------------------------------------------------% % Return the initial and the final instantiatedness for the given mode. % Throw an exception if the mode is undefined. % :- pred mode_get_insts(module_info::in, mer_mode::in, mer_inst::out, mer_inst::out) is det. :- pred mode_get_from_to_insts(module_info::in, mer_mode::in, from_to_insts::out) is det. % Return the initial and final instantiatedness for the given mode. % Fail if the mode is undefined. % :- pred mode_get_insts_semidet(module_info::in, mer_mode::in, mer_inst::out, mer_inst::out) is semidet. % Succeed iff the mode is input. % Throw an exception if the mode is undefined. % % A mode is considered input if the initial inst is bound. % :- pred mode_is_input(module_info::in, mer_mode::in) is semidet. :- pred init_inst_is_input(module_info::in, mer_inst::in) is semidet. % Succeed iff the mode is fully input. % Throw an exception if the mode is undefined. % % A mode is considered fully input if the initial inst is ground. % :- pred mode_is_fully_input(module_info::in, mer_mode::in) is semidet. :- pred init_inst_is_fully_input(module_info::in, mer_inst::in) is semidet. % Succeed iff the mode is output. % Throw an exception if the mode is undefined. % % A mode is considered output if the initial inst is free and % the final inst is bound. % :- pred mode_is_output(module_info::in, mer_mode::in) is semidet. :- pred init_final_insts_is_output(module_info::in, mer_inst::in, mer_inst::in) is semidet. % Succeed iff the mode is fully output. % Throw an exception if the mode is undefined. % % A mode is considered fully output if the initial inst is free % and the final inst is ground. % :- pred mode_is_fully_output(module_info::in, mer_mode::in) is semidet. :- pred init_final_insts_is_fully_output(module_info::in, mer_inst::in, mer_inst::in) is semidet. % Succeed iff the mode is unused. % Throws an exception if the mode is undefined. % % A mode is considered unused if both the initial and final insts are free. % :- pred mode_is_unused(module_info::in, mer_mode::in) is semidet. :- pred init_final_insts_is_unused(module_info::in, mer_inst::in, mer_inst::in) is semidet. %---------------------% % Return the modes of the operands on the given side of the unifications. % :- func unify_modes_to_lhs_mode(unify_mode) = mer_mode. :- func unify_modes_to_rhs_mode(unify_mode) = mer_mode. :- func unify_modes_to_lhs_from_to_insts(unify_mode) = from_to_insts. :- func unify_modes_to_rhs_from_to_insts(unify_mode) = from_to_insts. % Given the modes of the two sides of a unification, return the unify_mode. % :- pred modes_to_unify_mode(module_info::in, mer_mode::in, mer_mode::in, unify_mode::out) is det. :- pred from_to_insts_to_unify_mode(from_to_insts::in, from_to_insts::in, unify_mode::out) is det. % Given two lists of modes (inst mappings) of equal length, % return a unify_mode for each corresponding pair of modes. % :- pred modes_to_unify_modes(module_info::in, list(mer_mode)::in, list(mer_mode)::in, list(unify_mode)::out) is det. :- pred from_to_insts_to_unify_modes( list(from_to_insts)::in, list(from_to_insts)::in, list(unify_mode)::out) is det. %---------------------% :- pred modes_to_top_functor_modes(module_info::in, list(mer_mode)::in, list(mer_type)::in, list(top_functor_mode)::out) is det. % mode_to_top_functor_mode converts a mode (and corresponding type) % to a top_functor_mode. % A mode is a high-level notion, the normal Mercury language mode. % A top_functor_mode is a low-level notion used for code generation, % which indicates the argument passing convention (top_in, top_out, or % top_unused) that corresponds to that mode. We need to know the type, % not just the mode, because the argument passing convention can depend % on the type's representation. % :- pred mode_to_top_functor_mode(module_info::in, mer_mode::in, mer_type::in, top_functor_mode::out) is det. :- pred init_final_insts_to_top_functor_mode(module_info::in, mer_inst::in, mer_inst::in, mer_type::in, top_functor_mode::out) is det. %---------------------% % Given a list of variables and their corresponding modes, % return a list containing only those variables which have an output mode. % :- func select_output_vars(module_info, list(prog_var), list(mer_mode), vartypes) = list(prog_var). :- func select_output_things(module_info, list(Thing), list(mer_mode), map(Thing, mer_type)) = list(Thing). %---------------------% :- func mode_get_initial_inst(module_info, mer_mode) = mer_inst. :- func mode_get_final_inst(module_info, mer_mode) = mer_inst. :- pred mode_list_get_initial_insts(module_info::in, list(mer_mode)::in, list(mer_inst)::out) is det. :- pred mode_list_get_final_insts(module_info::in, list(mer_mode)::in, list(mer_inst)::out) is det. %---------------------% % Given a user-defined or compiler-defined inst name, lookup the % corresponding inst in the inst table. % :- pred inst_lookup(module_info::in, inst_name::in, mer_inst::out) is det. %---------------------% :- type recompute_atomic_instmap_deltas ---> recompute_atomic_instmap_deltas ; do_not_recompute_atomic_instmap_deltas. % Use the instmap deltas for all the atomic sub-goals to recompute % the instmap deltas for all the non-atomic sub-goals of a goal. % Used to ensure that the instmap deltas remain valid after code has % been re-arranged, e.g. by followcode. This also takes the module_info % as input and output since it may need to insert new merge_insts % into the merge_inst table. The first argument says whether the % instmap_deltas for calls and deconstruction unifications % should also recomputed. % :- pred recompute_instmap_delta_proc(recompute_atomic_instmap_deltas::in, proc_info::in, proc_info::out, module_info::in, module_info::out) is det. :- pred recompute_instmap_delta(recompute_atomic_instmap_deltas::in, hlds_goal::in, hlds_goal::out, vartypes::in, inst_varset::in, instmap::in, module_info::in, module_info::out) is det. % Given corresponding lists of types and modes, produce a new list % of modes which includes the information provided by the % corresponding types. % :- pred propagate_types_into_mode_list(module_info::in, list(mer_type)::in, list(mer_mode)::in, list(mer_mode)::out) is det. % Given corresponding lists of types and insts and a substitution % for the type variables in the type, produce a new list of insts % which includes the information provided by the corresponding types. % :- pred propagate_types_into_inst_list(module_info::in, tsubst::in, list(mer_type)::in, list(mer_inst)::in, list(mer_inst)::out) is det. % Convert a list of constructors to a list of bound_insts where the % arguments are `ground'. % % NOTE: the list(bound_inst) is not sorted and may contain duplicates. % :- pred constructors_to_bound_insts(module_info::in, uniqueness::in, type_ctor::in, list(constructor)::in, list(bound_inst)::out) is det. % Convert a list of constructors to a list of bound_insts where the % arguments are `any'. % % NOTE: the list(bound_inst) is not sorted and may contain duplicates. % :- pred constructors_to_bound_any_insts(module_info::in, uniqueness::in, type_ctor::in, list(constructor)::in, list(bound_inst)::out) is det. % A bound(_, _, BoundInsts) inst contains a cons_id in each of the % BoundInsts. This predicate records, for each of those cons_ids, % that the cons_id belongs to the given type, *if* in fact that cons_id % is one of the function symbols of the give type. % % NOTE: If insts were required to belong to just one explicitly specified % type, as they should be, this predicate would not be necessary. % :- pred propagate_ctor_info_into_bound_inst(module_info::in, mer_type::in, mer_inst::in(mer_inst_is_bound), mer_inst::out) is det. % Given the mode of a predicate, work out which arguments are live % (might be used again by the caller of that predicate) and which are dead. % :- pred get_arg_lives(module_info::in, list(mer_mode)::in, list(is_live)::out) is det. % Given the switched on variable and the instmaps before the switch % and after a branch make sure that any information added by the % functor test gets added to the instmap for the case. % :- pred fixup_instmap_switch_var(prog_var::in, instmap::in, instmap::in, hlds_goal::in, hlds_goal::out) is det. %---------------------------------------------------------------------------% :- pred normalise_insts(module_info::in, list(mer_type)::in, list(mer_inst)::in, list(mer_inst)::out) is det. :- pred normalise_inst(module_info::in, mer_type::in, mer_inst::in, mer_inst::out) is det. %---------------------------------------------------------------------------% % Partition a list of arguments into inputs and others. % Throws an exception if one of the modes is undefined. % :- pred partition_args(module_info::in, list(mer_mode)::in, list(T)::in, list(T)::out, list(T)::out) is det. %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% :- implementation. :- import_module check_hlds.inst_match. :- import_module check_hlds.inst_test. :- import_module check_hlds.inst_util. :- import_module check_hlds.type_util. :- import_module hlds.hlds_data. :- import_module hlds.hlds_inst_mode. :- import_module mdbcomp. :- import_module mdbcomp.builtin_modules. :- import_module mdbcomp.prim_data. :- import_module mdbcomp.sym_name. :- import_module parse_tree.prog_mode. :- import_module parse_tree.prog_type. :- import_module parse_tree.prog_type_subst. :- import_module parse_tree.set_of_var. :- import_module bool. :- import_module int. :- import_module maybe. :- import_module one_or_more. :- import_module require. :- import_module set. :- import_module term. :- import_module varset. %---------------------------------------------------------------------------% from_to_insts_to_mode(FromToInsts) = Mode :- FromToInsts = from_to_insts(Init, Final), Mode = from_to_mode(Init, Final). mode_to_from_to_insts(ModuleInfo, Mode) = FromToInsts :- mode_get_insts(ModuleInfo, Mode, Init, Final), FromToInsts = from_to_insts(Init, Final). from_to_insts_to_init_inst(FromToInsts) = Init :- FromToInsts = from_to_insts(Init, _Final). from_to_insts_to_final_inst(FromToInsts) = Final :- FromToInsts = from_to_insts(_Init, Final). unify_mode_to_lhs_rhs_from_to_insts(UnifyMode, LHSInsts, RHSInsts) :- LHSInsts = from_to_insts(LHSInitInst, LHSFinalInst), RHSInsts = from_to_insts(RHSInitInst, RHSFinalInst), UnifyMode = unify_modes_li_lf_ri_rf(LHSInitInst, LHSFinalInst, RHSInitInst, RHSFinalInst). %---------------------------------------------------------------------------% mode_get_initial_inst(ModuleInfo, Mode) = Inst :- mode_get_insts(ModuleInfo, Mode, Inst, _). mode_get_final_inst(ModuleInfo, Mode) = Inst :- mode_get_insts(ModuleInfo, Mode, _, Inst). mode_list_get_initial_insts(_ModuleInfo, [], []). mode_list_get_initial_insts(ModuleInfo, [Mode | Modes], [Inst | Insts]) :- mode_get_insts(ModuleInfo, Mode, Inst, _), mode_list_get_initial_insts(ModuleInfo, Modes, Insts). mode_list_get_final_insts(_ModuleInfo, [], []). mode_list_get_final_insts(ModuleInfo, [Mode | Modes], [Inst | Insts]) :- mode_get_insts(ModuleInfo, Mode, _, Inst), mode_list_get_final_insts(ModuleInfo, Modes, Insts). %---------------------------------------------------------------------------% mode_is_input(ModuleInfo, Mode) :- mode_get_insts(ModuleInfo, Mode, InitialInst, _FinalInst), inst_is_bound(ModuleInfo, InitialInst). init_inst_is_input(ModuleInfo, InitialInst) :- inst_is_bound(ModuleInfo, InitialInst). %---------------------% mode_is_fully_input(ModuleInfo, Mode) :- mode_get_insts(ModuleInfo, Mode, InitialInst, _FinalInst), inst_is_ground(ModuleInfo, InitialInst). init_inst_is_fully_input(ModuleInfo, InitialInst) :- inst_is_ground(ModuleInfo, InitialInst). %---------------------% mode_is_output(ModuleInfo, Mode) :- mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst), inst_is_free(ModuleInfo, InitialInst), inst_is_bound(ModuleInfo, FinalInst). init_final_insts_is_output(ModuleInfo, InitialInst, FinalInst) :- inst_is_free(ModuleInfo, InitialInst), inst_is_bound(ModuleInfo, FinalInst). %---------------------% mode_is_fully_output(ModuleInfo, Mode) :- mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst), inst_is_free(ModuleInfo, InitialInst), inst_is_ground(ModuleInfo, FinalInst). init_final_insts_is_fully_output(ModuleInfo, InitialInst, FinalInst) :- inst_is_free(ModuleInfo, InitialInst), inst_is_ground(ModuleInfo, FinalInst). %---------------------% mode_is_unused(ModuleInfo, Mode) :- mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst), inst_is_free(ModuleInfo, InitialInst), inst_is_free(ModuleInfo, FinalInst). init_final_insts_is_unused(ModuleInfo, InitialInst, FinalInst) :- inst_is_free(ModuleInfo, InitialInst), inst_is_free(ModuleInfo, FinalInst). %---------------------------------------------------------------------------% unify_modes_to_lhs_mode(UnifyMode) = LHSMode :- UnifyMode = unify_modes_li_lf_ri_rf(LHSInitInst, LHSFinalInst, _, _), LHSMode = from_to_mode(LHSInitInst, LHSFinalInst). unify_modes_to_rhs_mode(UnifyMode) = RHSMode :- UnifyMode = unify_modes_li_lf_ri_rf(_, _, RHSInitInst, RHSFinalInst), RHSMode = from_to_mode(RHSInitInst, RHSFinalInst). unify_modes_to_lhs_from_to_insts(UnifyMode) = LHSFromToInsts :- UnifyMode = unify_modes_li_lf_ri_rf(LHSInitInst, LHSFinalInst, _, _), LHSFromToInsts = from_to_insts(LHSInitInst, LHSFinalInst). unify_modes_to_rhs_from_to_insts(UnifyMode) = RHSFromToInsts :- UnifyMode = unify_modes_li_lf_ri_rf(_, _, RHSInitInst, RHSFinalInst), RHSFromToInsts = from_to_insts(RHSInitInst, RHSFinalInst). %---------------------% modes_to_top_functor_modes(_ModuleInfo, [], [], []). modes_to_top_functor_modes(_ModuleInfo, [], [_ | _], _) :- unexpected($pred, "length mismatch"). modes_to_top_functor_modes(_ModuleInfo, [_ | _], [], _) :- unexpected($pred, "length mismatch"). modes_to_top_functor_modes(ModuleInfo, [Mode | Modes], [Type | Types], [TopFunctorMode | TopFunctorModes]) :- mode_to_top_functor_mode(ModuleInfo, Mode, Type, TopFunctorMode), modes_to_top_functor_modes(ModuleInfo, Modes, Types, TopFunctorModes). mode_to_top_functor_mode(ModuleInfo, Mode, Type, TopFunctorMode) :- mode_get_insts(ModuleInfo, Mode, InitialInst, FinalInst), find_top_functor_mode_loop_over_notags(ModuleInfo, Type, [], InitialInst, FinalInst, TopFunctorMode). init_final_insts_to_top_functor_mode(ModuleInfo, InitialInst, FinalInst, Type, TopFunctorMode) :- find_top_functor_mode_loop_over_notags(ModuleInfo, Type, [], InitialInst, FinalInst, TopFunctorMode). :- pred find_top_functor_mode_loop_over_notags(module_info::in, mer_type::in, list(type_ctor)::in, mer_inst::in, mer_inst::in, top_functor_mode::out) is det. find_top_functor_mode_loop_over_notags(ModuleInfo, Type, ContainingTypes, InitialInst, FinalInst, TopFunctorMode) :- % We need to handle no_tag types (types which have exactly one constructor, % and whose one constructor has exactly one argument) specially here, % since for them an inst of bound(f(free)) is not really bound as far as % code generation is concerned, since the f/1 will get optimized away. ( if % Is this a no_tag type? type_is_no_tag_type(ModuleInfo, Type, FunctorName, ArgType), % Avoid infinite recursion. type_to_ctor(Type, TypeCtor), not list.member(TypeCtor, ContainingTypes) then % The top_functor_mode will be determined by the mode and type of the % functor's argument, so we figure out the mode and type of the % argument, and then recurse. ConsId = cons(FunctorName, 1, TypeCtor), get_single_arg_inst(ModuleInfo, InitialInst, ConsId, InitialArgInst), get_single_arg_inst(ModuleInfo, FinalInst, ConsId, FinalArgInst), find_top_functor_mode_loop_over_notags(ModuleInfo, ArgType, [TypeCtor | ContainingTypes], InitialArgInst, FinalArgInst, TopFunctorMode) else ( if inst_is_bound(ModuleInfo, InitialInst) then TopFunctorMode = top_in else if inst_is_bound(ModuleInfo, FinalInst) then TopFunctorMode = top_out else TopFunctorMode = top_unused ) ). select_output_vars(ModuleInfo, HeadVars, HeadModes, VarTypes) = OutputVars :- ( HeadVars = [], HeadModes = [], OutputVars = [] ; HeadVars = [Var | Vars], HeadModes = [Mode | Modes], lookup_var_type(VarTypes, Var, VarType), mode_to_top_functor_mode(ModuleInfo, Mode, VarType, Top), ( Top = top_out, OutputVars1 = select_output_vars(ModuleInfo, Vars, Modes, VarTypes), OutputVars = [Var | OutputVars1] ; ( Top = top_in ; Top = top_unused ), OutputVars = select_output_vars(ModuleInfo, Vars, Modes, VarTypes) ) ; HeadVars = [], HeadModes = [_ | _], unexpected($pred, "length mismatch") ; HeadVars = [_ | _], HeadModes = [], unexpected($pred, "length mismatch") ). select_output_things(ModuleInfo, HeadThings, HeadModes, ThingTypes) = OutputThings :- ( HeadThings = [], HeadModes = [], OutputThings = [] ; HeadThings = [Thing | Things], HeadModes = [Mode | Modes], map.lookup(ThingTypes, Thing, ThingType), mode_to_top_functor_mode(ModuleInfo, Mode, ThingType, Top), ( Top = top_out, OutputThings1 = select_output_things(ModuleInfo, Things, Modes, ThingTypes), OutputThings = [Thing | OutputThings1] ; ( Top = top_in ; Top = top_unused ), OutputThings = select_output_things(ModuleInfo, Things, Modes, ThingTypes) ) ; HeadThings = [], HeadModes = [_ | _], unexpected($pred, "length mismatch") ; HeadThings = [_ | _], HeadModes = [], unexpected($pred, "length mismatch") ). %---------------------------------------------------------------------------% % get_single_arg_inst(ModuleInfo, Inst, ConsId, ArgInsts): % Given an inst `Inst', figure out what the inst of the argument would be, % assuming that the functor is the one given by the specified ConsId, % whose arity is 1. % :- pred get_single_arg_inst(module_info::in, mer_inst::in, cons_id::in, mer_inst::out) is det. get_single_arg_inst(ModuleInfo, Inst, ConsId, ArgInst) :- % XXX This is very similar to get_arg_insts in prog_mode. ( Inst = defined_inst(InstName), inst_lookup(ModuleInfo, InstName, NamedInst), get_single_arg_inst(ModuleInfo, NamedInst, ConsId, ArgInst) ; Inst = not_reached, ArgInst = not_reached ; Inst = ground(Uniq, _PredInst), ArgInst = ground(Uniq, none_or_default_func) ; Inst = bound(_Uniq, _InstResult, List), ( if get_single_arg_inst_in_bound_insts(List, ConsId, ArgInst0) then ArgInst = ArgInst0 else % The code is unreachable. ArgInst = not_reached ) ; Inst = free, ArgInst = free ; Inst = free(_Type), ArgInst = free % XXX loses type info ; Inst = any(Uniq, _), ArgInst = any(Uniq, none_or_default_func) ; Inst = abstract_inst(_, _), unexpected($pred, "abstract insts not supported") ; Inst = inst_var(_), unexpected($pred, "inst_var") ; Inst = constrained_inst_vars(_, InsideInst), get_single_arg_inst(ModuleInfo, InsideInst, ConsId, ArgInst) ). :- pred get_single_arg_inst_in_bound_insts(list(bound_inst)::in, cons_id::in, mer_inst::out) is semidet. get_single_arg_inst_in_bound_insts([BoundInst | BoundInsts], ConsId, ArgInst) :- ( if BoundInst = bound_functor(InstConsId, [ArgInst0]), % The cons_ids for types and insts can differ in the type_ctor field % so we must ignore them. equivalent_cons_ids(ConsId, InstConsId) then ArgInst = ArgInst0 else get_single_arg_inst_in_bound_insts(BoundInsts, ConsId, ArgInst) ). %---------------------------------------------------------------------------% modes_to_unify_mode(ModuleInfo, ModeX, ModeY, UnifyMode) :- mode_get_insts(ModuleInfo, ModeX, InitialX, FinalX), mode_get_insts(ModuleInfo, ModeY, InitialY, FinalY), UnifyMode = unify_modes_li_lf_ri_rf(InitialX, FinalX, InitialY, FinalY). from_to_insts_to_unify_mode(FromToInstsX, FromToInstsY, UnifyMode) :- FromToInstsX = from_to_insts(InitInstX, FinalInstX), FromToInstsY = from_to_insts(InitInstY, FinalInstY), UnifyMode = unify_modes_li_lf_ri_rf(InitInstX, FinalInstX, InitInstY, FinalInstY). modes_to_unify_modes(_ModuleInfo, [], [], []). modes_to_unify_modes(_ModuleInfo, [], [_ | _], _) :- unexpected($pred, "length mismatch"). modes_to_unify_modes(_ModuleInfo, [_ | _], [], _) :- unexpected($pred, "length mismatch"). modes_to_unify_modes(ModuleInfo, [ModeX | ModeXs], [ModeY | ModeYs], [UnifyMode | UnifyModes]) :- modes_to_unify_mode(ModuleInfo, ModeX, ModeY, UnifyMode), modes_to_unify_modes(ModuleInfo, ModeXs, ModeYs, UnifyModes). from_to_insts_to_unify_modes([], [], []). from_to_insts_to_unify_modes([], [_ | _], _) :- unexpected($pred, "length mismatch"). from_to_insts_to_unify_modes([_ | _], [], _) :- unexpected($pred, "length mismatch"). from_to_insts_to_unify_modes( [FromToInstsX | FromToInstsXs], [FromToInstsY | FromToInstsYs], [UnifyMode | UnifyModes]) :- from_to_insts_to_unify_mode(FromToInstsX, FromToInstsY, UnifyMode), from_to_insts_to_unify_modes(FromToInstsXs, FromToInstsYs, UnifyModes). %---------------------------------------------------------------------------% inst_lookup(ModuleInfo, InstName, Inst) :- ( InstName = unify_inst(Live, Real, InstA, InstB), UnifyInstInfo = unify_inst_info(Live, Real, InstA, InstB), module_info_get_inst_table(ModuleInfo, InstTable), inst_table_get_unify_insts(InstTable, UnifyInstTable), lookup_unify_inst(UnifyInstTable, UnifyInstInfo, MaybeInstDet), ( MaybeInstDet = inst_det_known(Inst, _) ; MaybeInstDet = inst_det_unknown, Inst = defined_inst(InstName) ) ; InstName = merge_inst(InstA, InstB), MergeInstInfo = merge_inst_info(InstA, InstB), module_info_get_inst_table(ModuleInfo, InstTable), inst_table_get_merge_insts(InstTable, MergeInstTable), lookup_merge_inst(MergeInstTable, MergeInstInfo, MaybeInst), ( MaybeInst = inst_known(Inst) ; MaybeInst = inst_unknown, Inst = defined_inst(InstName) ) ; InstName = ground_inst(SubInstName, Uniq, Live, Real), GroundInstInfo = ground_inst_info(SubInstName, Uniq, Live, Real), module_info_get_inst_table(ModuleInfo, InstTable), inst_table_get_ground_insts(InstTable, GroundInstTable), lookup_ground_inst(GroundInstTable, GroundInstInfo, MaybeInstDet), ( MaybeInstDet = inst_det_known(Inst, _) ; MaybeInstDet = inst_det_unknown, Inst = defined_inst(InstName) ) ; InstName = any_inst(SubInstName, Uniq, Live, Real), AnyInstInfo = any_inst_info(SubInstName, Uniq, Live, Real), module_info_get_inst_table(ModuleInfo, InstTable), inst_table_get_any_insts(InstTable, AnyInstTable), lookup_any_inst(AnyInstTable, AnyInstInfo, MaybeInstDet), ( MaybeInstDet = inst_det_known(Inst, _) ; MaybeInstDet = inst_det_unknown, Inst = defined_inst(InstName) ) ; InstName = shared_inst(SharedInstName), module_info_get_inst_table(ModuleInfo, InstTable), inst_table_get_shared_insts(InstTable, SharedInstTable), lookup_shared_inst(SharedInstTable, SharedInstName, MaybeInst), ( MaybeInst = inst_known(Inst) ; MaybeInst = inst_unknown, Inst = defined_inst(InstName) ) ; InstName = mostly_uniq_inst(NondetLiveInstName), module_info_get_inst_table(ModuleInfo, InstTable), inst_table_get_mostly_uniq_insts(InstTable, MostlyUniqInstTable), lookup_mostly_uniq_inst(MostlyUniqInstTable, NondetLiveInstName, MaybeInst), ( MaybeInst = inst_known(Inst) ; MaybeInst = inst_unknown, Inst = defined_inst(InstName) ) ; InstName = user_inst(Name, Args), module_info_get_inst_table(ModuleInfo, InstTable), inst_table_get_user_insts(InstTable, UserInstTable), list.length(Args, Arity), ( if map.search(UserInstTable, inst_ctor(Name, Arity), InstDefn) then InstDefn = hlds_inst_defn(_VarSet, Params, InstBody, _MMTC, _Context, _Status), InstBody = eqv_inst(Inst0), inst_substitute_arg_list(Params, Args, Inst0, Inst) else Inst = abstract_inst(Name, Args) ) ; InstName = typed_ground(Uniq, Type), map.init(Subst), propagate_type_into_inst(ModuleInfo, Subst, Type, ground(Uniq, none_or_default_func), Inst) ; InstName = typed_inst(Type, TypedInstName), inst_lookup(ModuleInfo, TypedInstName, Inst0), map.init(Subst), propagate_type_into_inst(ModuleInfo, Subst, Type, Inst0, Inst) ). %---------------------------------------------------------------------------% propagate_types_into_mode_list(_, [], [], []). propagate_types_into_mode_list(_, [], [_ | _], []) :- unexpected($pred, "length mismatch"). propagate_types_into_mode_list(_, [_ | _], [], []) :- unexpected($pred, "length mismatch"). propagate_types_into_mode_list(ModuleInfo, [Type | Types], [Mode0 | Modes0], [Mode | Modes]) :- propagate_type_into_mode(ModuleInfo, Type, Mode0, Mode), propagate_types_into_mode_list(ModuleInfo, Types, Modes0, Modes). propagate_types_into_inst_list(_, _, [], [], []). propagate_types_into_inst_list(_, _, [], [_ | _], []) :- unexpected($pred, "length mismatch"). propagate_types_into_inst_list(_, _, [_ | _], [], []) :- unexpected($pred, "length mismatch"). propagate_types_into_inst_list(ModuleInfo, Subst, [Type | Types], [Inst0 | Insts0], [Inst | Insts]) :- propagate_type_into_inst(ModuleInfo, Subst, Type, Inst0, Inst), propagate_types_into_inst_list(ModuleInfo, Subst, Types, Insts0, Insts). % Given a type and a mode, produce a new mode that includes the % information provided by the type. % :- pred propagate_type_into_mode(module_info::in, mer_type::in, mer_mode::in, mer_mode::out) is det. propagate_type_into_mode(ModuleInfo, Type, Mode0, Mode) :- mode_get_insts(ModuleInfo, Mode0, InitialInst0, FinalInst0), map.init(Subst), propagate_type_into_inst_lazily(ModuleInfo, Subst, Type, InitialInst0, InitialInst), propagate_type_into_inst_lazily(ModuleInfo, Subst, Type, FinalInst0, FinalInst), Mode = from_to_mode(InitialInst, FinalInst). % Given a type, an inst and a substitution for the type variables in % the type, produce a new inst that includes the information % provided by the type. % % There are three sorts of information added: % 1 Module qualifiers. % 2 The set of constructors in the type. % 3 For higher-order function types (but not higher-order predicate % types), the higher-order inst, i.e. the argument modes and % the determinism. % % Currently #2 is not yet implemented, due to unsolved % efficiency problems. (See the XXX's below.) % % There are two versions, an "eager" one and a "lazy" one. In general, % eager expansion is to be preferred, because the expansion is done % just once, whereas with lazy expansion the work will be done N times. % However, for recursive insts we must use lazy expansion (otherwise % we would get infinite regress). Also, usually many of the imported % procedures will not be called, so for the insts in imported mode % declarations N is often zero. % :- pred propagate_type_into_inst(module_info::in, tsubst::in, mer_type::in, mer_inst::in, mer_inst::out) is det. :- pred propagate_type_into_inst_lazily(module_info::in, tsubst::in, mer_type::in, mer_inst::in, mer_inst::out) is det. propagate_type_into_inst(ModuleInfo, Subst, Type0, Inst0, Inst) :- ( if semidet_fail then % XXX We ought to expand things eagerly here, using this code. % However, that causes efficiency problems, so for the moment % we always do propagation lazily. apply_type_subst(Type0, Subst, Type), ( if type_constructors(ModuleInfo, Type, Constructors) then propagate_ctor_info(ModuleInfo, Type, Constructors, Inst0, Inst) else Inst = Inst0 ) else propagate_ctor_info_lazily(ModuleInfo, Subst, Type0, Inst0, Inst) ). propagate_type_into_inst_lazily(ModuleInfo, Subst, Type, Inst0, Inst) :- propagate_ctor_info_lazily(ModuleInfo, Subst, Type, Inst0, Inst). %---------------------------------------------------------------------------% :- pred propagate_ctor_info(module_info::in, mer_type::in, list(constructor)::in, mer_inst::in, mer_inst::out) is det. propagate_ctor_info(ModuleInfo, Type, Constructors, Inst0, Inst) :- ( Inst0 = free, % Inst = free(Type) Inst = free % XXX temporary hack ; Inst0 = free(_), unexpected($pred, "type info already present") ; Inst0 = ground(Uniq, none_or_default_func), ( if type_is_higher_order_details(Type, _, pf_function, _, ArgTypes) then default_higher_order_func_inst(ModuleInfo, ArgTypes, HigherOrderInstInfo), Inst = ground(Uniq, higher_order(HigherOrderInstInfo)) else type_to_ctor_det(Type, TypeCtor), constructors_to_bound_insts(ModuleInfo, Uniq, TypeCtor, Constructors, BoundInsts0), list.sort_and_remove_dups(BoundInsts0, BoundInsts), InstResults = inst_test_results( inst_result_is_ground, inst_result_does_not_contain_any, inst_result_contains_inst_names_known(set.init), inst_result_contains_inst_vars_known(set.init), inst_result_contains_types_known(set.init), inst_result_type_ctor_propagated(TypeCtor) ), Inst = bound(Uniq, InstResults, BoundInsts) ) ; Inst0 = any(Uniq, none_or_default_func), ( if type_is_higher_order_details(Type, _, pf_function, _, ArgTypes) then default_higher_order_func_inst(ModuleInfo, ArgTypes, PredInstInfo), Inst = any(Uniq, higher_order(PredInstInfo)) else type_to_ctor_det(Type, TypeCtor), constructors_to_bound_any_insts(ModuleInfo, Uniq, TypeCtor, Constructors, BoundInsts0), list.sort_and_remove_dups(BoundInsts0, BoundInsts), % Normally, Inst is not ground, and contains any. % But if all the Ctors are constants, it is ground, % and does not contain any. InstResults = inst_test_results( inst_result_groundness_unknown, inst_result_contains_any_unknown, inst_result_contains_inst_names_known(set.init), inst_result_contains_inst_vars_known(set.init), inst_result_contains_types_known(set.init), inst_result_type_ctor_propagated(TypeCtor) ), Inst = bound(Uniq, InstResults, BoundInsts) ) ; Inst0 = ground(Uniq, higher_order(PredInstInfo0)), PredInstInfo0 = pred_inst_info(PredOrFunc, Modes0, MaybeArgRegs, Det), ( if type_is_higher_order_details(Type, _, PredOrFunc, _, ArgTypes), list.same_length(ArgTypes, Modes0) then propagate_types_into_mode_list(ModuleInfo, ArgTypes, Modes0, Modes) else % The inst is not a valid inst for the type, so leave it alone. % This can only happen if the user has made a mistake. A mode % error should hopefully be reported if anything tries to match % with the inst. Modes = Modes0 ), PredInstInfo = pred_inst_info(PredOrFunc, Modes, MaybeArgRegs, Det), Inst = ground(Uniq, higher_order(PredInstInfo)) ; Inst0 = any(Uniq, higher_order(PredInstInfo0)), PredInstInfo0 = pred_inst_info(PredOrFunc, Modes0, MaybeArgRegs, Det), ( if type_is_higher_order_details(Type, _, PredOrFunc, _, ArgTypes), list.same_length(ArgTypes, Modes0) then propagate_types_into_mode_list(ModuleInfo, ArgTypes, Modes0, Modes) else % The inst is not a valid inst for the type, so leave it alone. % This can only happen if the user has made a mistake. A mode % error should hopefully be reported if anything tries to match % with the inst. Modes = Modes0 ), PredInstInfo = pred_inst_info(PredOrFunc, Modes, MaybeArgRegs, Det), Inst = any(Uniq, higher_order(PredInstInfo)) ; Inst0 = bound(_Uniq, _InstResult, _BoundInsts0), propagate_ctor_info_into_bound_inst(ModuleInfo, Type, Inst0, Inst) ; Inst0 = not_reached, Inst = Inst0 ; Inst0 = inst_var(_), Inst = Inst0 ; Inst0 = constrained_inst_vars(V, SubInst0), propagate_ctor_info(ModuleInfo, Type, Constructors, SubInst0, SubInst), Inst = constrained_inst_vars(V, SubInst) ; Inst0 = abstract_inst(_Name, _Args), Inst = Inst0 % XXX loses info ; Inst0 = defined_inst(InstName), inst_lookup(ModuleInfo, InstName, NamedInst), propagate_ctor_info(ModuleInfo, Type, Constructors, NamedInst, Inst) ). :- pred propagate_ctor_info_lazily(module_info::in, tsubst::in, mer_type::in, mer_inst::in, mer_inst::out) is det. propagate_ctor_info_lazily(ModuleInfo, Subst, Type0, Inst0, Inst) :- ( Inst0 = free, % Inst = free(Type0) Inst = free % XXX temporary hack ; Inst0 = free(_), unexpected($pred, "typeinfo already present") ; Inst0 = ground(Uniq, none_or_default_func), apply_type_subst(Type0, Subst, Type), ( if type_is_higher_order_details(Type, _, pf_function, _, ArgTypes) then default_higher_order_func_inst(ModuleInfo, ArgTypes, HOInstInfo), Inst = ground(Uniq, higher_order(HOInstInfo)) else % XXX The information added by this is not yet used, so % it is disabled since it unnecessarily complicates the insts. % % Inst = defined_inst(typed_ground(Uniq, Type)) Inst = ground(Uniq, none_or_default_func) ) ; Inst0 = any(Uniq, none_or_default_func), apply_type_subst(Type0, Subst, Type), ( if type_is_higher_order_details(Type, _, pf_function, _, ArgTypes) then default_higher_order_func_inst(ModuleInfo, ArgTypes, HOInstInfo), Inst = any(Uniq, higher_order(HOInstInfo)) else Inst = any(Uniq, none_or_default_func) ) ; Inst0 = ground(Uniq, higher_order(PredInstInfo0)), PredInstInfo0 = pred_inst_info(PredOrFunc, Modes0, MaybeArgRegs, Det), apply_type_subst(Type0, Subst, Type), ( if type_is_higher_order_details(Type, _, PredOrFunc, _, ArgTypes), list.same_length(ArgTypes, Modes0) then propagate_types_into_mode_list(ModuleInfo, ArgTypes, Modes0, Modes) else % The inst is not a valid inst for the type, so leave it alone. % This can only happen if the user has made a mistake. A mode error % should hopefully be reported if anything tries to match with the % inst. Modes = Modes0 ), PredInstInfo = pred_inst_info(PredOrFunc, Modes, MaybeArgRegs, Det), Inst = ground(Uniq, higher_order(PredInstInfo)) ; Inst0 = any(Uniq, higher_order(PredInstInfo0)), PredInstInfo0 = pred_inst_info(PredOrFunc, Modes0, MaybeArgRegs, Det), apply_type_subst(Type0, Subst, Type), ( if type_is_higher_order_details(Type, _, PredOrFunc, _, ArgTypes), list.same_length(ArgTypes, Modes0) then propagate_types_into_mode_list(ModuleInfo, ArgTypes, Modes0, Modes) else % The inst is not a valid inst for the type, so leave it alone. % This can only happen if the user has made a mistake. A mode error % should hopefully be reported if anything tries to match with the % inst. Modes = Modes0 ), PredInstInfo = pred_inst_info(PredOrFunc, Modes, MaybeArgRegs, Det), Inst = any(Uniq, higher_order(PredInstInfo)) ; Inst0 = bound(_Uniq, _InstResult, _BoundInsts0), apply_type_subst(Type0, Subst, Type), propagate_ctor_info_into_bound_inst(ModuleInfo, Type, Inst0, Inst) ; Inst0 = not_reached, Inst = Inst0 ; Inst0 = inst_var(_), Inst = Inst0 ; Inst0 = constrained_inst_vars(V, SubInst0), propagate_ctor_info_lazily(ModuleInfo, Subst, Type0, SubInst0, SubInst), Inst = constrained_inst_vars(V, SubInst) ; Inst0 = abstract_inst(_Name, _Args), Inst = Inst0 % XXX loses info ; Inst0 = defined_inst(InstName0), apply_type_subst(Type0, Subst, Type), ( if InstName0 = typed_inst(_, _) then % If this happens, it means that we have already lazily propagated % type info into this inst. We want to avoid creating insts of % the form typed_inst(_, typed_inst(...)), because that would be % unnecessary, and could cause efficiency problems or perhaps % even infinite loops. InstName = InstName0 else InstName = typed_inst(Type, InstName0) ), Inst = defined_inst(InstName) ). % If the user does not explicitly specify a higher-order inst % for a higher-order function type, it defaults to % `func(in, in, ..., in) = out is det', % i.e. all args input, return value output, and det. % This applies recursively to the arguments and return % value too. % :- pred default_higher_order_func_inst(module_info::in, list(mer_type)::in, pred_inst_info::out) is det. default_higher_order_func_inst(ModuleInfo, PredArgTypes, PredInstInfo) :- Ground = ground(shared, none_or_default_func), In = from_to_mode(Ground, Ground), Out = from_to_mode(free, Ground), list.length(PredArgTypes, NumPredArgs), NumFuncArgs = NumPredArgs - 1, list.duplicate(NumFuncArgs, In, FuncArgModes), FuncRetMode = Out, list.append(FuncArgModes, [FuncRetMode], PredArgModes0), propagate_types_into_mode_list(ModuleInfo, PredArgTypes, PredArgModes0, PredArgModes), PredInstInfo = pred_inst_info(pf_function, PredArgModes, arg_reg_types_unset, detism_det). constructors_to_bound_insts(ModuleInfo, Uniq, TypeCtor, Constructors, BoundInsts) :- constructors_to_bound_insts_loop_over_ctors(ModuleInfo, Uniq, TypeCtor, Constructors, ground(Uniq, none_or_default_func), BoundInsts). constructors_to_bound_any_insts(ModuleInfo, Uniq, TypeCtor, Constructors, BoundInsts) :- constructors_to_bound_insts_loop_over_ctors(ModuleInfo, Uniq, TypeCtor, Constructors, any(Uniq, none_or_default_func), BoundInsts). :- pred constructors_to_bound_insts_loop_over_ctors(module_info::in, uniqueness::in, type_ctor::in, list(constructor)::in, mer_inst::in, list(bound_inst)::out) is det. constructors_to_bound_insts_loop_over_ctors(_, _, _, [], _, []). constructors_to_bound_insts_loop_over_ctors(ModuleInfo, Uniq, TypeCtor, [Ctor | Ctors], ArgInst, [BoundInst | BoundInsts]) :- Ctor = ctor(_Ordinal, _MaybeExistConstraints, Name, Args, _Arity, _Ctxt), ctor_arg_list_to_inst_list(Args, ArgInst, Insts), list.length(Insts, Arity), BoundInst = bound_functor(cons(Name, Arity, TypeCtor), Insts), constructors_to_bound_insts_loop_over_ctors(ModuleInfo, Uniq, TypeCtor, Ctors, ArgInst, BoundInsts). :- pred ctor_arg_list_to_inst_list(list(constructor_arg)::in, mer_inst::in, list(mer_inst)::out) is det. ctor_arg_list_to_inst_list([], _, []). ctor_arg_list_to_inst_list([_ | Args], Inst, [Inst | Insts]) :- ctor_arg_list_to_inst_list(Args, Inst, Insts). propagate_ctor_info_into_bound_inst(ModuleInfo, Type, Inst0, Inst) :- Inst0 = bound(Uniq, InstResults0, BoundInsts0), ( if type_is_tuple(Type, TupleArgTypes) then list.map(propagate_ctor_info_tuple(ModuleInfo, TupleArgTypes), BoundInsts0, BoundInsts), % Tuples don't have a *conventional* type_ctor. PropagatedResult = inst_result_no_type_ctor_propagated, ConstructNewInst = yes else if type_to_ctor_and_args(Type, TypeCtor, TypeArgs), TypeCtor = type_ctor(qualified(TypeModule, _), _), module_info_get_type_table(ModuleInfo, TypeTable), search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn), hlds_data.get_type_defn_tparams(TypeDefn, TypeParams), hlds_data.get_type_defn_body(TypeDefn, TypeBody), OoMConstructors = TypeBody ^ du_type_ctors then ( if InstResults0 = inst_test_results(_, _, _, _, _, PropagatedResult0), PropagatedResult0 = inst_result_type_ctor_propagated(PropagatedTypeCtor), PropagatedTypeCtor = TypeCtor, TypeParams = [] then BoundInsts = BoundInsts0, PropagatedResult = PropagatedResult0, ConstructNewInst = no else map.from_corresponding_lists(TypeParams, TypeArgs, ArgSubst), Constructors = one_or_more_to_list(OoMConstructors), propagate_ctor_info_into_bound_functors(ModuleInfo, ArgSubst, TypeCtor, TypeModule, Constructors, BoundInsts0, BoundInsts1), list.sort(BoundInsts1, BoundInsts), PropagatedResult = inst_result_type_ctor_propagated(TypeCtor), ConstructNewInst = yes ) else % Builtin types don't need processing. BoundInsts = BoundInsts0, % dummy PropagatedResult = inst_result_no_type_ctor_propagated, % dummy ConstructNewInst = no ), % The code here would be slightly cleaner if ConstructNewInst's type % was maybe(list(bound_inst)), since we wouldn't have to set BoundInsts % and PropagatedResult if ConstructNewInst = no, but this predicate % is a performance bottleneck, so we want to minimize our memory % allocations. ( ConstructNewInst = no, Inst = Inst0 ; ConstructNewInst = yes, ( BoundInsts = [], Inst = not_reached ; BoundInsts = [_ | _], ( InstResults0 = inst_test_results_fgtc, InstResults = InstResults0 ; InstResults0 = inst_test_no_results, InstResults = inst_test_results(inst_result_groundness_unknown, inst_result_contains_any_unknown, inst_result_contains_inst_names_unknown, inst_result_contains_inst_vars_unknown, inst_result_contains_types_unknown, PropagatedResult) ; InstResults0 = inst_test_results(GroundNessResult0, ContainsAnyResult, _, _, _, _), % XXX I (zs) don't understand the predicate % propagate_ctor_info_into_bound_functors % well enough to figure out under what circumstances we could % keep the parts of InstResult0 we are clobbering here. InstResults = inst_test_results(GroundNessResult0, ContainsAnyResult, inst_result_contains_inst_names_unknown, inst_result_contains_inst_vars_unknown, inst_result_contains_types_unknown, PropagatedResult) ), % We shouldn't need to sort BoundInsts. The cons_ids in the % bound_insts in the list should have been either all typed % or all non-typed. If they were all typed, then pushing the % type_ctor into them should not have modified them. If they % were all non-typed, then pushing the same type_ctor into them all % should not have changed their order. Inst = bound(Uniq, InstResults, BoundInsts) ) ). :- pred propagate_ctor_info_tuple(module_info::in, list(mer_type)::in, bound_inst::in, bound_inst::out) is det. propagate_ctor_info_tuple(ModuleInfo, TupleArgTypes, BoundInst0, BoundInst) :- BoundInst0 = bound_functor(Functor, ArgInsts0), ( if Functor = tuple_cons(_), list.length(ArgInsts0, ArgInstsLen), list.length(TupleArgTypes, TupleArgTypesLen), ArgInstsLen = TupleArgTypesLen then map.init(Subst), propagate_types_into_inst_list(ModuleInfo, Subst, TupleArgTypes, ArgInsts0, ArgInsts) else % The bound_inst's arity does not match the tuple's arity, so leave it % alone. This can only happen in a user defined bound_inst. % A mode error should be reported if anything tries to match with % the inst. ArgInsts = ArgInsts0 ), BoundInst = bound_functor(Functor, ArgInsts). :- pred propagate_ctor_info_into_bound_functors(module_info::in, tsubst::in, type_ctor::in, module_name::in, list(constructor)::in, list(bound_inst)::in, list(bound_inst)::out) is det. propagate_ctor_info_into_bound_functors(_, _, _, _, _, [], []). propagate_ctor_info_into_bound_functors(ModuleInfo, Subst, TypeCtor, TypeModule, Constructors, [BoundInst0 | BoundInsts0], [BoundInst | BoundInsts]) :- BoundInst0 = bound_functor(ConsId0, ArgInsts0), ( if ConsId0 = cons(unqualified(Name), ConsArity, _ConsTypeCtor) then % _ConsTypeCtor should be either TypeCtor or cons_id_dummy_type_ctor. ConsId = cons(qualified(TypeModule, Name), ConsArity, TypeCtor) else ConsId = ConsId0 ), ( if ConsId = cons(ConsName, Arity, _), find_first_matching_constructor(ConsName, Arity, Constructors, MatchingConstructor) then MatchingConstructor = ctor(_Ordinal, _MaybeExistConstraints, _Name, Args, _Arity, _Ctxt), get_constructor_arg_types(Args, ArgTypes), propagate_types_into_inst_list(ModuleInfo, Subst, ArgTypes, ArgInsts0, ArgInsts), BoundInst = bound_functor(ConsId, ArgInsts) else % The cons_id is not a valid constructor for the type, % so leave it alone. This can only happen in a user defined % bound_inst. A mode error should be reported if anything % tries to match with the inst. BoundInst = bound_functor(ConsId, ArgInsts0) ), propagate_ctor_info_into_bound_functors(ModuleInfo, Subst, TypeCtor, TypeModule, Constructors, BoundInsts0, BoundInsts). % Find the first constructor in the egiven list of constructors % that match the given functor name and arity. Since the constructors % should all come from the same type definition, there should be % at most one matching constructor in the list anyway. % :- pred find_first_matching_constructor(sym_name::in, arity::in, list(constructor)::in, constructor::out) is semidet. find_first_matching_constructor(_ConsName, _Arity, [], _MatchingCtor) :- fail. find_first_matching_constructor(ConsName, Arity, [Ctor | Ctors], MatchingCtor) :- ( if Ctor = ctor(_, _, ConsName, _, Arity, _) then MatchingCtor = Ctor else find_first_matching_constructor(ConsName, Arity, Ctors, MatchingCtor) ). :- pred get_constructor_arg_types(list(constructor_arg)::in, list(mer_type)::out) is det. get_constructor_arg_types([], []). get_constructor_arg_types([Arg | Args], [ArgType | ArgTypes]) :- ArgType = Arg ^ arg_type, get_constructor_arg_types(Args, ArgTypes). :- pred apply_type_subst(mer_type::in, tsubst::in, mer_type::out) is det. apply_type_subst(Type0, Subst, Type) :- % Optimize common case. ( if map.is_empty(Subst) then Type = Type0 else apply_subst_to_type(Subst, Type0, Type) ). %---------------------------------------------------------------------------% mode_get_insts_semidet(_ModuleInfo, from_to_mode(InitialInst, FinalInst), InitialInst, FinalInst). mode_get_insts_semidet(ModuleInfo, user_defined_mode(Name, Args), Initial, Final) :- list.length(Args, Arity), module_info_get_mode_table(ModuleInfo, Modes), mode_table_get_mode_defns(Modes, ModeDefns), % Try looking up Name as-is. If that fails and Name is unqualified, % try looking it up with the builtin qualifier. % XXX This is a makeshift fix for a problem that requires more % investigation (without this fix the compiler occasionally % throws an exception in mode_get_insts/4). ( if map.search(ModeDefns, mode_ctor(Name, Arity), HLDS_Mode0) then HLDS_Mode = HLDS_Mode0 else Name = unqualified(String), BuiltinName = qualified(mercury_public_builtin_module, String), map.search(ModeDefns, mode_ctor(BuiltinName, Arity), HLDS_Mode) ), HLDS_Mode = hlds_mode_defn(_VarSet, Params, ModeDefn, _Context, _Status), ModeDefn = hlds_mode_body(Mode0), mode_substitute_arg_list(Mode0, Params, Args, Mode), mode_get_insts_semidet(ModuleInfo, Mode, Initial, Final). mode_get_insts(ModuleInfo, Mode, InitInst, FinalInst) :- ( if mode_get_insts_semidet(ModuleInfo, Mode, InitInstPrime, FinalInstPrime) then InitInst = InitInstPrime, FinalInst = FinalInstPrime else unexpected($pred, "mode_get_insts_semidet failed") ). mode_get_from_to_insts(ModuleInfo, Mode, FromToInsts) :- mode_get_insts(ModuleInfo, Mode, InitInst, FinalInst), FromToInsts = from_to_insts(InitInst, FinalInst). %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% :- type recompute_info ---> recompute_info( ri_module_info :: module_info, ri_inst_varset :: inst_varset ). % Use the instmap deltas for all the atomic sub-goals to recompute % the instmap deltas for all the non-atomic sub-goals of a goal. % Used to ensure that the instmap deltas remain valid after % code has been re-arranged, e.g. by followcode. % After common.m has been run, it may be necessary to recompute % instmap deltas for atomic goals, since more outputs of calls % and deconstructions may become non-local (XXX does this require % rerunning mode analysis rather than just recompute_instmap_delta?). % recompute_instmap_delta_proc(RecomputeAtomic, !ProcInfo, !ModuleInfo) :- proc_info_get_initial_instmap(!.ModuleInfo, !.ProcInfo, InstMap0), proc_info_get_vartypes(!.ProcInfo, VarTypes), proc_info_get_goal(!.ProcInfo, Goal0), proc_info_get_inst_varset(!.ProcInfo, InstVarSet), recompute_instmap_delta(RecomputeAtomic, Goal0, Goal, VarTypes, InstVarSet, InstMap0, !ModuleInfo), proc_info_set_goal(Goal, !ProcInfo). recompute_instmap_delta(RecomputeAtomic, Goal0, Goal, VarTypes, InstVarSet, InstMap0, ModuleInfo0, ModuleInfo) :- RI0 = recompute_info(ModuleInfo0, InstVarSet), recompute_instmap_delta_1(RecomputeAtomic, Goal0, Goal, VarTypes, InstMap0, _, RI0, RI), ModuleInfo = RI ^ ri_module_info. :- pred recompute_instmap_delta_1(recompute_atomic_instmap_deltas::in, hlds_goal::in, hlds_goal::out, vartypes::in, instmap::in, instmap_delta::out, recompute_info::in, recompute_info::out) is det. recompute_instmap_delta_1(RecomputeAtomic, Goal0, Goal, VarTypes, InstMap0, InstMapDelta, !RI) :- Goal0 = hlds_goal(GoalExpr0, GoalInfo0), ( GoalExpr0 = switch(Var, Det, Cases0), ( if goal_info_has_feature(GoalInfo0, feature_mode_check_clauses_goal) then Cases = Cases0, InstMapDelta1 = goal_info_get_instmap_delta(GoalInfo0) else NonLocals0 = goal_info_get_nonlocals(GoalInfo0), recompute_instmap_delta_cases(RecomputeAtomic, Var, Cases0, Cases, VarTypes, InstMap0, NonLocals0, InstMapDelta1, !RI) ), GoalExpr = switch(Var, Det, Cases) ; GoalExpr0 = conj(ConjType, Conjuncts0), recompute_instmap_delta_conj(RecomputeAtomic, Conjuncts0, Conjuncts, VarTypes, InstMap0, InstMapDelta1, !RI), GoalExpr = conj(ConjType, Conjuncts) ; GoalExpr0 = disj(Disjuncts0), ( if goal_info_has_feature(GoalInfo0, feature_mode_check_clauses_goal) then Disjuncts = Disjuncts0, InstMapDelta1 = goal_info_get_instmap_delta(GoalInfo0) else NonLocals0 = goal_info_get_nonlocals(GoalInfo0), recompute_instmap_delta_disj(RecomputeAtomic, Disjuncts0, Disjuncts, VarTypes, InstMap0, NonLocals0, InstMapDelta1, !RI) ), GoalExpr = disj(Disjuncts) ; GoalExpr0 = negation(SubGoal0), InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0), ( if instmap_delta_is_reachable(InstMapDelta0) then instmap_delta_init_reachable(InstMapDelta1) else instmap_delta_init_unreachable(InstMapDelta1) ), recompute_instmap_delta_1(RecomputeAtomic, SubGoal0, SubGoal, VarTypes, InstMap0, _, !RI), GoalExpr = negation(SubGoal) ; GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0), recompute_instmap_delta_1(RecomputeAtomic, Cond0, Cond, VarTypes, InstMap0, InstMapDeltaCond, !RI), apply_instmap_delta(InstMapDeltaCond, InstMap0, InstMapCond), recompute_instmap_delta_1(RecomputeAtomic, Then0, Then, VarTypes, InstMapCond, InstMapDeltaThen, !RI), recompute_instmap_delta_1(RecomputeAtomic, Else0, Else, VarTypes, InstMap0, InstMapDeltaElse, !RI), instmap_delta_apply_instmap_delta(InstMapDeltaCond, InstMapDeltaThen, test_size, InstMapDeltaCondThen), NonLocals0 = goal_info_get_nonlocals(GoalInfo0), ModuleInfo0 = !.RI ^ ri_module_info, merge_instmap_delta(InstMap0, NonLocals0, VarTypes, InstMapDeltaElse, InstMapDeltaCondThen, InstMapDelta1, ModuleInfo0, ModuleInfo), !RI ^ ri_module_info := ModuleInfo, GoalExpr = if_then_else(Vars, Cond, Then, Else) ; GoalExpr0 = scope(Reason, SubGoal0), ( if Reason = from_ground_term(_, FGT) then ( ( FGT = from_ground_term_construct ; FGT = from_ground_term_deconstruct ), SubGoal = SubGoal0, SubGoal = hlds_goal(_, SubGoalInfo), InstMapDelta1 = goal_info_get_instmap_delta(SubGoalInfo) ; FGT = from_ground_term_initial, unexpected($pred, "from_ground_term_initial") ; FGT = from_ground_term_other, recompute_instmap_delta_1(RecomputeAtomic, SubGoal0, SubGoal, VarTypes, InstMap0, InstMapDelta1, !RI) ) else recompute_instmap_delta_1(RecomputeAtomic, SubGoal0, SubGoal, VarTypes, InstMap0, InstMapDelta1, !RI) ), GoalExpr = scope(Reason, SubGoal) ; GoalExpr0 = generic_call(_Details, Vars, Modes, _, Detism), ( RecomputeAtomic = do_not_recompute_atomic_instmap_deltas, InstMapDelta1 = goal_info_get_instmap_delta(GoalInfo0) ; RecomputeAtomic = recompute_atomic_instmap_deltas, ( if determinism_components(Detism, _, at_most_zero) then instmap_delta_init_unreachable(InstMapDelta1) else ModuleInfo = !.RI ^ ri_module_info, instmap_delta_from_mode_list(ModuleInfo, Vars, Modes, InstMapDelta1) ) ), GoalExpr = GoalExpr0 ; GoalExpr0 = plain_call(PredId, ProcId, Args, _BI, _UC, _Name), ( RecomputeAtomic = do_not_recompute_atomic_instmap_deltas, InstMapDelta1 = goal_info_get_instmap_delta(GoalInfo0) ; RecomputeAtomic = recompute_atomic_instmap_deltas, recompute_instmap_delta_call(PredId, ProcId, Args, VarTypes, InstMap0, InstMapDelta1, !RI) ), GoalExpr = GoalExpr0 ; GoalExpr0 = unify(LHS, RHS0, UniMode0, Uni, Context), ( RHS0 = rhs_lambda_goal(Purity, Groundness, PorF, EvalMethod, LambdaNonLocals, LambdaVars, Modes, Det, SubGoal0), ModuleInfo0 = !.RI ^ ri_module_info, instmap.pre_lambda_update(ModuleInfo0, LambdaVars, Modes, InstMap0, InstMap), recompute_instmap_delta_1(RecomputeAtomic, SubGoal0, SubGoal, VarTypes, InstMap, _, !RI), RHS = rhs_lambda_goal(Purity, Groundness, PorF, EvalMethod, LambdaNonLocals, LambdaVars, Modes, Det, SubGoal) ; ( RHS0 = rhs_var(_) ; RHS0 = rhs_functor(_, _, _) ), RHS = RHS0 ), ( RecomputeAtomic = do_not_recompute_atomic_instmap_deltas, UniMode = UniMode0, InstMapDelta1 = goal_info_get_instmap_delta(GoalInfo0) ; RecomputeAtomic = recompute_atomic_instmap_deltas, recompute_instmap_delta_unify(Uni, UniMode0, UniMode, GoalInfo0, InstMap0, InstMapDelta1, !RI) ), GoalExpr = unify(LHS, RHS, UniMode, Uni, Context) ; GoalExpr0 = call_foreign_proc(_Attr, PredId, ProcId, Args, ExtraArgs, _MTRC, _Impl), ( RecomputeAtomic = do_not_recompute_atomic_instmap_deltas, InstMapDelta1 = goal_info_get_instmap_delta(GoalInfo0) ; RecomputeAtomic = recompute_atomic_instmap_deltas, ArgVars = list.map(foreign_arg_var, Args), recompute_instmap_delta_call(PredId, ProcId, ArgVars, VarTypes, InstMap0, InstMapDelta0, !RI), ( ExtraArgs = [], InstMapDelta1 = InstMapDelta0 ; ExtraArgs = [_ | _], OldInstMapDelta = goal_info_get_instmap_delta(GoalInfo0), ExtraArgVars = list.map(foreign_arg_var, ExtraArgs), instmap_delta_restrict(set_of_var.list_to_set(ExtraArgVars), OldInstMapDelta, ExtraArgsInstMapDelta), instmap_delta_apply_instmap_delta(InstMapDelta0, ExtraArgsInstMapDelta, large_base, InstMapDelta1) ) ), GoalExpr = GoalExpr0 ; GoalExpr0 = shorthand(ShortHand0), ( ShortHand0 = atomic_goal(GoalType, Outer, Inner, MaybeOutputVars, MainGoal0, OrElseGoals0, OrElseInners), Goals0 = [MainGoal0 | OrElseGoals0], NonLocals0 = goal_info_get_nonlocals(GoalInfo0), recompute_instmap_delta_disj(RecomputeAtomic, Goals0, Goals, VarTypes, InstMap0, NonLocals0, InstMapDelta1, !RI), ( Goals = [], unexpected($pred, "Goals = []") ; Goals = [MainGoal | OrElseGoals] ), ShortHand = atomic_goal(GoalType, Outer, Inner, MaybeOutputVars, MainGoal, OrElseGoals, OrElseInners) ; ShortHand0 = try_goal(MaybeIO, ResultVar, SubGoal0), recompute_instmap_delta_1(RecomputeAtomic, SubGoal0, SubGoal, VarTypes, InstMap0, InstMapDelta1, !RI), ShortHand = try_goal(MaybeIO, ResultVar, SubGoal) ; ShortHand0 = bi_implication(_, _), % These should have been expanded out by now. unexpected($pred, "bi_implication") ), GoalExpr = shorthand(ShortHand) ), % If the initial instmap is unreachable, so is the final instmap. ( if instmap_is_unreachable(InstMap0) then instmap_delta_init_unreachable(InstMapDelta) else NonLocals = goal_info_get_nonlocals(GoalInfo0), instmap_delta_restrict(NonLocals, InstMapDelta1, InstMapDelta) ), goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo), Goal = hlds_goal(GoalExpr, GoalInfo). %---------------------------------------------------------------------------% :- pred recompute_instmap_delta_conj(recompute_atomic_instmap_deltas::in, list(hlds_goal)::in, list(hlds_goal)::out, vartypes::in, instmap::in, instmap_delta::out, recompute_info::in, recompute_info::out) is det. recompute_instmap_delta_conj(_, [], [], _, _, InstMapDelta, !RI) :- instmap_delta_init_reachable(InstMapDelta). recompute_instmap_delta_conj(RecomputeAtomic, [Goal0 | Goals0], [Goal | Goals], VarTypes, InstMap0, InstMapDelta, !RI) :- recompute_instmap_delta_1(RecomputeAtomic, Goal0, Goal, VarTypes, InstMap0, InstMapDelta0, !RI), apply_instmap_delta(InstMapDelta0, InstMap0, InstMap1), recompute_instmap_delta_conj(RecomputeAtomic, Goals0, Goals, VarTypes, InstMap1, InstMapDelta1, !RI), instmap_delta_apply_instmap_delta(InstMapDelta0, InstMapDelta1, large_overlay, InstMapDelta). %---------------------------------------------------------------------------% :- pred recompute_instmap_delta_disj(recompute_atomic_instmap_deltas::in, list(hlds_goal)::in, list(hlds_goal)::out, vartypes::in, instmap::in, set_of_progvar::in, instmap_delta::out, recompute_info::in, recompute_info::out) is det. recompute_instmap_delta_disj(RecomputeAtomic, Goals0, Goals, VarTypes, InstMap, NonLocals, InstMapDelta, !RI) :- recompute_instmap_delta_disj_2(RecomputeAtomic, Goals0, Goals, VarTypes, InstMap, NonLocals, InstMapDeltas, !RI), ( InstMapDeltas = [], instmap_delta_init_unreachable(InstMapDelta) ; InstMapDeltas = [_ | _], ModuleInfo0 = !.RI ^ ri_module_info, merge_instmap_deltas(InstMap, NonLocals, VarTypes, InstMapDeltas, InstMapDelta, ModuleInfo0, ModuleInfo), !RI ^ ri_module_info := ModuleInfo ). :- pred recompute_instmap_delta_disj_2(recompute_atomic_instmap_deltas::in, list(hlds_goal)::in, list(hlds_goal)::out, vartypes::in, instmap::in, set_of_progvar::in, list(instmap_delta)::out, recompute_info::in, recompute_info::out) is det. recompute_instmap_delta_disj_2(_RecomputeAtomic, [], [], _VarTypes, _InstMap, _NonLocals, [], !RI). recompute_instmap_delta_disj_2(RecomputeAtomic, [Goal0 | Goals0], [Goal | Goals], VarTypes, InstMap, NonLocals, [InstMapDelta | InstMapDeltas], !RI) :- recompute_instmap_delta_1(RecomputeAtomic, Goal0, Goal, VarTypes, InstMap, InstMapDelta, !RI), recompute_instmap_delta_disj_2(RecomputeAtomic, Goals0, Goals, VarTypes, InstMap, NonLocals, InstMapDeltas, !RI). %---------------------------------------------------------------------------% :- pred recompute_instmap_delta_cases(recompute_atomic_instmap_deltas::in, prog_var::in, list(case)::in, list(case)::out, vartypes::in, instmap::in, set_of_progvar::in, instmap_delta::out, recompute_info::in, recompute_info::out) is det. recompute_instmap_delta_cases(RecomputeAtomic, Var, Cases0, Cases, VarTypes, InstMap0, NonLocals, InstMapDelta, !RI) :- recompute_instmap_delta_cases_2(RecomputeAtomic, Var, Cases0, Cases, VarTypes, InstMap0, NonLocals, InstMapDeltas, !RI), ( InstMapDeltas = [], instmap_delta_init_unreachable(InstMapDelta) ; InstMapDeltas = [_ | _], ModuleInfo0 = !.RI ^ ri_module_info, merge_instmap_deltas(InstMap0, NonLocals, VarTypes, InstMapDeltas, InstMapDelta, ModuleInfo0, ModuleInfo), !RI ^ ri_module_info := ModuleInfo ). :- pred recompute_instmap_delta_cases_2(recompute_atomic_instmap_deltas::in, prog_var::in, list(case)::in, list(case)::out, vartypes::in, instmap::in, set_of_progvar::in, list(instmap_delta)::out, recompute_info::in, recompute_info::out) is det. recompute_instmap_delta_cases_2(_RecomputeAtomic, _Var, [], [], _VarTypes, _InstMap, _NonLocals, [], !RI). recompute_instmap_delta_cases_2(RecomputeAtomic, Var, [Case0 | Cases0], [Case | Cases], VarTypes, InstMap0, NonLocals, [InstMapDelta | InstMapDeltas], !RI) :- Case0 = case(MainConsId, OtherConsIds, Goal0), lookup_var_type(VarTypes, Var, Type), ModuleInfo0 = !.RI ^ ri_module_info, bind_var_to_functors(Var, Type, MainConsId, OtherConsIds, InstMap0, InstMap1, ModuleInfo0, ModuleInfo1), !RI ^ ri_module_info := ModuleInfo1, recompute_instmap_delta_1(RecomputeAtomic, Goal0, Goal, VarTypes, InstMap1, InstMapDelta0, !RI), ModuleInfo2 = !.RI ^ ri_module_info, instmap_delta_bind_var_to_functors(Var, Type, MainConsId, OtherConsIds, InstMap0, InstMapDelta0, InstMapDelta, ModuleInfo2, ModuleInfo3), !RI ^ ri_module_info := ModuleInfo3, Case = case(MainConsId, OtherConsIds, Goal), recompute_instmap_delta_cases_2(RecomputeAtomic, Var, Cases0, Cases, VarTypes, InstMap0, NonLocals, InstMapDeltas, !RI). %---------------------------------------------------------------------------% :- pred recompute_instmap_delta_call(pred_id::in, proc_id::in, list(prog_var)::in, vartypes::in, instmap::in, instmap_delta::out, recompute_info::in, recompute_info::out) is det. recompute_instmap_delta_call(PredId, ProcId, Args, VarTypes, InstMap, InstMapDelta, !RI) :- ModuleInfo0 = !.RI ^ ri_module_info, module_info_pred_proc_info(ModuleInfo0, PredId, ProcId, _, ProcInfo), proc_info_interface_determinism(ProcInfo, Detism), ( if determinism_components(Detism, _, at_most_zero) then instmap_delta_init_unreachable(InstMapDelta) else proc_info_get_argmodes(ProcInfo, ArgModes0), proc_info_get_inst_varset(ProcInfo, ProcInstVarSet), InstVarSet0 = !.RI ^ ri_inst_varset, rename_apart_inst_vars(InstVarSet0, ProcInstVarSet, InstVarSet, ArgModes0, ArgModes1), !RI ^ ri_inst_varset := InstVarSet, mode_list_get_initial_insts(ModuleInfo0, ArgModes1, InitialInsts), % Compute the inst_var substitution from the initial insts % of the called procedure and the insts of the argument variables. ( if instmap_is_reachable(InstMap) then map.init(InstVarSub0), compute_inst_var_sub(Args, VarTypes, InstMap, InitialInsts, InstVarSub0, InstVarSub, ModuleInfo0, ModuleInfo1), % Apply the inst_var substitution to the argument modes. mode_list_apply_substitution(InstVarSub, ArgModes1, ArgModes2), % Calculate the final insts of the argument variables from their % initial insts and the final insts of the called procedure % (with inst_var substitutions applied). recompute_instmap_delta_call_2(Args, InstMap, ArgModes2, ArgModes, ModuleInfo1, ModuleInfo), !RI ^ ri_module_info := ModuleInfo else list.length(Args, NumArgs), list.duplicate(NumArgs, from_to_mode(not_reached, not_reached), ArgModes), ModuleInfo = ModuleInfo0 ), instmap_delta_from_mode_list(ModuleInfo, Args, ArgModes, InstMapDelta) ). :- pred compute_inst_var_sub(list(prog_var)::in, vartypes::in, instmap::in, list(mer_inst)::in, inst_var_sub::in, inst_var_sub::out, module_info::in, module_info::out) is det. compute_inst_var_sub([], _, _, [], !Sub, !ModuleInfo). compute_inst_var_sub([_ | _], _, _, [], !Sub, !ModuleInfo) :- unexpected($pred, "length mismatch"). compute_inst_var_sub([], _, _, [_ | _], !Sub, !ModuleInfo) :- unexpected($pred, "length mismatch"). compute_inst_var_sub([Arg | Args], VarTypes, InstMap, [Inst | Insts], !Sub, !ModuleInfo) :- % This is similar to modecheck_var_has_inst. SaveModuleInfo = !.ModuleInfo, SaveSub = !.Sub, instmap_lookup_var(InstMap, Arg, ArgInst), lookup_var_type(VarTypes, Arg, Type), ( if inst_matches_initial_sub(ArgInst, Inst, Type, !ModuleInfo, !Sub) then true else % error("compute_inst_var_sub: " ++ % ++ "inst_matches_initial failed") % XXX We shouldn't ever get here, but unfortunately % the mode system currently has several problems (most % noticeably lack of alias tracking for unique modes) % which mean inst_matches_initial can sometimes fail here. !:ModuleInfo = SaveModuleInfo, !:Sub = SaveSub ), compute_inst_var_sub(Args, VarTypes, InstMap, Insts, !Sub, !ModuleInfo). :- pred recompute_instmap_delta_call_2(list(prog_var)::in, instmap::in, list(mer_mode)::in, list(mer_mode)::out, module_info::in, module_info::out) is det. recompute_instmap_delta_call_2([], _, [], [], !ModuleInfo). recompute_instmap_delta_call_2([_ | _], _, [], _, !ModuleInfo) :- unexpected($pred, "length mismatch"). recompute_instmap_delta_call_2([], _, [_ | _], _, !ModuleInfo) :- unexpected($pred, "length mismatch"). recompute_instmap_delta_call_2([Arg | Args], InstMap, [Mode0 | Modes0], [Mode | Modes], !ModuleInfo) :- % This is similar to modecheck_set_var_inst. instmap_lookup_var(InstMap, Arg, ArgInst0), mode_get_insts(!.ModuleInfo, Mode0, _, FinalInst), ( if % The is_dead allows abstractly_unify_inst to succeed when % some parts of ArgInst0 and the corresponding parts of FinalInst % are free. % XXX There should be a better way to communicate that information. abstractly_unify_inst(is_dead, ArgInst0, FinalInst, fake_unify, UnifyInst, _, !ModuleInfo) then Mode = from_to_mode(ArgInst0, UnifyInst) else unexpected($pred, "unify_inst failed") ), recompute_instmap_delta_call_2(Args, InstMap, Modes0, Modes, !ModuleInfo). :- pred recompute_instmap_delta_unify(unification::in, unify_mode::in, unify_mode::out, hlds_goal_info::in, instmap::in, instmap_delta::out, recompute_info::in, recompute_info::out) is det. recompute_instmap_delta_unify(Unification, UniMode0, UniMode, GoalInfo, InstMap, InstMapDelta, !RI) :- % Deconstructions are the only types of unifications that can require % updating of the instmap_delta after simplify.m has been run. % Type specialization may require constructions of type-infos, % typeclass-infos or predicate constants to be added to the % instmap_delta. ModuleInfo0 = !.RI ^ ri_module_info, ( Unification = deconstruct(LHSVar, _ConsId, RHSVars, ArgModes, _, _CanCGC), % Get the final inst of the deconstructed var, which will be the same % as in the old instmap. OldInstMapDelta = goal_info_get_instmap_delta(GoalInfo), instmap_lookup_var(InstMap, LHSVar, LHSInitialInst), ( if instmap_delta_search_var(OldInstMapDelta, LHSVar, DeltaInst) then % Inlining can result in situations where the initial inst % (from procedure 1) can decide that a variable must be bound % to one set of function symbols, while the instmap delta from % a later unification (from procedure 2) can say that it is bound % to a different, non-overlapping set of function symbols. % % The is_dead allows abstractly_unify_inst to succeed when some % parts of InitialInst and the corresponding parts of DeltaInst % are free. % XXX There should be a better way to communicate that information. ( if abstractly_unify_inst(is_dead, LHSInitialInst, DeltaInst, fake_unify, LHSFinalInstPrime, _Detism, ModuleInfo0, ModuleInfo1) then LHSFinalInst = LHSFinalInstPrime, ModuleInfo = ModuleInfo1, !RI ^ ri_module_info := ModuleInfo else unexpected($pred, "abstractly_unify_inst failed") ) else % It wasn't in the instmap_delta, so the inst didn't change. LHSFinalInst = LHSInitialInst, ModuleInfo = ModuleInfo0 ), LHSTuple = var_init_final_insts(LHSVar, LHSInitialInst, LHSFinalInst), pair_arg_vars_with_rhs_insts(RHSVars, ArgModes, RHSTuples), instmap_delta_from_var_init_final_insts(ModuleInfo, [LHSTuple | RHSTuples], InstMapDelta), UniMode = UniMode0 ; Unification = construct(Var, ConsId, Args, _, _, _, _), ( if NonLocals = goal_info_get_nonlocals(GoalInfo), set_of_var.member(NonLocals, Var), OldInstMapDelta = goal_info_get_instmap_delta(GoalInfo), not instmap_delta_search_var(OldInstMapDelta, Var, _), MaybeInst = cons_id_to_shared_inst(ModuleInfo0, ConsId, list.length(Args)), MaybeInst = yes(Inst) then UniMode = UniMode0, instmap_delta_init_reachable(InstMapDelta0), instmap_delta_set_var(Var, Inst, InstMapDelta0, InstMapDelta) else InstMapDelta = goal_info_get_instmap_delta(GoalInfo), UniMode = UniMode0 ) ; ( Unification = assign(_, _) ; Unification = simple_test(_, _) ; Unification = complicated_unify(_, _, _) ), InstMapDelta = goal_info_get_instmap_delta(GoalInfo), UniMode = UniMode0 ). :- pred pair_arg_vars_with_rhs_insts(list(prog_var)::in, list(unify_mode)::in, list(var_init_final_insts)::out) is det. pair_arg_vars_with_rhs_insts([], [], []). pair_arg_vars_with_rhs_insts([], [_ | _], _) :- unexpected($pred, "mismatched list lengths"). pair_arg_vars_with_rhs_insts([_ | _], [], _) :- unexpected($pred, "mismatched list lengths"). pair_arg_vars_with_rhs_insts([RHSVar | RHSVars], [UnifyMode | UnifyModes], [Tuple | Tuples]) :- UnifyMode = unify_modes_li_lf_ri_rf(_, _, InitRHS, FinalRHS), Tuple = var_init_final_insts(RHSVar, InitRHS, FinalRHS), pair_arg_vars_with_rhs_insts(RHSVars, UnifyModes, Tuples). % For a builtin constructor, return the inst of the constructed term. % Handling user-defined constructors properly would require running % mode analysis again. % :- func cons_id_to_shared_inst(module_info, cons_id, int) = maybe(mer_inst). cons_id_to_shared_inst(ModuleInfo, ConsId, NumArgs) = MaybeInst :- ( ( ConsId = cons(_, _, _) ; ConsId = tuple_cons(_) ), MaybeInst = no ; % Note that before the change that introduced the char_const functor, % we used to handle character constants as user-defined cons_ids. ( ConsId = int_const(_) ; ConsId = uint_const(_) ; ConsId = int8_const(_) ; ConsId = uint8_const(_) ; ConsId = int16_const(_) ; ConsId = uint16_const(_) ; ConsId = int32_const(_) ; ConsId = uint32_const(_) ; ConsId = int64_const(_) ; ConsId = uint64_const(_) ; ConsId = float_const(_) ; ConsId = char_const(_) ; ConsId = string_const(_) ), MaybeInst = yes(bound(shared, inst_test_results_fgtc, [bound_functor(ConsId, [])])) ; ConsId = impl_defined_const(_), unexpected($pred, "impl_defined_const") ; ConsId = closure_cons(PredProcId, _), module_info_pred_proc_info(ModuleInfo, unshroud_pred_proc_id(PredProcId), PredInfo, ProcInfo), PorF = pred_info_is_pred_or_func(PredInfo), proc_info_interface_determinism(ProcInfo, Det), proc_info_get_argmodes(ProcInfo, ProcArgModes), list.det_drop(NumArgs, ProcArgModes, Modes), Inst = ground(shared, higher_order(pred_inst_info(PorF, Modes, arg_reg_types_unset, Det))), MaybeInst = yes(Inst) ; ( 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(_) ), MaybeInst = yes(ground(shared, none_or_default_func)) ). %---------------------------------------------------------------------------% get_arg_lives(_, [], []). get_arg_lives(ModuleInfo, [Mode | Modes], [IsLive | IsLives]) :- % Arguments with final inst `clobbered' are dead, any others % are assumed to be live. mode_get_insts(ModuleInfo, Mode, _InitialInst, FinalInst), ( if inst_is_clobbered(ModuleInfo, FinalInst) then IsLive = is_dead else IsLive = is_live ), get_arg_lives(ModuleInfo, Modes, IsLives). %---------------------------------------------------------------------------% fixup_instmap_switch_var(Var, InstMap0, InstMap, Goal0, Goal) :- Goal0 = hlds_goal(GoalExpr, GoalInfo0), InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0), instmap_lookup_var(InstMap0, Var, Inst0), instmap_lookup_var(InstMap, Var, Inst), ( if Inst = Inst0 then GoalInfo = GoalInfo0 else instmap_delta_set_var(Var, Inst, InstMapDelta0, InstMapDelta), goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo) ), Goal = hlds_goal(GoalExpr, GoalInfo). %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% normalise_insts(_, [], [], []). normalise_insts(_, [], [_ | _], _) :- unexpected($pred, "length mismatch"). normalise_insts(_, [_ | _], [], _) :- unexpected($pred, "length mismatch"). normalise_insts(ModuleInfo, [Type | Types], [Inst0 | Insts0], [Inst | Insts]) :- normalise_inst(ModuleInfo, Type, Inst0, Inst), normalise_insts(ModuleInfo, Types, Insts0, Insts). normalise_inst(ModuleInfo, Type, Inst0, NormalisedInst) :- % This is a bit of a hack. % The aim is to avoid non-termination due to the creation % of ever-expanding insts. % XXX should also normalise partially instantiated insts. inst_expand(ModuleInfo, Inst0, Inst), ( if Inst = bound(_, _, _) then ( if % Don't infer unique modes for introduced type_info arguments, % because that leads to an increase in the number of inferred modes % without any benefit. not is_introduced_type_info_type(Type), inst_is_ground(ModuleInfo, Inst), ( if inst_is_unique(ModuleInfo, Inst) then Uniq = unique else if inst_is_mostly_unique(ModuleInfo, Inst) then Uniq = mostly_unique else fail ), not inst_contains_nondefault_func_mode(ModuleInfo, Inst) then NormalisedInst = ground(Uniq, none_or_default_func) else if inst_is_ground(ModuleInfo, Inst), not inst_is_clobbered(ModuleInfo, Inst), not inst_contains_nondefault_func_mode(ModuleInfo, Inst) then NormalisedInst = ground(shared, none_or_default_func) else % XXX We need to limit the potential size of insts here % in order to avoid infinite loops in mode inference. NormalisedInst = Inst ) else NormalisedInst = Inst ). %---------------------------------------------------------------------------% partition_args(_, [], [], [], []). partition_args(_, [], [_ | _], _, _) :- unexpected($pred, "length mismatch"). partition_args(_, [_ | _], [], _, _) :- unexpected($pred, "length mismatch"). partition_args(ModuleInfo, [ArgMode | ArgModes], [Arg | Args], !:InputArgs, !:OutputArgs) :- partition_args(ModuleInfo, ArgModes, Args, !:InputArgs, !:OutputArgs), ( if mode_is_input(ModuleInfo, ArgMode) then !:InputArgs = [Arg | !.InputArgs] else !:OutputArgs = [Arg | !.OutputArgs] ). %---------------------------------------------------------------------------% :- end_module check_hlds.mode_util. %---------------------------------------------------------------------------%