%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2012 The University of Melbourne.
% Copyright (C) 2013-2024 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: float_regs.m
% Author: wangp.
%
% In the following we assume that Mercury `float' is wider than a word,
% and that we are targeting a Mercury abstract machine with float registers.
% The module is not used otherwise.
%
% Arguments in first-order calls are passed via float registers if the formal
% parameter has type `float' or equivalent. All other arguments are passed via
% regular registers.
%
% Higher-order calls are complicated by polymorphism. A procedure of type
% `pred(float)' may be an argument to another procedure, where that argument
% position has type `pred(T)'. Calling that higher-order term should place
% its argument into a regular register (since it is polymorphic), but the
% actual procedure expects its argument in a float register.
%
% We deal with these problems of incompatible calling conventions by
% substituting wrapper closures over the original higher-order terms, when the
% original higher-order term is passed to a callee or stored in a data term,
% where the expected calling convention is different. See below for examples.
%
% As we have seen, a higher-order type does not identify the register class for
% each argument. A higher-order inst already contains information about the
% calling convention to use for a term with that inst: the argument modes.
% In this module, we extend higher-order insts to record the register class
% that must be used for each argument, e.g.
%
%       pred(in, out, out) is det /* arg regs: [reg_r, reg_r, reg_f] */
%
% indicates that the first and second arguments must be passed via regular
% registers, and the third argument must be passed via a float register.
%
%---------------------------------------------------------------------------%
%
% EXAMPLE 1
% ---------
%
%   :- pred get_q(pred(T, T)).
%   :- mode get_q(out(pred(in, out) is det)) is det.
%
%   p(X) :-
%       get_q(Q),
%       call(Q, 1.0, X).
%
% Q has type `pred(float, float)'. Without other information, we would
% incorrectly assume that the call to Q should pass the float arguments in via
% the float registers. Information about the required register class for each
% call argument can be added to the higher-order inst.
%
%   :- pred get_q(pred(T, T)).
%   :- mode get_q(out(pred(in, out) is det /* arg regs: [reg_r, reg_r] */))
%       is det.
%
%   p(X) :-
%       get_q(Q),
%       % new insts:
%       % Q -> pred(in, out) is det /* arg regs: [reg_r, reg_r] */
%       call(Q, 1.0, X).
%       % arg regs: [reg_r, reg_r]
%
% The higher-order inst will force the call to Q to pass float arguments via
% regular registers instead of float registers.
%
% EXAMPLE 2
% ---------
%
%   :- pred foo(float) is semidet.
%   :- pred q(pred(T)::in(pred(in) is semidet /* arg regs: [reg_r] */), T::in)
%       is semidet.
%
%   p :-
%       F = foo,            /* arg regs: [reg_f] */
%       q(F, 1.0).          /* F incompatible */
%
% becomes
%
%   p :-
%       F = foo,            /* arg regs: [reg_f] */
%       F1 = wrapper1(F),   /* arg regs: [reg_r] */
%       q(F1, 1.0).
%
%   :- pred wrapper(
%       pred(float)::in(pred(in) is semidet /* arg regs: [reg_f] */),
%       float::in) is semidet.
%
%   wrapper1(F, X) :- /* must use reg_r: X */
%       call(F, X).
%
% The wrapper1 predicate has an annotation that causes the code generator to
% use a regular register for the argument X.
%
% EXAMPLE 3
% ---------
%
%   :- type foo(T) ---> mkfoo(pred(T, T)).
%   :- inst mkfoo  ---> mkfoo(pred(in, out) is det).
%
%   :- pred p(foo(float)::out(mkfoo)) is det.
%   :- pred q(float::in, float::in) is det.
%
%   p(Foo) :-
%       Q = q,              /* arg regs: [reg_f, reg_f] */
%       Foo = mkfoo(Q).
%       ...
%
% becomes
%
%   p(Foo) :-
%       Q = q,              /* arg regs: [reg_f, reg_f] */
%       Q1 = wrapper2(Q),   /* arg regs: [reg_r, reg_r] */
%       Foo = mkfoo(Q1).
%
% `q' needs to be wrapped in argument of `mkfoo'. Foo has type `foo(float)'
% but may be passed to a procedure with the argument type `foo(T)'.
% Then `q' could be extracted from Foo, and called with arguments placed in
% the regular registers.
%
%---------------------------------------------------------------------------%

:- module transform_hlds.float_regs.
:- interface.

:- import_module hlds.
:- import_module hlds.hlds_module.
:- import_module parse_tree.
:- import_module parse_tree.error_spec.

:- import_module list.

%---------------------------------------------------------------------------%

:- pred insert_reg_wrappers(module_info::in, module_info::out,
    list(error_spec)::out) is det.

%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%

:- implementation.

:- import_module check_hlds.
:- import_module check_hlds.inst_lookup.
:- import_module check_hlds.inst_test.
:- import_module check_hlds.inst_util.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.recompute_instmap_deltas.
:- import_module check_hlds.type_util.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_class.
:- import_module hlds.hlds_error_util.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_proc_util.
:- import_module hlds.instmap.
:- import_module hlds.passes_aux.
:- import_module hlds.pred_name.
:- import_module hlds.quantification.
:- import_module mdbcomp.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_construct.
:- import_module parse_tree.prog_type_test.
:- import_module parse_tree.set_of_var.
:- import_module parse_tree.var_table.
:- import_module transform_hlds.lambda.

:- import_module assoc_list.
:- import_module bool.
:- import_module int.
:- import_module io.
:- import_module map.
:- import_module maybe.
:- import_module pair.
:- import_module require.
:- import_module set.
:- import_module varset.

%---------------------------------------------------------------------------%

insert_reg_wrappers(!ModuleInfo, Specs) :-
    % In the first phase, update the pred_inst_infos in argument modes to
    % include information about the register type that should be used for
    % each higher-order argument.
    module_info_get_valid_pred_ids(!.ModuleInfo, PredIds),
    list.foldl(add_arg_regs_in_pred, PredIds, !ModuleInfo),

    % In the second phase, go over every procedure goal, update instmap deltas
    % to include the information from pred_inst_infos. When a higher-order
    % variable has an inst that indicates it uses a different calling
    % convention from that required in a given context, replace that variable
    % with a wrapper closure which has the expected calling convention.
    list.foldl2(insert_reg_wrappers_pred, PredIds, !ModuleInfo, [], Specs),
    module_info_clobber_dependency_info(!ModuleInfo).

%---------------------------------------------------------------------------%
%
% First phase.
%

:- pred add_arg_regs_in_pred(pred_id::in, module_info::in, module_info::out)
    is det.

add_arg_regs_in_pred(PredId, !ModuleInfo) :-
    module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
    ProcIds = pred_info_all_procids(PredInfo0),
    list.foldl(add_arg_regs_in_proc(!.ModuleInfo), ProcIds,
        PredInfo0, PredInfo),
    module_info_set_pred_info(PredId, PredInfo, !ModuleInfo).

:- pred add_arg_regs_in_proc(module_info::in, proc_id::in,
    pred_info::in, pred_info::out) is det.

add_arg_regs_in_proc(ModuleInfo, ProcId, PredInfo0, PredInfo) :-
    pred_info_get_markers(PredInfo0, PredMarkers),
    pred_info_proc_info(PredInfo0, ProcId, ProcInfo0),
    proc_info_get_argmodes(ProcInfo0, ArgModes0),
    ( if check_marker(PredMarkers, marker_class_instance_method) then
        % For class instance methods use the argument types before
        % instance types were substituted. The list of arguments in the
        % procedure may be longer due to type_infos and typeclass_infos.
        pred_info_get_instance_method_arg_types(PredInfo0, IM_ArgTypes),
        list.length(IM_ArgTypes, Num_IM_ArgTypes),
        split_list_from_end(Num_IM_ArgTypes, ArgModes0, FrontModes,
            ArgModes1),
        list.map_corresponding(add_arg_regs_in_proc_arg(ModuleInfo),
            IM_ArgTypes, ArgModes1, ArgModes2),
        ArgModes = FrontModes ++ ArgModes2
    else
        pred_info_get_arg_types(PredInfo0, ArgTypes),
        list.map_corresponding(add_arg_regs_in_proc_arg(ModuleInfo),
            ArgTypes, ArgModes0, ArgModes)
    ),
    proc_info_set_argmodes(ArgModes, ProcInfo0, ProcInfo),
    pred_info_set_proc_info(ProcId, ProcInfo, PredInfo0, PredInfo).

:- pred add_arg_regs_in_proc_arg(module_info::in, mer_type::in,
    mer_mode::in, mer_mode::out) is det.

add_arg_regs_in_proc_arg(ModuleInfo, RealVarType, ArgMode0, ArgMode) :-
    ( if
        type_to_ctor_and_args(RealVarType, _TypeCtor, TypeArgs),
        TypeArgs = [_ | _]
    then
        % Even though a type parameter might be substituted by `float', in
        % another procedure it might be left generic, e.g.
        %
        %   :- type f(T) ---> f(pred(T)).
        %   :- inst f    ---> f(pred(in) is semidet).
        %
        %   :- pred p1(f(float)::in(f), float::in) is semidet.
        %   :- pred p2(f(T)::in(f), T::in) is semidet.
        %
        % The same value may be passed to `p1' and `p2' so the higher-order
        % term contained within must use the same calling convention, namely a
        % regular register for its argument. Therefore while processing `p1'
        % we must undo the type substitution and treat `f(float)' as if it were
        % `f(T)'.
        %
        % A type parameter may also be substituted by a higher-order type, e.g.
        %
        %   :- type g(T) ---> g(T).
        %   :- inst g    ---> g(pred(in) is semidet).
        %
        %   :- pred q1(g(pred(float))::in(g), float::in) is semidet.
        %   :- pred q2(g(pred(T))::in(g), T::in) is semidet.
        %
        % When processing `q1' we must treat the `g(pred(float))' argument as
        % if it were `g(pred(T))'.

        PolymorphicContext = no,
        make_generic_type(PolymorphicContext, RealVarType, AssumedType),
        add_arg_regs_in_mode(ModuleInfo, AssumedType, ArgMode0, ArgMode)
    else
        ArgMode = ArgMode0
    ).

:- pred make_generic_type(bool::in, mer_type::in, mer_type::out) is det.

make_generic_type(PolymorphicContext, Type0, Type) :-
    ( if
        type_is_higher_order_details(Type0, Purity, PredOrFunc, ArgTypes0)
    then
        list.map(make_generic_type(PolymorphicContext), ArgTypes0, ArgTypes),
        construct_higher_order_type(Purity, PredOrFunc, ArgTypes, Type)
    else if
        type_to_ctor_and_args(Type0, TypeCtor, ArgTypes0)
    then
        (
            ArgTypes0 = [],
            ( if
                PolymorphicContext = yes,
                TypeCtor = float_type_ctor
            then
                % We don't actually need to replace `float' by a type variable.
                % Any other type will do, so long as it forces the argument to
                % be passed via a regular register.
                Type = heap_pointer_type
            else
                Type = Type0
            )
        ;
            ArgTypes0 = [_ | _],
            list.map(make_generic_type(yes), ArgTypes0, ArgTypes),
            construct_type(TypeCtor, ArgTypes, Type)
        )
    else
        Type = Type0
    ).

%---------------------------------------------------------------------------%

:- pred add_arg_regs_in_from_to_insts(module_info::in, mer_type::in,
    from_to_insts::in, from_to_insts::out) is det.

add_arg_regs_in_from_to_insts(ModuleInfo, VarType,
        ArgFromToInsts0, ArgFromToInsts) :-
    add_arg_regs_in_from_to_insts_seen(ModuleInfo, set.init, VarType,
        ArgFromToInsts0, ArgFromToInsts).

:- pred add_arg_regs_in_from_to_insts_seen(module_info::in, set(inst_name)::in,
    mer_type::in, from_to_insts::in, from_to_insts::out) is det.

add_arg_regs_in_from_to_insts_seen(ModuleInfo, Seen, VarType,
        ArgFromToInsts0, ArgFromToInsts) :-
    ArgFromToInsts0 = from_to_insts(InitialInst0, FinalInst0),
    add_arg_regs_in_inst(ModuleInfo, Seen, VarType, InitialInst0, InitialInst),
    add_arg_regs_in_inst(ModuleInfo, Seen, VarType, FinalInst0, FinalInst),
    ( if
        InitialInst = InitialInst0,
        FinalInst = FinalInst0
    then
        ArgFromToInsts = ArgFromToInsts0
    else
        ArgFromToInsts = from_to_insts(InitialInst, FinalInst)
    ).

%---------------------%

:- pred add_arg_regs_in_mode(module_info::in, mer_type::in,
    mer_mode::in, mer_mode::out) is det.

add_arg_regs_in_mode(ModuleInfo, VarType, ArgMode0, ArgMode) :-
    add_arg_regs_in_mode_seen(ModuleInfo, set.init, VarType,
        ArgMode0, ArgMode).

:- pred add_arg_regs_in_mode_seen(module_info::in, set(inst_name)::in,
    mer_type::in, mer_mode::in, mer_mode::out) is det.

add_arg_regs_in_mode_seen(ModuleInfo, Seen, VarType, ArgMode0, ArgMode) :-
    mode_get_insts(ModuleInfo, ArgMode0, InitialInst0, FinalInst0),
    add_arg_regs_in_inst(ModuleInfo, Seen, VarType, InitialInst0, InitialInst),
    add_arg_regs_in_inst(ModuleInfo, Seen, VarType, FinalInst0, FinalInst),
    ( if
        InitialInst = InitialInst0,
        FinalInst = FinalInst0
    then
        ArgMode = ArgMode0
    else
        ArgMode = from_to_mode(InitialInst, FinalInst)
    ).

%---------------------%

:- pred add_arg_regs_in_inst(module_info::in, set(inst_name)::in, mer_type::in,
    mer_inst::in, mer_inst::out) is det.

add_arg_regs_in_inst(ModuleInfo, Seen0, Type, Inst0, Inst) :-
    (
        Inst0 = ground(Uniq, higher_order(PredInstInfo0)),
        ( if type_is_higher_order_details(Type, _, _, ArgTypes) then
            add_arg_regs_in_pred_inst_info(ModuleInfo, Seen0, ArgTypes,
                PredInstInfo0, PredInstInfo)
        else
            PredInstInfo = PredInstInfo0
        ),
        Inst = ground(Uniq, higher_order(PredInstInfo))
    ;
        Inst0 = any(Uniq, higher_order(PredInstInfo0)),
        ( if type_is_higher_order_details(Type, _, _, ArgTypes) then
            add_arg_regs_in_pred_inst_info(ModuleInfo, Seen0, ArgTypes,
                PredInstInfo0, PredInstInfo)
        else
            PredInstInfo = PredInstInfo0
        ),
        Inst = any(Uniq, higher_order(PredInstInfo))
    ;
        Inst0 = bound(Uniq, InstResults, BoundFunctors0),
        list.map(add_arg_regs_in_bound_functor(ModuleInfo, Seen0, Type),
            BoundFunctors0, BoundFunctors),
        Inst = bound(Uniq, InstResults, BoundFunctors)
    ;
        Inst0 = constrained_inst_vars(InstVarSet, SpecInst0),
        add_arg_regs_in_inst(ModuleInfo, Seen0, Type, SpecInst0, SpecInst),
        Inst = constrained_inst_vars(InstVarSet, SpecInst)
    ;
        Inst0 = defined_inst(InstName),
        % XXX is this correct?
        ( if set.contains(Seen0, InstName) then
            Inst = Inst0
        else
            set.insert(InstName, Seen0, Seen1),
            inst_lookup(ModuleInfo, InstName, Inst1),
            add_arg_regs_in_inst(ModuleInfo, Seen1, Type, Inst1, Inst2),
            % Avoid expanding insts if unchanged.
            ( if Inst1 = Inst2 then
                Inst = Inst0
            else
                Inst = Inst2
            )
        )
    ;
        % XXX handle functions with default mode. If they have float
        % arguments, we may need to include include the pred_inst_info
        % even though they are default.
        ( Inst0 = ground(_, none_or_default_func)
        ; Inst0 = any(_, none_or_default_func)
        ; Inst0 = free
        ; Inst0 = not_reached
        ; Inst0 = inst_var(_)
        ),
        Inst = Inst0
    ).

:- pred add_arg_regs_in_pred_inst_info(module_info::in, set(inst_name)::in,
    list(mer_type)::in, pred_inst_info::in, pred_inst_info::out) is det.

add_arg_regs_in_pred_inst_info(ModuleInfo, Seen, ArgTypes, PredInstInfo0,
        PredInstInfo) :-
    PredInstInfo0 = pred_inst_info(PredOrFunc, Modes0, _ArgRegInfo, Detism),
    list.map_corresponding(add_arg_regs_in_mode_seen(ModuleInfo, Seen),
        ArgTypes, Modes0, Modes),
    list.map(ho_arg_reg_for_type, ArgTypes, ArgRegs),
    ArgRegInfo = arg_reg_types(ArgRegs),
    PredInstInfo = pred_inst_info(PredOrFunc, Modes, ArgRegInfo, Detism).

:- pred add_arg_regs_in_bound_functor(module_info::in, set(inst_name)::in,
    mer_type::in, bound_functor::in, bound_functor::out) is det.

add_arg_regs_in_bound_functor(ModuleInfo, Seen, Type,
        BoundFunctor0, BoundFunctor) :-
    BoundFunctor0 = bound_functor(ConsId, ArgInsts0),
    ( if ConsId = du_data_ctor(DuCtor) then
        ( if
            get_du_ctor_non_existential_arg_types(ModuleInfo, Type,
                DuCtor, ArgTypes)
        then
            (
                ArgTypes = [],
                % When a foreign type overrides a d.u. type, the inst may have
                % arguments but the foreign type does not.
                ArgInsts = ArgInsts0
            ;
                ArgTypes = [_ | _],
                list.map_corresponding(add_arg_regs_in_inst(ModuleInfo, Seen),
                    ArgTypes, ArgInsts0, ArgInsts)
            )
        else
            % XXX handle existentially typed cons_ids
            trace [compile_time(flag("debug_float_regs"))] (
                sorry($pred, "existentially typed cons_id")
            ),
            ArgInsts = ArgInsts0
        )
    else
        ArgInsts = ArgInsts0
    ),
    BoundFunctor = bound_functor(ConsId, ArgInsts).

:- pred ho_arg_reg_for_type(mer_type::in, ho_arg_reg::out) is det.

ho_arg_reg_for_type(Type, RegType) :-
    ( if Type = float_type then
        RegType = ho_arg_reg_f
    else
        RegType = ho_arg_reg_r
    ).

%---------------------------------------------------------------------------%
%
% Second phase.
%

:- pred insert_reg_wrappers_pred(pred_id::in,
    module_info::in, module_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_pred(PredId, !ModuleInfo, !Specs) :-
    module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
    ProcIds = pred_info_all_procids(PredInfo),
    list.foldl2(insert_reg_wrappers_proc(PredId), ProcIds,
        !ModuleInfo, !Specs).

:- pred insert_reg_wrappers_proc(pred_id::in, proc_id::in,
    module_info::in, module_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_proc(PredId, ProcId, !ModuleInfo, !Specs) :-
    module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
    pred_info_proc_info(PredInfo0, ProcId, ProcInfo0),
    insert_reg_wrappers_proc_2(ProcInfo0, ProcInfo, PredInfo0, PredInfo1,
        !ModuleInfo, !Specs),
    pred_info_set_proc_info(ProcId, ProcInfo, PredInfo1, PredInfo),
    module_info_set_pred_info(PredId, PredInfo, !ModuleInfo).

:- pred insert_reg_wrappers_proc_2(proc_info::in, proc_info::out,
    pred_info::in, pred_info::out, module_info::in, module_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_proc_2(!ProcInfo, !PredInfo, !ModuleInfo, !Specs) :-
    % Grab the appropriate fields from the pred_info and proc_info.
    pred_info_get_typevarset(!.PredInfo, TypeVarSet0),
    proc_info_get_headvars(!.ProcInfo, HeadVars),
    proc_info_get_var_table(!.ProcInfo, VarTable0),
    proc_info_get_argmodes(!.ProcInfo, ArgModes),
    proc_info_get_goal(!.ProcInfo, Goal0),
    proc_info_get_initial_instmap(!.ModuleInfo, !.ProcInfo, InstMap0),
    proc_info_get_rtti_varmaps(!.ProcInfo, RttiVarMaps0),
    proc_info_get_inst_varset(!.ProcInfo, InstVarSet0),
    proc_info_get_has_parallel_conj(!.ProcInfo, HasParallelConj),

    % Process the goal.
    init_lambda_info(!.ModuleInfo, !.PredInfo, TypeVarSet0, InstVarSet0,
        VarTable0, RttiVarMaps0, HasParallelConj, Info0),
    insert_reg_wrappers_proc_body(HeadVars, ArgModes, Goal0, Goal1, InstMap0,
        Info0, Info1, !Specs),
    lambda_info_get_var_table(Info1, VarTable1),
    lambda_info_get_tvarset(Info1, TypeVarSet),
    lambda_info_get_rtti_varmaps(Info1, RttiVarMaps1),
    lambda_info_get_module_info(Info1, !:ModuleInfo),
    lambda_info_get_recompute_nonlocals(Info1, MustRecomputeNonLocals),

    % Check if we need to requantify.
    (
        MustRecomputeNonLocals = must_recompute_nonlocals,
        implicitly_quantify_clause_body_general(ord_nl_no_lambda,
            HeadVars, _Warnings, Goal1, Goal2,
            VarTable1, VarTable, RttiVarMaps1, RttiVarMaps)
    ;
        MustRecomputeNonLocals = need_not_recompute_nonlocals,
        Goal2 = Goal1,
        VarTable = VarTable1,
        RttiVarMaps = RttiVarMaps1
    ),

    % We recomputed instmap deltas for atomic goals during the second phase,
    % so we only need to recompute instmap deltas for compound goals now.
    recompute_instmap_delta(no_recomp_atomics, VarTable, InstVarSet0,
        InstMap0, Goal2, Goal, !ModuleInfo),

    % Set the new values of the fields in proc_info and pred_info.
    proc_info_set_goal(Goal, !ProcInfo),
    proc_info_set_var_table(VarTable, !ProcInfo),
    proc_info_set_rtti_varmaps(RttiVarMaps, !ProcInfo),
    proc_info_set_headvars(HeadVars, !ProcInfo),
    ensure_all_headvars_are_named(!ProcInfo),
    pred_info_set_typevarset(TypeVarSet, !PredInfo).

:- pred insert_reg_wrappers_proc_body(list(prog_var)::in, list(mer_mode)::in,
    hlds_goal::in, hlds_goal::out, instmap::in,
    lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_proc_body(HeadVars, ArgModes, Goal0, Goal, InstMap0,
        !Info, !Specs) :-
    insert_reg_wrappers_goal(Goal0, Goal1, InstMap0, InstMap1, !Info, !Specs),
    % Ensure that all arguments match their final insts.
    lambda_info_get_module_info(!.Info, ModuleInfo),
    mode_list_get_final_insts(ModuleInfo, ArgModes, FinalInsts),
    assoc_list.from_corresponding_lists(HeadVars, FinalInsts, VarsExpectInsts),
    fix_branching_goal(VarsExpectInsts, Goal1, InstMap1, Goal, !Info, !Specs).

%---------------------------------------------------------------------------%

:- pred insert_reg_wrappers_goal(hlds_goal::in, hlds_goal::out,
    instmap::in, instmap::out, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_goal(Goal0, Goal, !InstMap, !Info, !Specs) :-
    ( if instmap_is_reachable(!.InstMap) then
        insert_reg_wrappers_goal_2(Goal0, Goal, !InstMap, !Info, !Specs)
    else
        Goal = Goal0
    ).

:- pred insert_reg_wrappers_goal_2(hlds_goal::in, hlds_goal::out,
    instmap::in, instmap::out, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_goal_2(Goal0, Goal, !InstMap, !Info, !Specs) :-
    Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
    (
        GoalExpr0 = unify(_LHS, _RHS, _Mode, _Unification, _Context),
        insert_reg_wrappers_unify_goal(GoalExpr0, GoalInfo0, Goal, !InstMap,
            !Info, !Specs)
    ;
        GoalExpr0 = conj(ConjType, Goals0),
        (
            ConjType = plain_conj,
            insert_reg_wrappers_conj(Goals0, Goals, !InstMap, !Info, !Specs)
        ;
            ConjType = parallel_conj,
            list.map_foldl3(insert_reg_wrappers_goal, Goals0, Goals,
                !InstMap, !Info, !Specs)
        ),
        GoalExpr = conj(ConjType, Goals),
        Goal = hlds_goal(GoalExpr, GoalInfo0),
        % Imported procedures may have a body consisting of an empty
        % conjunction, yet have an `unreachable' instmap delta.
        % Then we must make !:InstMap `unreachable' as well otherwise
        % we will run into problems at fix_branching_goal.
        update_instmap_if_unreachable(Goal, !InstMap)
    ;
        GoalExpr0 = disj(Goals0),
        NonLocals = goal_info_get_nonlocals(GoalInfo0),
        insert_reg_wrappers_disj(Goals0, Goals, NonLocals, !InstMap, !Info,
            !Specs),
        GoalExpr = disj(Goals),
        Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = switch(Var, CanFail, Cases0),
        NonLocals = goal_info_get_nonlocals(GoalInfo0),
        insert_reg_wrappers_switch(Var, Cases0, Cases, NonLocals, !InstMap,
            !Info, !Specs),
        GoalExpr = switch(Var, CanFail, Cases),
        Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = negation(SubGoal0),
        insert_reg_wrappers_goal(SubGoal0, SubGoal, !.InstMap, _, !Info,
            !Specs),
        GoalExpr = negation(SubGoal),
        Goal = hlds_goal(GoalExpr, GoalInfo0),
        update_instmap_if_unreachable(Goal, !InstMap)
    ;
        GoalExpr0 = scope(Reason, SubGoal0),
        ( if Reason = from_ground_term(_, from_ground_term_construct) then
            % The subgoal cannot construct higher order values.
            GoalExpr = GoalExpr0,
            Goal = hlds_goal(GoalExpr, GoalInfo0),
            update_instmap(Goal, !InstMap)
        else
            insert_reg_wrappers_goal(SubGoal0, SubGoal, !InstMap, !Info,
                !Specs),
            GoalExpr = scope(Reason, SubGoal),
            Goal = hlds_goal(GoalExpr, GoalInfo0)
        )
    ;
        GoalExpr0 = if_then_else(_, _, _, _),
        NonLocals = goal_info_get_nonlocals(GoalInfo0),
        insert_reg_wrappers_ite(NonLocals, GoalExpr0, GoalExpr, !InstMap,
            !Info, !Specs),
        Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = plain_call(PredId, ProcId, Args0, Builtin,
            MaybeUnifyContext, SymName),
        Context = goal_info_get_context(GoalInfo0),
        insert_reg_wrappers_plain_call(PredId, ProcId, Args0, Args, WrapGoals,
            MissingProc, !.InstMap, Context, !Info, !Specs),
        (
            MissingProc = no,
            GoalExpr1 = plain_call(PredId, ProcId, Args, Builtin,
                MaybeUnifyContext, SymName),
            finish_call_goal(WrapGoals, GoalExpr1, GoalInfo0, Goal, !InstMap,
                !Info)
        ;
            MissingProc = yes,
            Goal = Goal0
        )
    ;
        GoalExpr0 = generic_call(GenericCall, Args0, Modes0, _MaybeArgRegs0,
            Determinism),
        (
            GenericCall = higher_order(CallVar, _Purity, _PredOrFunc, _Arity,
                _Syntax),
            Context = goal_info_get_context(GoalInfo0),
            insert_reg_wrappers_higher_order_call(CallVar, Args0, Args, Modes,
                ArgsRegs, WrapGoals, !.InstMap, Context, !Info, !Specs),
            GoalExpr1 = generic_call(GenericCall, Args, Modes,
                arg_reg_types(ArgsRegs), Determinism),
            finish_call_goal(WrapGoals, GoalExpr1, GoalInfo0, Goal, !InstMap,
                !Info)
        ;
            GenericCall = class_method(_TCIVar, MethodNum, ClassId, _),
            Context = goal_info_get_context(GoalInfo0),
            insert_reg_wrappers_method_call(ClassId, MethodNum, Args0, Args,
                Modes0, Modes, WrapGoals, !.InstMap, Context, !Info, !Specs),
            % Currently we don't use float registers for method calls.
            GoalExpr1 = generic_call(GenericCall, Args, Modes,
                arg_reg_types_unset, Determinism),
            finish_call_goal(WrapGoals, GoalExpr1, GoalInfo0, Goal, !InstMap,
                !Info)
        ;
            ( GenericCall = event_call(_)
            ; GenericCall = cast(_)
            ),
            Goal = Goal0,
            update_instmap(Goal, !InstMap)
        )
    ;
        GoalExpr0 = call_foreign_proc(Attributes, PredId, ProcId, ForeignArgs0,
            ExtraArgs, MaybeTraceRuntimeCond, PragmaImpl),
        Context = goal_info_get_context(GoalInfo0),
        insert_reg_wrappers_foreign_call(PredId, ProcId, ForeignArgs0,
            ForeignArgs, WrapGoals, !.InstMap, Context, !Info, !Specs),
        GoalExpr1 = call_foreign_proc(Attributes, PredId, ProcId, ForeignArgs,
            ExtraArgs, MaybeTraceRuntimeCond, PragmaImpl),
        finish_call_goal(WrapGoals, GoalExpr1, GoalInfo0, Goal, !InstMap,
            !Info)
    ;
        GoalExpr0 = shorthand(_),
        % These should have been expanded out by now.
        unexpected($pred, "shorthand")
    ).

:- pred finish_call_goal(list(hlds_goal)::in, hlds_goal_expr::in,
    hlds_goal_info::in, hlds_goal::out, instmap::in, instmap::out,
    lambda_info::in, lambda_info::out) is det.

finish_call_goal(WrapGoals, CallGoalExpr0, CallGoalInfo0, Goal,
        !InstMap, !Info) :-
    % Recompute the instmap_delta for the call goal to reflect changes to the
    % callee's argument modes that we made in the first phase.
    CallGoal0 = hlds_goal(CallGoalExpr0, CallGoalInfo0),
    do_recompute_atomic_instmap_delta(CallGoal0, CallGoal, !.InstMap, !Info),
    update_instmap(CallGoal, !InstMap),
    CallGoal = hlds_goal(_, CallGoalInfo),
    conj_list_to_goal(WrapGoals ++ [CallGoal], CallGoalInfo, Goal).

:- pred do_recompute_atomic_instmap_delta(hlds_goal::in, hlds_goal::out,
    instmap::in, lambda_info::in, lambda_info::out) is det.

do_recompute_atomic_instmap_delta(Goal0, Goal, InstMap, !Info) :-
    lambda_info_get_var_table(!.Info, VarTable),
    lambda_info_get_inst_varset(!.Info, InstVarSet),
    lambda_info_get_module_info(!.Info, ModuleInfo0),
    recompute_instmap_delta(recomp_atomics, VarTable,
        InstVarSet, InstMap, Goal0, Goal, ModuleInfo0, ModuleInfo),
    lambda_info_set_module_info(ModuleInfo, !Info).

:- pred update_instmap_if_unreachable(hlds_goal::in, instmap::in, instmap::out)
    is det.

update_instmap_if_unreachable(Goal, InstMap0, InstMap) :-
    Goal = hlds_goal(_, GoalInfo),
    InstMapDelta = goal_info_get_instmap_delta(GoalInfo),
    ( if instmap_delta_is_unreachable(InstMapDelta) then
        init_unreachable(InstMap)
    else
        InstMap = InstMap0
    ).

%---------------------------------------------------------------------------%

:- pred insert_reg_wrappers_unify_goal(hlds_goal_expr::in(goal_expr_unify),
    hlds_goal_info::in, hlds_goal::out, instmap::in, instmap::out,
    lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_unify_goal(GoalExpr0, GoalInfo0, Goal, !InstMap, !Info,
        !Specs) :-
    GoalExpr0 = unify(LHS, RHS0, Mode, Unification0, Context),
    (
        Unification0 = construct(CellVar, ConsId, Args0, ArgUnifyModes0,
            HowToConstruct, IsUnique, SubInfo),
        (
            RHS0 = rhs_functor(_, IsExistConstruct, _)
        ;
            RHS0 = rhs_var(_),
            unexpected($pred, "construct rhs_var")
        ;
            RHS0 = rhs_lambda_goal(_, _, _, _, _, _, _),
            unexpected($pred, "construct rhs_lambda_goal")
        ),
        (
            Args0 = [],
            lambda_info_get_module_info(!.Info, ModuleInfo),
            update_construct_goal_instmap_delta(ModuleInfo, CellVar, ConsId,
                Args0, GoalInfo0, GoalInfo, !InstMap),
            Goal = hlds_goal(GoalExpr0, GoalInfo)
        ;
            Args0 = [_ | _],
            GoalContext = goal_info_get_context(GoalInfo0),
            insert_reg_wrappers_construct(CellVar, ConsId, Args0, Args,
                ArgUnifyModes0, ArgUnifyModes, MaybeWrappedGoals, !.InstMap,
                GoalContext, !Info, !Specs),
            (
                MaybeWrappedGoals = yes(WrapGoals),
                list.foldl(update_instmap, WrapGoals, !InstMap),
                lambda_info_get_module_info(!.Info, ModuleInfo),
                update_construct_goal_instmap_delta(ModuleInfo, CellVar,
                    ConsId, Args, GoalInfo0, GoalInfo1, !InstMap),
                RHS = rhs_functor(ConsId, IsExistConstruct, Args),
                Unification = construct(CellVar, ConsId, Args, ArgUnifyModes,
                    HowToConstruct, IsUnique, SubInfo),
                GoalExpr1 = unify(LHS, RHS, Mode, Unification, Context),
                Goal1 = hlds_goal(GoalExpr1, GoalInfo1),
                conj_list_to_goal(WrapGoals ++ [Goal1], GoalInfo1, Goal)
            ;
                MaybeWrappedGoals = no,
                lambda_info_get_module_info(!.Info, ModuleInfo),
                update_construct_goal_instmap_delta(ModuleInfo, CellVar,
                    ConsId, Args0, GoalInfo0, GoalInfo, !InstMap),
                Goal = hlds_goal(GoalExpr0, GoalInfo)
            )
        )
    ;
        Unification0 = deconstruct(CellVar, ConsId, Args, ArgUnifyModes0,
            CanFail, CanCGC),
        % Update the uni_modes of the deconstruction using the current inst of
        % the deconstructed var. Recompute the instmap delta from the new
        % uni_modes if changed.
        lambda_info_get_module_info(!.Info, ModuleInfo),
        list.length(Args, Arity),
        instmap_lookup_var(!.InstMap, CellVar, CellVarInst0),
        inst_expand_and_remove_constrained_inst_vars(ModuleInfo,
            CellVarInst0, CellVarInst),
        ( if
            get_arg_insts(CellVarInst, ConsId, Arity, ArgInsts),
            list.map_corresponding(unify_mode_set_rhs_final_inst(ModuleInfo),
                ArgInsts, ArgUnifyModes0, ArgUnifyModes),
            ArgUnifyModes \= ArgUnifyModes0
        then
            Unification = deconstruct(CellVar, ConsId, Args, ArgUnifyModes,
                CanFail, CanCGC),
            GoalExpr1 = unify(LHS, RHS0, Mode, Unification, Context),
            Goal1 = hlds_goal(GoalExpr1, GoalInfo0),
            do_recompute_atomic_instmap_delta(Goal1, Goal, !.InstMap, !Info)
        else
            Goal = hlds_goal(GoalExpr0, GoalInfo0)
        ),
        update_instmap(Goal, !InstMap)
    ;
        Unification0 = assign(ToVar, FromVar),
        Delta0 = goal_info_get_instmap_delta(GoalInfo0),
        instmap_lookup_var(!.InstMap, FromVar, Inst),
        instmap_delta_set_var(ToVar, Inst, Delta0, Delta),
        goal_info_set_instmap_delta(Delta, GoalInfo0, GoalInfo1),
        Goal = hlds_goal(GoalExpr0, GoalInfo1),
        update_instmap(Goal, !InstMap)
    ;
        Unification0 = simple_test(_, _),
        Goal = hlds_goal(GoalExpr0, GoalInfo0),
        update_instmap(Goal, !InstMap)
    ;
        Unification0 = complicated_unify(_, _, _),
        unexpected($pred, "complicated_unify")
    ).

:- pred insert_reg_wrappers_construct(prog_var::in, cons_id::in,
    list(prog_var)::in, list(prog_var)::out,
    list(unify_mode)::in, list(unify_mode)::out, maybe(list(hlds_goal))::out,
    instmap::in, prog_context::in, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_construct(CellVar, ConsId, OrigVars, Vars,
        ArgModes0, ArgModes, MaybeWrappedGoals, InstMap0, Context,
        !Info, !Specs) :-
    lambda_info_get_module_info(!.Info, ModuleInfo),
    lambda_info_get_var_table(!.Info, VarTable),
    lookup_var_type(VarTable, CellVar, CellType),
    ( if
        % Replace all type parameters by phony type variables.
        % See EXAMPLE 3 at the top of the file.
        type_to_ctor_and_args(CellType, TypeCtor, TypeArgs),
        TypeArgs = [_ | _],
        varset.init(TVarSet0),
        list.map_foldl(replace_type_params_by_dummy_vars, TypeArgs,
            PhonyTypeArgs, TVarSet0, _TVarSet),
        construct_type(TypeCtor, PhonyTypeArgs, PhonyCellType),
        get_cons_id_non_existential_arg_types(ModuleInfo, PhonyCellType,
            ConsId, PhonyArgTypes),
        PhonyArgTypes = [_ | _]
    then
        list.map2(unify_mode_to_lhs_rhs_from_to_insts, ArgModes0,
            LHSFromToInsts0, RHSFromToInsts0),
        list.map_corresponding(add_arg_regs_in_from_to_insts(ModuleInfo),
            PhonyArgTypes, LHSFromToInsts0, LHSFromToInsts),
        list.map_corresponding(add_arg_regs_in_from_to_insts(ModuleInfo),
            PhonyArgTypes, RHSFromToInsts0, RHSFromToInsts),
        from_to_insts_to_unify_modes(LHSFromToInsts, RHSFromToInsts, ArgModes),
        ArgInitialInsts = list.map(from_to_insts_to_init_inst, RHSFromToInsts),
        match_args(InstMap0, Context, PhonyArgTypes, ArgInitialInsts,
            OrigVars, Vars, [], WrapGoals, !Info, !Specs),
        MaybeWrappedGoals = yes(WrapGoals)
    else
        Vars = OrigVars,
        ArgModes = ArgModes0,
        MaybeWrappedGoals = no
    ).

:- pred replace_type_params_by_dummy_vars(mer_type::in, mer_type::out,
    tvarset::in, tvarset::out) is det.

replace_type_params_by_dummy_vars(Type0, Type, !TVarSet) :-
    ( if
        type_is_higher_order_details(Type0, Purity, PredOrFunc, ArgTypes0)
    then
        list.map_foldl(replace_type_params_by_dummy_vars, ArgTypes0, ArgTypes,
            !TVarSet),
        construct_higher_order_type(Purity, PredOrFunc, ArgTypes, Type)
    else
        varset.new_var(TVar, !TVarSet),
        Type = type_variable(TVar, kind_star)
    ).

:- pred update_construct_goal_instmap_delta(module_info::in, prog_var::in,
    cons_id::in, list(prog_var)::in, hlds_goal_info::in, hlds_goal_info::out,
    instmap::in, instmap::out) is det.

update_construct_goal_instmap_delta(ModuleInfo, CellVar, ConsId, Args,
        GoalInfo0, GoalInfo, !InstMap) :-
    Delta0 = goal_info_get_instmap_delta(GoalInfo0),
    ( if instmap_delta_search_var(Delta0, CellVar, CellInst0) then
        rebuild_cell_inst(ModuleInfo, !.InstMap, ConsId, Args,
            CellInst0, CellInst),
        instmap_delta_set_var(CellVar, CellInst, Delta0, Delta),
        goal_info_set_instmap_delta(Delta, GoalInfo0, GoalInfo),
        apply_instmap_delta(Delta, !InstMap)
    else
        GoalInfo = GoalInfo0,
        apply_instmap_delta(Delta0, !InstMap)
    ).

:- pred rebuild_cell_inst(module_info::in, instmap::in, cons_id::in,
    list(prog_var)::in, mer_inst::in, mer_inst::out) is det.

rebuild_cell_inst(ModuleInfo, InstMap, ConsId, Args, Inst0, Inst) :-
    (
        Inst0 = bound(Uniq, InstResults, BoundFunctors0),
        list.map(rebuild_cell_bound_functor(InstMap, ConsId, Args),
            BoundFunctors0, BoundFunctors),
        Inst = bound(Uniq, InstResults, BoundFunctors)
    ;
        (
            Inst0 = ground(Uniq, higher_order(PredInstInfo0))
        ;
            Inst0 = any(Uniq, higher_order(PredInstInfo0))
        ),
        PredInstInfo0 = pred_inst_info(PredOrFunc, Modes, _, Determinism),
        ( if ConsId = closure_cons(ShroudedPredProcId) then
            proc(PredId, _) = unshroud_pred_proc_id(ShroudedPredProcId),
            module_info_pred_info(ModuleInfo, PredId, PredInfo),
            pred_info_get_arg_types(PredInfo, ArgTypes),
            list.length(Args, NumArgs),
            list.det_drop(NumArgs, ArgTypes, MissingArgTypes),
            list.map(ho_arg_reg_for_type, MissingArgTypes, ArgRegs),
            PredInstInfo = pred_inst_info(PredOrFunc, Modes,
                arg_reg_types(ArgRegs), Determinism),
            (
                Inst0 = ground(_, _),
                Inst = ground(Uniq, higher_order(PredInstInfo))
            ;
                Inst0 = any(_, _),
                Inst = any(Uniq, higher_order(PredInstInfo))
            )
        else
            Inst = Inst0
        )
    ;
        Inst0 = constrained_inst_vars(InstVarSet, SpecInst0),
        rebuild_cell_inst(ModuleInfo, InstMap, ConsId, Args,
            SpecInst0, SpecInst),
        Inst = constrained_inst_vars(InstVarSet, SpecInst)
    ;
        % XXX do we need to handle any of these other cases?
        % XXX handle functions with default mode: look for pred_inst_info
        % for the called proc if ConsId is a closure.
        ( Inst0 = free
        ; Inst0 = any(_, none_or_default_func)
        ; Inst0 = ground(_, none_or_default_func)
        ; Inst0 = not_reached
        ; Inst0 = defined_inst(_)
        ),
        Inst = Inst0
    ;
        Inst0 = inst_var(_),
        unexpected($pred, "inst_var")
    ).

:- pred rebuild_cell_bound_functor(instmap::in, cons_id::in,
    list(prog_var)::in, bound_functor::in, bound_functor::out) is det.

rebuild_cell_bound_functor(InstMap, ConsId, Args, Inst0, Inst) :-
    Inst0 = bound_functor(BoundConsId, ArgInsts0),
    ( if equivalent_cons_ids(ConsId, BoundConsId) then
        list.map_corresponding(rebuild_cell_bound_functor_arg(InstMap),
            Args, ArgInsts0, ArgInsts),
        Inst = bound_functor(BoundConsId, ArgInsts)
    else
        Inst = Inst0
    ).

:- pred rebuild_cell_bound_functor_arg(instmap::in, prog_var::in,
    mer_inst::in, mer_inst::out) is det.

rebuild_cell_bound_functor_arg(InstMap, Var, ArgInst0, ArgInst) :-
    instmap_lookup_var(InstMap, Var, VarInst),
    % To cope with LCO.
    ( if VarInst = free_inst then
        ArgInst = ArgInst0
    else
        ArgInst = VarInst
    ).

:- pred unify_mode_set_rhs_final_inst(module_info::in, mer_inst::in,
    unify_mode::in, unify_mode::out) is det.

unify_mode_set_rhs_final_inst(ModuleInfo, ArgInst, UnifyMode0, UnifyMode) :-
    UnifyMode0 = unify_modes_li_lf_ri_rf(LI, LF, RI, RF),
    % Only when deconstructing to produce the right variable.
    ( if
        inst_is_free(ModuleInfo, RI),
        inst_is_bound(ModuleInfo, RF)
    then
        % Due to combined higher-order types and insts, RF may contain
        % higher-order inst information that is not in ArgInst.
        % In that case, do not lose the higher-order inst information.
        % XXX We may need to generalise this once we have some other test
        % cases.
        ( if
            ArgInst = ground(Uniq, none_or_default_func),
            RF = ground(Uniq, higher_order(_))
        then
            UnifyMode = UnifyMode0
        else
            UnifyMode = unify_modes_li_lf_ri_rf(LI, LF, RI, ArgInst)
        )
    else
        UnifyMode = UnifyMode0
    ).

%---------------------------------------------------------------------------%

:- pred insert_reg_wrappers_conj(list(hlds_goal)::in, list(hlds_goal)::out,
    instmap::in, instmap::out, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_conj([], [], !InstMap, !Info, !Specs).
insert_reg_wrappers_conj([Goal0 | Goals0], Goals, !InstMap, !Info, !Specs) :-
    % Flatten the conjunction as we go.
    insert_reg_wrappers_goal(Goal0, Goal1, !InstMap, !Info, !Specs),
    goal_to_conj_list(Goal1, Goal1List),
    insert_reg_wrappers_conj(Goals0, Goals1, !InstMap, !Info, !Specs),
    list.append(Goal1List, Goals1, Goals).

%---------------------------------------------------------------------------%

:- pred insert_reg_wrappers_disj(list(hlds_goal)::in, list(hlds_goal)::out,
    set_of_progvar::in, instmap::in, instmap::out,
    lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_disj(Goals0, Goals, NonLocals, InstMap0, InstMap, !Info,
        !Specs) :-
    list.map2_foldl2(insert_reg_wrappers_disjunct(InstMap0),
        Goals0, Goals1, InstMaps1, !Info, !Specs),
    common_instmap_delta(InstMap0, NonLocals, InstMaps1, CommonDelta, !Info),
    ( if instmap_delta_is_reachable(CommonDelta) then
        instmap_delta_to_assoc_list(CommonDelta, VarsExpectInsts),
        list.map_corresponding_foldl2(fix_branching_goal(VarsExpectInsts),
            Goals1, InstMaps1, Goals, !Info, !Specs)
    else
        Goals = Goals1
    ),
    apply_instmap_delta(CommonDelta, InstMap0, InstMap).

:- pred insert_reg_wrappers_disjunct(instmap::in,
    hlds_goal::in, hlds_goal::out, instmap::out,
    lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_disjunct(InstMap0, Goal0, Goal, InstMap, !Info, !Specs) :-
    insert_reg_wrappers_goal(Goal0, Goal, InstMap0, InstMap, !Info, !Specs).

%---------------------------------------------------------------------------%

:- pred insert_reg_wrappers_switch(prog_var::in,
    list(case)::in, list(case)::out, set_of_progvar::in,
    instmap::in, instmap::out, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_switch(Var, Cases0, Cases, NonLocals, InstMap0, InstMap,
        !Info, !Specs) :-
    lambda_info_get_var_table(!.Info, VarTable),
    lookup_var_type(VarTable, Var, Type),
    list.map2_foldl2(insert_reg_wrappers_case(Var, Type, InstMap0),
        Cases0, Cases1, InstMaps1, !Info, !Specs),
    common_instmap_delta(InstMap0, NonLocals, InstMaps1, CommonDelta, !Info),
    ( if instmap_delta_is_reachable(CommonDelta) then
        instmap_delta_to_assoc_list(CommonDelta, VarsExpectInsts),
        list.map_corresponding_foldl2(fix_case_goal(VarsExpectInsts),
            Cases1, InstMaps1, Cases, !Info, !Specs)
    else
        Cases = Cases1
    ),
    apply_instmap_delta(CommonDelta, InstMap0, InstMap).

:- pred insert_reg_wrappers_case(prog_var::in, mer_type::in, instmap::in,
    case::in, case::out, instmap::out, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_case(Var, Type, InstMap0, Case0, Case, InstMap,
        !Info, !Specs) :-
    Case0 = case(MainConsId, OtherConsIds, Goal0),
    lambda_info_get_module_info(!.Info, ModuleInfo0),
    bind_var_to_functors(Var, Type, MainConsId, OtherConsIds,
        InstMap0, InstMap1, ModuleInfo0, ModuleInfo1),
    lambda_info_set_module_info(ModuleInfo1, !Info),
    insert_reg_wrappers_goal(Goal0, Goal, InstMap1, InstMap, !Info, !Specs),
    Case = case(MainConsId, OtherConsIds, Goal).

%---------------------------------------------------------------------------%

:- pred insert_reg_wrappers_ite(set_of_progvar::in,
    hlds_goal_expr::in(goal_expr_ite), hlds_goal_expr::out(goal_expr_ite),
    instmap::in, instmap::out, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_ite(NonLocals, GoalExpr0, GoalExpr, InstMap0, InstMap,
        !Info, !Specs) :-
    GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
    insert_reg_wrappers_goal(Cond0, Cond, InstMap0, InstMapCond,
        !Info, !Specs),
    insert_reg_wrappers_goal(Then0, Then1, InstMapCond, InstMapThen,
        !Info, !Specs),
    insert_reg_wrappers_goal(Else0, Else1, InstMap0, InstMapElse,
        !Info, !Specs),

    common_instmap_delta(InstMap0, NonLocals, [InstMapThen, InstMapElse],
        CommonDelta, !Info),
    ( if instmap_delta_is_reachable(CommonDelta) then
        instmap_delta_to_assoc_list(CommonDelta, VarsExpectInsts),
        fix_branching_goal(VarsExpectInsts, Then1, InstMapThen, Then,
            !Info, !Specs),
        fix_branching_goal(VarsExpectInsts, Else1, InstMapElse, Else,
            !Info, !Specs)
    else
        Then = Then1,
        Else = Else1
    ),
    apply_instmap_delta(CommonDelta, InstMap0, InstMap),
    GoalExpr = if_then_else(Vars, Cond, Then, Else).

%---------------------------------------------------------------------------%

:- pred insert_reg_wrappers_plain_call(pred_id::in, proc_id::in,
    list(prog_var)::in, list(prog_var)::out, list(hlds_goal)::out, bool::out,
    instmap::in, prog_context::in, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_plain_call(PredId, ProcId, Vars0, Vars, WrapGoals,
        MissingProc, InstMap0, Context, !Info, !Specs) :-
    lambda_info_get_module_info(!.Info, ModuleInfo),
    module_info_pred_info(ModuleInfo, PredId, PredInfo),
    pred_info_get_proc_table(PredInfo, ProcTable),
    ( if map.search(ProcTable, ProcId, ProcInfo) then
        pred_info_get_arg_types(PredInfo, ArgTypes),
        proc_info_get_argmodes(ProcInfo, ArgModes),
        match_args_for_call(InstMap0, Context, ArgTypes, ArgModes, Vars0, Vars,
            WrapGoals, !Info, !Specs),
        MissingProc = no
    else
        % XXX After the dep_par_conj pass, some dead procedures are removed
        % but calls to them (from also dead procedures?) remain.
        trace [compile_time(flag("debug_float_regs")), io(!IO)] (
            get_debug_output_stream(ModuleInfo, DebugStream, !IO),
            PredProcId = proc(PredId, ProcId),
            maybe_write_proc_progress_message(DebugStream, ModuleInfo,
                "Ignoring call to missing procedure", PredProcId, !IO)
        ),
        Vars = Vars0,
        WrapGoals = [],
        MissingProc = yes
    ).

:- pred insert_reg_wrappers_higher_order_call(prog_var::in,
    list(prog_var)::in, list(prog_var)::out, list(mer_mode)::out,
    list(ho_arg_reg)::out, list(hlds_goal)::out, instmap::in, prog_context::in,
    lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_higher_order_call(CallVar, Vars0, Vars, ArgModes, ArgRegs,
        WrapGoals, InstMap0, Context, !Info, !Specs) :-
    lambda_info_get_module_info(!.Info, ModuleInfo),
    lambda_info_get_var_table(!.Info, VarTable),
    lookup_var_type(VarTable, CallVar, CallVarType),
    instmap_lookup_var(InstMap0, CallVar, CallVarInst),
    type_is_higher_order_details_det(CallVarType, _, PredOrFunc, ArgTypes),
    list.length(ArgTypes, Arity),
    lookup_pred_inst_info(ModuleInfo, CallVarInst, PredOrFunc, Arity,
        CallVarPredInstInfo),
    CallVarPredInstInfo = pred_inst_info(_, ArgModes, _, _),
    get_ho_arg_regs(CallVarPredInstInfo, ArgTypes, ArgRegs),
    match_args_for_call(InstMap0, Context, ArgTypes, ArgModes, Vars0, Vars,
        WrapGoals, !Info, !Specs).

:- pred insert_reg_wrappers_method_call(class_id::in, method_proc_num::in,
    list(prog_var)::in, list(prog_var)::out,
    list(mer_mode)::in, list(mer_mode)::out, list(hlds_goal)::out,
    instmap::in, prog_context::in, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_method_call(ClassId, MethodProcNum, Vars0, Vars,
        Modes0, Modes, WrapGoals, InstMap0, Context, !Info, !Specs) :-
    lambda_info_get_module_info(!.Info, ModuleInfo),
    module_info_get_class_table(ModuleInfo, Classes),
    map.lookup(Classes, ClassId, ClassDefn),
    MethodInfos = ClassDefn ^ classdefn_method_infos,
    MethodInfo = lookup_method_proc(MethodInfos, MethodProcNum),
    MethodInfo ^ method_cur_proc = PredProcId,
    module_info_pred_proc_info(ModuleInfo, PredProcId, PredInfo, ProcInfo),
    pred_info_get_arg_types(PredInfo, ArgTypes),
    proc_info_get_argmodes(ProcInfo, ProcArgModes),

    % We need to update the modes in the generic_call using the modes from the
    % proc_info because we may have changed them during the first phase.
    % Vars0 is missing the typeclass_info variable, whereas the ArgTypes and
    % ProcArgModes *do* include the respective data for that variable.
    % The problem is, we don't know which argument position the typeclass_info
    % variable appears at, and it's not easy to find out.
    %
    % match_args_for_call has no effect on typeclass_info nor type_info
    % variables, and we know those variables must appear at the head of the
    % argument list. Therefore we can just call match_args_for_call on the
    % non typeclass_info/type_info variables at the tail of Vars0, using the
    % corresponding tails of ArgTypes and ProcArgModes.

    take_non_rtti_types_from_tail(ArgTypes, EndTypes),
    list.length(EndTypes, N),
    split_list_from_end(N, Vars0, StartVars, EndVars0),
    split_list_from_end(N, Modes0, StartModes, _),
    split_list_from_end(N, ProcArgModes, _, EndProcArgModes),

    match_args_for_call(InstMap0, Context, EndTypes, EndProcArgModes,
        EndVars0, EndVars, WrapGoals, !Info, !Specs),

    Vars = StartVars ++ EndVars,
    Modes = StartModes ++ EndProcArgModes.

:- pred take_non_rtti_types_from_tail(list(mer_type)::in, list(mer_type)::out)
    is det.

take_non_rtti_types_from_tail([], []).
take_non_rtti_types_from_tail([Type | Types0], Types) :-
    take_non_rtti_types_from_tail(Types0, TypesTail),
    ( if
        ( type_is_typeclass_info_type(Type)
        ; type_is_type_info_or_ctor_type(Type)
        )
    then
        Types = TypesTail
    else
        Types = [Type | TypesTail]
    ).

:- pred insert_reg_wrappers_foreign_call(pred_id::in, proc_id::in,
    list(foreign_arg)::in, list(foreign_arg)::out, list(hlds_goal)::out,
    instmap::in, prog_context::in, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

insert_reg_wrappers_foreign_call(PredId, ProcId, ForeignArgs0, ForeignArgs,
        WrapGoals, InstMap0, Context, !Info, !Specs) :-
    Vars0 = list.map(foreign_arg_var, ForeignArgs0),
    insert_reg_wrappers_plain_call(PredId, ProcId, Vars0, Vars, WrapGoals,
        _MissingProc, InstMap0, Context, !Info, !Specs),
    list.map_corresponding(set_foreign_arg_var, Vars,
        ForeignArgs0, ForeignArgs).

:- pred set_foreign_arg_var(prog_var::in, foreign_arg::in, foreign_arg::out)
    is det.

set_foreign_arg_var(Var, !ForeignArg) :-
    !ForeignArg ^ arg_var := Var.

%---------------------------------------------------------------------------%

:- pred match_args_for_call(instmap::in, prog_context::in, list(mer_type)::in,
    list(mer_mode)::in, list(prog_var)::in, list(prog_var)::out,
    list(hlds_goal)::out, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

match_args_for_call(InstMap0, Context, ArgTypes, ArgModes, OrigVars, Vars,
        WrapGoals, !Info, !Specs) :-
    lambda_info_get_module_info(!.Info, ModuleInfo),
    mode_list_get_initial_insts(ModuleInfo, ArgModes, InitialInsts),
    match_args(InstMap0, Context, ArgTypes, InitialInsts, OrigVars, Vars,
        [], WrapGoals, !Info, !Specs).

:- pred match_args(instmap::in, prog_context::in, list(mer_type)::in,
    list(mer_inst)::in, list(prog_var)::in, list(prog_var)::out,
    list(hlds_goal)::in, list(hlds_goal)::out,
    lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

match_args(InstMap0, Context, ArgTypes, Insts, OrigVars, Vars, !WrapGoals,
        !Info, !Specs) :-
    ( if
        ArgTypes = [],
        Insts = [],
        OrigVars = []
    then
        Vars = []
    else if
        ArgTypes = [AT | ATs],
        Insts = [I | Is],
        OrigVars = [OV | OVs]
    then
        match_arg(InstMap0, Context, AT, I, OV, V, !WrapGoals, !Info, !Specs),
        match_args(InstMap0, Context, ATs, Is, OVs, Vs, !WrapGoals, !Info,
            !Specs),
        Vars = [V | Vs]
    else
        unexpected($pred, "length mismatch")
    ).

:- pred match_arg(instmap::in, prog_context::in, mer_type::in, mer_inst::in,
    prog_var::in, prog_var::out, list(hlds_goal)::in, list(hlds_goal)::out,
    lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

match_arg(InstMapBefore, Context, ArgType, ExpectInst, OrigVar, Var,
        !WrapGoals, !Info, !Specs) :-
    lambda_info_get_module_info(!.Info, ModuleInfo),
    lambda_info_get_var_table(!.Info, VarTable),
    ( if
        inst_is_bound(ModuleInfo, ExpectInst),
        type_is_higher_order_details(ArgType, _, PredOrFunc, ArgPredArgTypes),
        ArgPredArgTypes = [_ | _]
    then
        lookup_var_type(VarTable, OrigVar, OrigVarType),
        type_is_higher_order_details_det(OrigVarType, _, _, OrigPredArgTypes),
        list.length(OrigPredArgTypes, Arity),
        ( if
            search_pred_inst_info(ModuleInfo, ExpectInst, PredOrFunc, Arity,
                ExpectPredInstInfo)
        then
            instmap_lookup_var(InstMapBefore, OrigVar, OrigVarInst),
            lookup_pred_inst_info(ModuleInfo, OrigVarInst, PredOrFunc, Arity,
                OrigPredInstInfo),
            get_ho_arg_regs(ExpectPredInstInfo, ArgPredArgTypes,
                ExpectArgRegs),
            get_ho_arg_regs(OrigPredInstInfo, OrigPredArgTypes,
                OrigArgRegs),
            ( if OrigArgRegs = ExpectArgRegs then
                Var = OrigVar
            else
                create_reg_wrapper(OrigVar, OrigPredInstInfo, ExpectArgRegs,
                    OrigArgRegs, Context, Var, UnifyGoal, !Info),
                list.cons(UnifyGoal, !WrapGoals)
            )
        else
            lambda_info_get_pred_info(!.Info, PredInfo),
            maybe_report_missing_pred_inst(PredInfo, VarTable, OrigVar,
                Context, OrigPredArgTypes, ArgPredArgTypes, !Specs),
            Var = OrigVar
        )
    else
        Var = OrigVar
    ).

:- pred lookup_pred_inst_info(module_info::in, mer_inst::in, pred_or_func::in,
    int::in, pred_inst_info::out) is det.

lookup_pred_inst_info(ModuleInfo, Inst, PredOrFunc, Arity, PredInstInfo) :-
    ( if
        search_pred_inst_info(ModuleInfo, Inst, PredOrFunc, Arity,
            PredInstInfo0)
    then
        PredInstInfo = PredInstInfo0
    else
        unexpected($pred, "no higher order inst")
    ).

:- pred search_pred_inst_info(module_info::in, mer_inst::in, pred_or_func::in,
    int::in, pred_inst_info::out) is semidet.

search_pred_inst_info(ModuleInfo, Inst, PredOrFunc, Arity, PredInstInfo) :-
    ( if search_pred_inst_info_2(ModuleInfo, Inst, PredInstInfo0) then
        PredInstInfo = PredInstInfo0
    else
        PredOrFunc = pf_function,
        PredInstInfo = pred_inst_info_default_func_mode(Arity)
    ).

:- pred search_pred_inst_info_2(module_info::in, mer_inst::in,
    pred_inst_info::out) is semidet.

search_pred_inst_info_2(ModuleInfo, Inst, PredInstInfo) :-
    require_complete_switch [Inst]
    (
        Inst = any(_, higher_order(PredInstInfo))
    ;
        Inst = ground(_, higher_order(PredInstInfo))
    ;
        Inst = defined_inst(InstName),
        inst_lookup(ModuleInfo, InstName, InstB),
        search_pred_inst_info_2(ModuleInfo, InstB, PredInstInfo)
    ;
        Inst = constrained_inst_vars(_Vars, _SubInst),
        % This might be necessary if modecheck_higher_order_call is changed
        % to accept an inst with constrained_inst_vars at the top level:
        %   search_pred_inst_info_2(ModuleInfo, SubInst, PredInstInfo)
        fail
    ;
        ( Inst = free
        ; Inst = bound(_, _, _)
        ; Inst = not_reached
        ; Inst = inst_var(_)
        ),
        fail
    ).

:- pred get_ho_arg_regs(pred_inst_info::in, list(mer_type)::in,
    list(ho_arg_reg)::out) is det.

get_ho_arg_regs(PredInstInfo, ArgTypes, ArgRegs) :-
    PredInstInfo = pred_inst_info(_, _, MaybeArgRegs, _),
    (
        MaybeArgRegs = arg_reg_types(ArgRegs)
    ;
        MaybeArgRegs = arg_reg_types_unset,
        list.map(ho_arg_reg_for_type, ArgTypes, ArgRegs)
    ).

    % Emit an error if a higher-order inst cannot be found for the variable,
    % but only if any of its arguments are floats. We want to avoid reporting
    % errors for code which simply copies a higher-order term when updating an
    % unrelated structure field.
    %
    % XXX improve the conditions for which an error is reported
    %
:- pred maybe_report_missing_pred_inst(pred_info::in, var_table::in,
    prog_var::in, prog_context::in, list(mer_type)::in, list(mer_type)::in,
    list(error_spec)::in, list(error_spec)::out) is det.

maybe_report_missing_pred_inst(PredInfo, VarTable, Var, Context,
        ArgTypesA, ArgTypesB, !Specs) :-
    ( if
        ( list.member(float_type, ArgTypesA)
        ; list.member(float_type, ArgTypesB)
        ),
        % Ignore special predicates.
        pred_info_get_origin(PredInfo, Origin),
        Origin \= origin_compiler(made_for_uci(_, _))
    then
        Spec = report_missing_higher_order_inst(PredInfo, VarTable, Var,
            Context),
        list.cons(Spec, !Specs)
    else
        true
    ).

:- func report_missing_higher_order_inst(pred_info, var_table, prog_var,
    prog_context) = error_spec.

report_missing_higher_order_inst(PredInfo, VarTable, Var, Context) = Spec :-
    PredPieces = describe_one_pred_info_name(no, should_module_qualify, [],
        PredInfo),
    lookup_var_entry(VarTable, Var, Entry),
    VarName = var_entry_name(Var, Entry),
    InPieces = [words("In") | PredPieces] ++ [suffix(":"), nl],
    ErrorPieces = [words("error:")] ++
        color_as_incorrect([words("missing higher-order inst")]) ++
        [words("for variable")] ++
        color_as_subject([quote(VarName), suffix(".")]) ++
        [nl],
    VerbosePieces =
        [words("Please provide the higher-order inst to ensure correctness"),
        words("of the generated code in this grade.")],
    Msg = simple_msg(Context, [always(InPieces), always(ErrorPieces),
        verbose_only(verbose_always, VerbosePieces)]),
    Spec = error_spec($pred, severity_error, phase_code_gen, [Msg]).

%---------------------------------------------------------------------------%

    % At the end of a branching goal, non-local variables bound to higher-order
    % terms must agree on the calling convention across all branches.
    % When there is disagreement for a variable, we simply choose one calling
    % convention, then create wrappers in each branch to make that conform to
    % the chosen calling convention.
    %
    % Currently the choice of calling convention is arbitrary and may lead to
    % more wrappers, or more boxing of floats, than if we had chosen another
    % calling convention. This kind of code should be rare.
    %
:- pred common_instmap_delta(instmap::in, set_of_progvar::in,
    list(instmap)::in, instmap_delta::out, lambda_info::in, lambda_info::out)
    is det.

common_instmap_delta(InstMap0, NonLocals, InstMaps, CommonDelta, !Info) :-
    list.filter_map(
        ( pred(InstMap::in, Delta::out) is semidet :-
            instmap_is_reachable(InstMap),
            compute_instmap_delta(InstMap0, InstMap, NonLocals, Delta)
        ), InstMaps, InstMapDeltas),
    (
        InstMapDeltas = [],
        instmap_delta_init_unreachable(CommonDelta)
    ;
        InstMapDeltas = [_ | _],
        lambda_info_get_var_table(!.Info, VarTable),
        lambda_info_get_module_info(!.Info, ModuleInfo0),
        merge_instmap_deltas(VarTable, NonLocals, InstMap0,
            InstMapDeltas, CommonDelta, ModuleInfo0, ModuleInfo),
        lambda_info_set_module_info(ModuleInfo, !Info)
    ).

:- pred fix_branching_goal(assoc_list(prog_var, mer_inst)::in,
    hlds_goal::in, instmap::in, hlds_goal::out,
    lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

fix_branching_goal(VarsExpectInsts, Goal0, GoalInstMap0, Goal, !Info,
        !Specs) :-
    ( if instmap_is_reachable(GoalInstMap0) then
        % GoalInstMap0 is the instmap at the end of Goal0.
        Goal0 = hlds_goal(_, GoalInfo0),
        Context = goal_info_get_context(GoalInfo0),
        match_vars_insts(VarsExpectInsts, GoalInstMap0, Context,
            map.init, Renaming, [], WrapGoals0, !Info, !Specs),
        (
            WrapGoals0 = [],
            Goal = Goal0
        ;
            WrapGoals0 = [_ | _],
            conjoin_goal_and_goal_list(Goal0, WrapGoals0, Goal1),
            rename_some_vars_in_goal(Renaming, Goal1, Goal)
        )
    else
        Goal = Goal0
    ).

:- pred fix_case_goal(assoc_list(prog_var, mer_inst)::in,
    case::in, instmap::in, case::out, lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

fix_case_goal(VarsExpectInsts, Case0, GoalInstMap0, Case, !Info, !Specs) :-
    Case0 = case(MainConsId, OtherConsIds, Goal0),
    fix_branching_goal(VarsExpectInsts, Goal0, GoalInstMap0, Goal, !Info,
        !Specs),
    Case = case(MainConsId, OtherConsIds, Goal).

:- pred match_vars_insts(assoc_list(prog_var, mer_inst)::in, instmap::in,
    prog_context::in, prog_var_renaming::in, prog_var_renaming::out,
    list(hlds_goal)::in, list(hlds_goal)::out,
    lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

match_vars_insts(VarsExpectInsts, InstMap0, Context, !Renaming, !WrapGoals,
        !Info, !Specs) :-
    (
        VarsExpectInsts = []
    ;
        VarsExpectInsts = [Var - Inst | Tail],
        match_var_inst(Var, Inst, InstMap0, Context,
            !Renaming, !WrapGoals, !Info, !Specs),
        match_vars_insts(Tail, InstMap0, Context,
            !Renaming, !WrapGoals, !Info, !Specs)
    ).

:- pred match_var_inst(prog_var::in, mer_inst::in, instmap::in,
    prog_context::in, prog_var_renaming::in, prog_var_renaming::out,
    list(hlds_goal)::in, list(hlds_goal)::out,
    lambda_info::in, lambda_info::out,
    list(error_spec)::in, list(error_spec)::out) is det.

match_var_inst(Var, ExpectInst, InstMap0, Context, !Renaming, !WrapGoals,
        !Info, !Specs) :-
    lambda_info_get_module_info(!.Info, ModuleInfo),
    lambda_info_get_var_table(!.Info, VarTable),
    ( if inst_is_free(ModuleInfo, ExpectInst) then
        true
    else
        lookup_var_type(VarTable, Var, VarType),
        match_arg(InstMap0, Context, VarType, ExpectInst, Var, SubstVar,
            [], WrapGoals, !Info, !Specs),
        ( if Var = SubstVar then
            true
        else
            map.det_insert(Var, SubstVar, !Renaming),
            map.det_insert(SubstVar, Var, !Renaming),
            list.append(WrapGoals, !WrapGoals)
        )
    ).

%---------------------------------------------------------------------------%

:- pred create_reg_wrapper(prog_var::in, pred_inst_info::in,
    list(ho_arg_reg)::in, list(ho_arg_reg)::in, prog_context::in,
    prog_var::out, hlds_goal::out, lambda_info::in, lambda_info::out) is det.

create_reg_wrapper(OrigVar, OrigVarPredInstInfo, OuterArgRegs, InnerArgRegs,
        Context, LHSVar, UnifyGoal, !Info) :-
    lambda_info_get_var_table(!.Info, VarTable0),
    lambda_info_get_module_info(!.Info, ModuleInfo0),

    lookup_var_entry(VarTable0, OrigVar, OrigVarEntry),
    OrigVarEntry = vte(_, OrigVarType, OrigVarIsDummy),
    type_is_higher_order_details_det(OrigVarType, Purity, PredOrFunc,
        PredArgTypes),

    % Create variables for the head variables of the wrapper procedure.
    % These are also the variables in the call in the procedure body.
    create_fresh_vars(ModuleInfo0, PredArgTypes, CallVars,
        VarTable0, VarTable1),
    PredFormArity = arg_list_arity(CallVars),

    % Create the in the body of the wrapper procedure.
    % XXX What does that mean?
    CallVar = OrigVar,
    OrigVarPredInstInfo = pred_inst_info(_, ArgModes, _, Determinism),
    % Since we use the value of Syntax only when generating error messages,
    % but the code we construct here should be correct, the value we assign
    % here does not matter.
    Syntax = hos_var,
    GenericCall = higher_order(CallVar, Purity, PredOrFunc, PredFormArity,
        Syntax),
    CallGoalExpr = generic_call(GenericCall, CallVars, ArgModes,
        arg_reg_types(InnerArgRegs), Determinism),
    CallNonLocals = set_of_var.list_to_set([CallVar | CallVars]),
    instmap_delta_from_mode_list(ModuleInfo0, CallVars, ArgModes,
        CallInstMapDelta),
    goal_info_init(CallNonLocals, CallInstMapDelta, Determinism, Purity,
        Context, CallGoalInfo),
    CallGoal = hlds_goal(CallGoalExpr, CallGoalInfo),

    % Create the replacement variable LHSVar.
    ReplacementEntry = vte("", OrigVarType, OrigVarIsDummy),
    add_var_entry(ReplacementEntry, LHSVar, VarTable1, VarTable),
    lambda_info_set_var_table(VarTable, !Info),

    % RegR_HeadVars are the wrapper procedure's headvars which must use regular
    % registers.
    list.foldl_corresponding(make_reg_r_headvars(VarTable),
        CallVars, OuterArgRegs, set_of_var.init, RegR_HeadVars),

    % Create the wrapper procedure.
    DummyPPId = proc(invalid_pred_id, invalid_proc_id),
    DummyShroudedPPId = shroud_pred_proc_id(DummyPPId),
    ConsId = closure_cons(DummyShroudedPPId),
    LambdaNonLocals = [CallVar],
    InInst = ground(shared, higher_order(OrigVarPredInstInfo)),
    ArgUnifyModes0 = [unify_modes_li_lf_ri_rf(InInst, InInst, InInst, InInst)],
    Unification0 = construct(LHSVar, ConsId, LambdaNonLocals, ArgUnifyModes0,
        construct_dynamically, cell_is_shared, no_construct_sub_info),
    UnifyMode = unify_modes_li_lf_ri_rf(free, ground_inst,
        ground_inst, ground_inst),
    MainContext = umc_implicit("reg_wrapper"),
    UnifyContext = unify_context(MainContext, []),
    assoc_list.from_corresponding_lists(CallVars, ArgModes, CallVarsArgModes),
    RHS = rhs_lambda_goal(Purity, ho_ground, PredOrFunc,
        LambdaNonLocals, CallVarsArgModes, Determinism, CallGoal),
    lambda.expand_lambda(reg_wrapper_proc(RegR_HeadVars), LHSVar, RHS,
        UnifyMode, Unification0, UnifyContext, UnifyGoalExpr, !Info),

    % Create the unification goal for Var.
    UnifyNonLocals = set_of_var.make_singleton(LHSVar),
    UnifyPredInstInfo = pred_inst_info(PredOrFunc, ArgModes,
        arg_reg_types(OuterArgRegs), Determinism),
    UnifyPredVarInst = ground(shared, higher_order(UnifyPredInstInfo)),
    UnifyInstMapDelta = instmap_delta_from_assoc_list([
        LHSVar - UnifyPredVarInst]),
    goal_info_init(UnifyNonLocals, UnifyInstMapDelta, detism_det,
        purity_pure, UnifyGoalInfo),
    UnifyGoal = hlds_goal(UnifyGoalExpr, UnifyGoalInfo),

    lambda_info_set_recompute_nonlocals(must_recompute_nonlocals, !Info).

:- pred create_fresh_vars(module_info::in, list(mer_type)::in,
    list(prog_var)::out, var_table::in, var_table::out) is det.

create_fresh_vars(_, [], [], !VarTable).
create_fresh_vars(ModuleInfo, [Type | Types], [Var | Vars], !VarTable) :-
    IsDummy = is_type_a_dummy(ModuleInfo, Type),
    Entry = vte("", Type, IsDummy),
    add_var_entry(Entry, Var, !VarTable),
    create_fresh_vars(ModuleInfo, Types, Vars, !VarTable).

:- pred make_reg_r_headvars(var_table::in, prog_var::in, ho_arg_reg::in,
    set_of_progvar::in, set_of_progvar::out) is det.

make_reg_r_headvars(VarTable, Var, RegType, !RegR_HeadVars) :-
    (
        RegType = ho_arg_reg_r,
        lookup_var_entry(VarTable, Var, Entry),
        ( if Entry ^ vte_type = float_type then
            set_of_var.insert(Var, !RegR_HeadVars)
        else
            true
        )
    ;
        RegType = ho_arg_reg_f
    ).

%---------------------------------------------------------------------------%

:- pred split_list_from_end(int::in, list(T)::in, list(T)::out, list(T)::out)
    is det.

split_list_from_end(EndLen, List, Start, End) :-
    list.length(List, Len),
    StartLen = Len - EndLen,
    ( if StartLen = 0 then
        Start = [],
        End = List
    else if StartLen > 0 then
        list.det_split_list(StartLen, List, Start, End)
    else
        unexpected($pred, "list too short")
    ).

%---------------------------------------------------------------------------%
:- end_module transform_hlds.float_regs.
%---------------------------------------------------------------------------%
