%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1996-2011 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% File: lco.m.
% Author: zs.
% Modifications by wangp.
%
% Transform predicates with calls that are tail recursive modulo construction
% where (1) all recursive calls have the same args participating in the "modulo
% construction" part and (2) all the other output args are returned in the same
% registers in all recursive calls as expected by the head.
%
%   p(In1, ... InN, Out1, ... OutM) :-
%       Out1 = ground
%   p(In1, ... InN, Out1, ... OutM) :-
%       ...
%       p(In1, ... InN, Mid1, Out2... OutM)
%       Out1 = f1(...Mid1...)
%
% The definition of append fits this pattern:
%
% app(list(T)::in, list(T)::in, list(T)::out)
% app(A, B, C) :-
%   (
%       A == [],
%       C := B
%   ;
%       A => [H | T],
%       app(T, B, NT),
%       C <= [H | NT]
%   )
%
%-----------------------------------------------------------------------------%
%
% TRANSFORMATION FOR LOW-LEVEL DATA
%
% Concrete example of what the original predicate and its return-via-memory
% variant should look like for append, in grades for which it is possible to
% take the address of a field:
%
% app(list(T)::in, list(T)::in, list(T)::out)
% app(A, B, C) :-
%   (
%       A == [],
%       C := B
%   ;
%       A => [H | T],
%       C <= [H | _HT] capture &HT in AddrHT
%       app'(T, B, AddrHT)
%   )
%
% app'(list(T)::in, list(T)::in, store_at_ref_type(T)::in)
% app'(A, B, AddrC) :-
%   (
%       A == [],
%       C := B,
%       store_at_ref(AddrC, C)
%   ;
%       A => [H | T],
%       C <= [H | _HT] capture &HT in AddrHT
%       store_at_ref(AddrC, C)
%       app'(T, B, AddrHT)
%   )
%
% The transformation done on the original predicate is to take recursive calls
% followed by construction unifications that use outputs of the recursive calls
% (each being used just once) and
%
% 1 move the constructions from after the recursive call to before, and attach
%   a feature to them that tells the code generator to not define a given list
%   of fields, but to capture their addresses in the related variable instead,
%
% 2 make the call go to the variant, and pass the address variables (e.g.
%   AddrHT) as inputs instead of the original variables (e.g. HT) as outputs.
%
% The variant predicate is based on the transformed version of the original
% predicate, but it has a further transformation performed on it. This further
% transformation
%
% 3 replaces the output arguments with input arguments of type
%   store_at_ref_type(T), where T is type of the field pointed to, and
%
% 4 calls to other procedures in the same SCC are replaced by calls to
%   variants where possible, and
%
% 5 follows each primitive goal that binds one of the output arguments
%   with a store to the memory location indicated by the corresponding pointer.
%
%   p(In1, ... InN, Out1, ... OutM) :-
%       Out1 = ground
%   p(In1, ... InN, Out1, ... OutM) :-
%       ...
%       Out1 = f1(...Mid1...)
%           capture addr of Mid1 in Addr1
%       p'(In1, ... InN, Addr1, Out2... OutM)
%
%   p'(In1, ... InN, Ref1, ... OutM) :-
%       Out1 = ground,
%       store_at_ref(Ref1, Out1)
%   p'(In1, ... InN, Ref1, Out2... OutM) :-
%       ...
%       Out1 = f1(...Mid1...)
%           capture addr of Mid1 in Addr1
%       store_at_ref(Ref1, Out1)
%       p'(In1, ... InN, Addr1, Out2... OutM)
%
%-----------------------------------------------------------------------------%
%
% TRANSFORMATION FOR HIGH-LEVEL DATA
%
% In grades where it is impossible to take the address of a field (we assume
% this is so when using --highlevel-data), the transformed procedures are
% passed partially instantiated cells, whose holes need to be filled.
% The append example looks like:
%
% app(list(T)::in, list(T)::in, list(T)::out)
% app(A, B, C) :-
%   (
%       A == [],
%       C := B
%   ;
%       A => [H | T],
%       C <= [H | _],   % with hole
%       app'(T, B, C)
%   )
%
% app'(list(T)::in, list(T)::in, T::in(bound('[|]'(ground, free))))
% app'(A, B, C) :-
%   (
%       A == [],
%       C => [_ | []]   % fill in hole
%   ;
%       A => [H | T],
%       C <= [H | _HT], % bind C to AddrC
%       app'(T, B, AddrC)
%   )
%
% The differences are:
%
% 1 The output arguments become partially instantiated input arguments
%   instead of store_at_ref_type(T) arguments.
%
% 2 The holes in the output arguments are filled in with unifications
%   instead of a store_at_ref builtin.
%
% 3 Variant procedures need to know the functor and position of the argument in
%   the partially instantiated structures, so many more variants could be
%   produced. The number of variants is capped.
%
%-----------------------------------------------------------------------------%

:- module transform_hlds.lco.
:- interface.

:- import_module hlds.hlds_module.

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

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

:- implementation.

:- import_module check_hlds.inst_match.
:- import_module check_hlds.mode_util.
:- import_module check_hlds.type_util.
:- import_module hlds.arg_info.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_code_util.
:- import_module hlds.hlds_data.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_out.
:- import_module hlds.hlds_out.hlds_out_goal.
:- import_module hlds.hlds_pred.
:- import_module hlds.instmap.
:- import_module hlds.pred_table.
:- import_module hlds.quantification.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_util.
:- import_module transform_hlds.dependency_graph.

:- import_module assoc_list.
:- import_module bag.
:- import_module bool.
:- import_module int.
:- import_module io.
:- import_module list.
:- import_module map.
:- import_module multi_map.
:- import_module maybe.
:- import_module pair.
:- import_module require.
:- import_module set.
:- import_module string.
:- import_module term.
:- import_module varset.

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

:- type variant_id
    --->    variant_id(
                list(variant_arg),  % The output arguments returned in memory.
                pred_proc_id,       % The id of the variant.
                string              % The name of the variant predicate.
            ).

:- type variant_arg
    --->    variant_arg(
                % Position of the output argument.  The first output argument
                % is 1, the second is 2, and so on, without counting input
                % arguments.
                va_pos      :: int,

                % For low-level data this is `no'.
                % For high-level data this is `yes(FieldId)' where FieldId
                % indicates the functor that the argument will be bound to, and
                % the argument of that functor which is to be filled.
                va_field    :: maybe(field_id)
            ).

:- type field_id
    --->    field_id(
                fi_type     :: mer_type,
                fi_cons_id  :: cons_id,
                fi_arg      :: int
            ).

:- type variant_map == multi_map(pred_proc_id, variant_id).

:- type lco_is_permitted_on_scc
    --->    lco_is_not_permitted_on_scc
    ;       lco_is_permitted_on_scc.

:- type proc_changed
    --->    proc_not_changed
    ;       proc_changed.

:- type allow_float_addr
    --->    do_not_allow_float_addr
    ;       allow_float_addr.

:- type lco_info
    --->    lco_info(
                lco_module_info         :: module_info,
                lco_cur_scc_variants    :: variant_map,
                lco_var_set             :: prog_varset,
                lco_var_types           :: vartypes,
                lco_allow_float_addr    :: allow_float_addr,
                lco_permitted           :: lco_is_permitted_on_scc,
                lco_changed             :: proc_changed
            ).

:- type lco_const_info
    --->    lco_const_info(
                lci_lower_scc_variants  :: variant_map,
                lci_cur_scc             :: set(pred_proc_id),
                lci_cur_proc_id         :: pred_proc_id,
                lci_cur_proc_pred       :: pred_info,
                lci_cur_proc_proc       :: proc_info,
                lci_cur_proc_outputs    :: list(prog_var),
                lci_cur_proc_detism     :: determinism,
                lci_highlevel_data      :: bool
            ).

:- type var_to_target == assoc_list(prog_var, store_target).

:- type store_target
    --->    store_target(
                prog_var,
                maybe(field_id)
            ).

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

lco_modulo_constructors(!ModuleInfo) :-
    module_info_rebuild_dependency_info(!ModuleInfo, DepInfo),
    hlds_dependency_info_get_dependency_ordering(DepInfo, SCCs),
    list.foldl2(lco_scc, SCCs, map.init, _, !ModuleInfo).

:- pred lco_scc(list(pred_proc_id)::in, variant_map::in, variant_map::out,
    module_info::in, module_info::out) is det.

lco_scc(SCC, !VariantMap, !ModuleInfo) :-
    % XXX did we forget to add CurSCCVariants to !VariantMap?
    ModuleInfo0 = !.ModuleInfo,
    list.foldl4(lco_proc(!.VariantMap, SCC), SCC, !ModuleInfo,
        map.init, CurSCCVariantMap, map.init, CurSCCUpdateMap,
        lco_is_permitted_on_scc, Permitted),
    multi_map.to_flat_assoc_list(CurSCCVariantMap, CurSCCVariants),
    map.to_assoc_list(CurSCCUpdateMap, CurSCCUpdates),
    (
        Permitted = lco_is_permitted_on_scc,
        CurSCCUpdates = [_ | _]
    ->
        list.foldl(lco_process_proc_update, CurSCCUpdates, !ModuleInfo),
        list.foldl(lco_process_proc_variant(CurSCCVariantMap), CurSCCVariants,
            !ModuleInfo)
    ;
        !:ModuleInfo = ModuleInfo0
    ).

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

:- pred lco_process_proc_update(pair(pred_proc_id, proc_info)::in,
    module_info::in, module_info::out) is det.

lco_process_proc_update(PredProcId - NewProcInfo, !ModuleInfo) :-
    PredProcId = proc(PredId, ProcId),
    module_info_get_preds(!.ModuleInfo, PredTable0),
    map.lookup(PredTable0, PredId, PredInfo0),
    pred_info_get_procedures(PredInfo0, Procs0),
    map.det_update(ProcId, NewProcInfo, Procs0, Procs),
    pred_info_set_procedures(Procs, PredInfo0, PredInfo),
    map.det_update(PredId, PredInfo, PredTable0, PredTable),
    module_info_set_preds(PredTable, !ModuleInfo).

:- pred lco_process_proc_variant(variant_map::in,
    pair(pred_proc_id, variant_id)::in,
    module_info::in, module_info::out) is det.

lco_process_proc_variant(VariantMap, PredProcId - VariantId, !ModuleInfo) :-
    VariantId = variant_id(AddrOutArgs, VariantPredProcId, VariantName),
    VariantPredProcId = proc(VariantPredId, VariantProcId),
    PredProcId = proc(PredId, ProcId),

    module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId,
        _PredInfo, ProcInfo),
    lco_transform_variant_proc(VariantMap, AddrOutArgs, ProcInfo,
        VariantProcInfo, !ModuleInfo),

    proc_info_get_headvars(VariantProcInfo, HeadVars),
    proc_info_get_vartypes(VariantProcInfo, VarTypes),
    map.apply_to_list(HeadVars, VarTypes, ArgTypes),

    some [!VariantPredInfo, !PredTable] (
        module_info_get_preds(!.ModuleInfo, !:PredTable),
        map.lookup(!.PredTable, VariantPredId, !:VariantPredInfo),
        pred_info_set_name(VariantName, !VariantPredInfo),
        pred_info_set_is_pred_or_func(pf_predicate, !VariantPredInfo),

        % Update the argument types for the variant's pred_info.
        pred_info_get_arg_types(!.VariantPredInfo, TVarSet, ExistQVars,
            _ArgTypes0),
        pred_info_set_arg_types(TVarSet, ExistQVars, ArgTypes,
            !VariantPredInfo),

        pred_info_get_origin(!.VariantPredInfo, Origin0),
        AddrOutArgPosns = list.map(va_pos, AddrOutArgs),
        Transform = transform_return_via_ptr(ProcId, AddrOutArgPosns),
        Origin = origin_transformed(Transform, Origin0, PredId),
        pred_info_set_origin(Origin, !VariantPredInfo),

        % We throw away any other procs in the variant predicate, because
        % we create a separate predicate for each variant.
        VariantProcs = map.singleton(VariantProcId, VariantProcInfo),
        pred_info_set_procedures(VariantProcs, !VariantPredInfo),
        map.det_update(VariantPredId, !.VariantPredInfo, !PredTable),
        module_info_set_preds(!.PredTable, !ModuleInfo)
    ).

:- func va_pos(variant_arg) = int.

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

:- pred lco_proc(variant_map::in, list(pred_proc_id)::in,
    pred_proc_id::in, module_info::in, module_info::out,
    variant_map::in, variant_map::out,
    map(pred_proc_id, proc_info)::in, map(pred_proc_id, proc_info)::out,
    lco_is_permitted_on_scc::in, lco_is_permitted_on_scc::out) is det.

lco_proc(LowerSCCVariants, SCC, CurProc, !ModuleInfo, !CurSCCVariants,
        !CurSCCUpdates, !Permitted) :-
    (
        !.Permitted = lco_is_not_permitted_on_scc
    ;
        !.Permitted = lco_is_permitted_on_scc,
        CurProc = proc(PredId, ProcId),
        module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId,
            PredInfo, ProcInfo0),
        pred_info_get_import_status(PredInfo, Status),
        DefInThisModule = status_defined_in_this_module(Status),
        proc_info_get_inferred_determinism(ProcInfo0, Detism),
        (
            ( DefInThisModule = no
            ; not acceptable_detism_for_lco(Detism)
            )
        ->
            !:Permitted = lco_is_not_permitted_on_scc
        ;
            proc_info_get_varset(ProcInfo0, VarSet0),
            proc_info_get_vartypes(ProcInfo0, VarTypes0),
            proc_info_get_headvars(ProcInfo0, HeadVars),
            proc_info_get_argmodes(ProcInfo0, ArgModes),
            list.map(map.lookup(VarTypes0), HeadVars, ArgTypes),
            arg_info.compute_in_and_out_vars(!.ModuleInfo, HeadVars,
                ArgModes, ArgTypes, _InputHeadVars, OutputHeadVars),
            proc_info_get_inferred_determinism(ProcInfo0, CurProcDetism),
            globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
            ConstInfo = lco_const_info(LowerSCCVariants, list_to_set(SCC),
                CurProc, PredInfo, ProcInfo0, OutputHeadVars, CurProcDetism,
                HighLevelData),
            module_info_get_globals(!.ModuleInfo, Globals),
            globals.lookup_bool_option(Globals, highlevel_code,
                HighLevelCode),
            (
                HighLevelCode = yes,
                % At the moment, the hlc backend boxes floats when they appear
                % as arguments in structures (even on 64 bit platforms), but
                % NOT when it passes them as stand-alone arguments. When this
                % pass transforms the HLDS, if the to-be-filled-in-later slot
                % contains a Mercury float, the code generated by the hlc
                % backend (and probably the other MLDS backeds) will take
                % the address of a boxed float, and casts it to be a pointer
                % to an unboxed float. The callee then fills in the pointed-to
                % location with a float, the caller interprets this as a
                % boxed float i.e. a pointer to a float, and you get a
                % core dump.
                AllowFloatAddr = do_not_allow_float_addr
            ;
                HighLevelCode = no,
                % The low level backend does not suffer from the problem:
                % if sizeof(double) == sizeof(void *), it uses unboxed
                % floats in both places (structures and arguments); if they are
                % of different sizes, it uses boxed floats in both places.
                AllowFloatAddr = allow_float_addr
            ),
            Info0 = lco_info(!.ModuleInfo, !.CurSCCVariants,
                VarSet0, VarTypes0, AllowFloatAddr,
                lco_is_permitted_on_scc, proc_not_changed),
            proc_info_get_goal(ProcInfo0, Goal0),
            lco_in_goal(Goal0, Goal, Info0, Info, ConstInfo),
            Info = lco_info(!:ModuleInfo, !:CurSCCVariants,
                VarSet, VarTypes, _AllowFloatAddr, !:Permitted, Changed),
            (
                !.Permitted = lco_is_permitted_on_scc,
                Changed = proc_changed
            ->
                trace [compiletime(flag("lco")), io(!IO)] (
                    io.write_string("\ngoal before lco:\n", !IO),
                    dump_goal(!.ModuleInfo, VarSet, Goal0, !IO),
                    io.nl(!IO),
                    io.write_string("\ngoal after lco:\n", !IO),
                    dump_goal(!.ModuleInfo, VarSet, Goal, !IO),
                    io.nl(!IO)
                ),
                some [!ProcInfo] (
                    !:ProcInfo = ProcInfo0,
                    proc_info_set_varset(VarSet, !ProcInfo),
                    proc_info_set_vartypes(VarTypes, !ProcInfo),
                    proc_info_set_goal(Goal, !ProcInfo),
                    requantify_proc_general(ordinary_nonlocals_no_lambda,
                        !ProcInfo),
                    map.det_insert(CurProc, !.ProcInfo, !CurSCCUpdates)
                )
            ;
                true
            )
        )
    ).

    % Procedures which can succeed more than once can't do proper tail calls,
    % and procedures that cannot succeed at all should not be optimized
    % for time.
    %
:- pred acceptable_detism_for_lco(determinism::in) is semidet.

acceptable_detism_for_lco(detism_det).
acceptable_detism_for_lco(detism_semi).
acceptable_detism_for_lco(detism_cc_multi).
acceptable_detism_for_lco(detism_cc_non).

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

:- pred lco_in_goal(hlds_goal::in, hlds_goal::out, lco_info::in, lco_info::out,
    lco_const_info::in) is det.

lco_in_goal(Goal0, Goal, !Info, ConstInfo) :-
    Goal0 = hlds_goal(GoalExpr0, GoalInfo),
    (
        GoalExpr0 = conj(ConjType, Goals0),
        (
            ConjType = plain_conj,
            lco_in_conj(list.reverse(Goals0), [], bag.init, MaybeGoals,
                !Info, ConstInfo),
            (
                MaybeGoals = yes(Goals),
                GoalExpr = conj(plain_conj, Goals)
            ;
                MaybeGoals = no,
                % If the top-level conjunction doesn't end with some
                % unifications we can move before a recursive call,
                % maybe it ends with a switch or if-then-else, some of whose
                % arms fit that pattern.
                ( list.split_last(Goals0, AllButLast, Last0) ->
                    lco_in_goal(Last0, Last, !Info, ConstInfo),
                    GoalExpr = conj(plain_conj, AllButLast ++ [Last])
                ;
                    GoalExpr = GoalExpr0
                )
            )
        ;
            ConjType = parallel_conj,
            GoalExpr = GoalExpr0,
            !Info ^ lco_permitted := lco_is_not_permitted_on_scc
        )
    ;
        GoalExpr0 = disj(Goals0),
        % There is no point in looking for tail calls in the non-last
        % disjuncts.
        ( list.split_last(Goals0, AllButLast, Last0) ->
            lco_in_goal(Last0, Last, !Info, ConstInfo),
            GoalExpr = disj(AllButLast ++ [Last])
        ;
            GoalExpr = GoalExpr0
        )
    ;
        GoalExpr0 = switch(Var, CanFail, Cases0),
        lco_in_cases(Cases0, Cases, !Info, ConstInfo),
        GoalExpr = switch(Var, CanFail, Cases)
    ;
        GoalExpr0 = if_then_else(Vars, Cond, Then0, Else0),
        lco_in_goal(Then0, Then, !Info, ConstInfo),
        lco_in_goal(Else0, Else, !Info, ConstInfo),
        GoalExpr = if_then_else(Vars, Cond, Then, Else)
    ;
        GoalExpr0 = scope(Reason, SubGoal0),
        ( Reason = from_ground_term(_, from_ground_term_construct) ->
            GoalExpr = GoalExpr0
        ;
            lco_in_goal(SubGoal0, SubGoal, !Info, ConstInfo),
            GoalExpr = scope(Reason, SubGoal)
        )
    ;
        ( GoalExpr0 = negation(_)
        ; GoalExpr0 = generic_call(_, _, _, _)
        ; GoalExpr0 = plain_call(_, _, _, _, _, _)
        ; GoalExpr0 = unify(_, _, _, _, _)
        ; GoalExpr0 = call_foreign_proc(_, _, _, _,  _, _, _)
        ),
        GoalExpr = GoalExpr0
    ;
        GoalExpr0 = shorthand(_),
        % These should have been expanded out by now.
        unexpected($module, $pred, "shorthand")
    ),
    Goal = hlds_goal(GoalExpr, GoalInfo).

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

:- pred lco_in_disj(list(hlds_goal)::in, list(hlds_goal)::out,
    lco_info::in, lco_info::out, lco_const_info::in) is det.

lco_in_disj([], [], !Info, _ConstInfo).
lco_in_disj([Goal0 | Goals0], [Goal | Goals], !Info, ConstInfo) :-
    lco_in_goal(Goal0, Goal, !Info, ConstInfo),
    lco_in_disj(Goals0, Goals, !Info, ConstInfo).

:- pred lco_in_cases(list(case)::in, list(case)::out,
    lco_info::in, lco_info::out, lco_const_info::in) is det.

lco_in_cases([], [], !Info, _ConstInfo).
lco_in_cases([Case0 | Cases0], [Case | Cases], !Info, ConstInfo) :-
    Case0 = case(MainConsId, OtherConsIds, Goal0),
    lco_in_goal(Goal0, Goal, !Info, ConstInfo),
    Case = case(MainConsId, OtherConsIds, Goal),
    lco_in_cases(Cases0, Cases, !Info, ConstInfo).

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

    % lco_in_conj(RevGoals, Unifies, ModuleInfo, Goals)
    %
    % Given a conjunction whose structure is:
    %
    %   zero or more arbitrary goals
    %   recursive call that could be a last call modulo constructors
    %   one or more construction unifications
    %
    % move the construction unifications before the call.
    %
    % We traverse the conjunction backwards (the caller has reversed the list).
    % RevGoals is the list of remaining goals in the reversed conjunction list.
    % RevUnifies is the list of assignments and constructions delayed by any
    % previous recursive invocations of lco_in_conj.
    %
    % invariant: append(reverse(RevGoals), Unifies) = original conjunction
    %
:- pred lco_in_conj(list(hlds_goal)::in, list(hlds_goal)::in,
    bag(prog_var)::in, maybe(list(hlds_goal))::out,
    lco_info::in, lco_info::out, lco_const_info::in) is det.

lco_in_conj([], _Unifies, _UnifyInputVars, no, !Info, _ConstInfo).
lco_in_conj([RevGoal | RevGoals], !.Unifies, !.UnifyInputVars, MaybeGoals,
        !Info, ConstInfo) :-
    RevGoal = hlds_goal(RevGoalExpr, RevGoalInfo),
    ModuleInfo = !.Info ^ lco_module_info,
    ProcInfo = ConstInfo ^ lci_cur_proc_proc,
    proc_info_get_vartypes(ProcInfo, VarTypes),
    (
        RevGoalExpr = unify(_, _, _, Unification, _),
        Unification = construct(ConstructedVar, ConsId, ConstructArgs,
            ArgUniModes, _, _, SubInfo),
        (
            SubInfo = no_construct_sub_info
        ;
            SubInfo = construct_sub_info(no, _)
        ),
        all_true(acceptable_construct_mode(ModuleInfo), ArgUniModes),
        ConsTag = cons_id_to_tag(ModuleInfo, ConsId),
        % The code generator can't handle some kinds of tags. For example,
        % it does not make sense to take the address of the field of a function
        % symbol of a `notag' type. These are the kinds it CAN handle.
        (
            ConsTag = single_functor_tag
        ;
            ConsTag = unshared_tag(_)
        ;
            ConsTag = shared_remote_tag(_, _)
        )
    ->
        trace [compiletime(flag("lco")), io(!IO)] (
            io.write_string("processing unification ", !IO),
            io.write(ConstructedVar, !IO),
            io.write_string(" <= ", !IO),
            io.write(ConsId, !IO),
            io.write_string("(", !IO),
            io.write(ConstructArgs, !IO),
            io.write_string(")\n", !IO)
        ),
        trace [compiletime(flag("lco")), io(!IO)] (
            io.write_string("initial UnifyInputVars: ", !IO),
            io.write(!.UnifyInputVars, !IO),
            io.nl(!IO)
        ),
        bag.delete(ConstructedVar, !UnifyInputVars),
        bag.insert_list(ConstructArgs, !UnifyInputVars),
        trace [compiletime(flag("lco")), io(!IO)] (
            io.write_string("updated UnifyInputVars: ", !IO),
            io.write(!.UnifyInputVars, !IO),
            io.nl(!IO)
        ),
        !:Unifies = [RevGoal | !.Unifies],
        lco_in_conj(RevGoals, !.Unifies, !.UnifyInputVars, MaybeGoals,
            !Info, ConstInfo)
    ;
        RevGoalExpr = plain_call(PredId, ProcId, Args, Builtin, UnifyContext,
            SymName),
        set.member(proc(PredId, ProcId), ConstInfo ^ lci_cur_scc),
        goal_info_get_determinism(RevGoalInfo) =
            ConstInfo ^ lci_cur_proc_detism,

        module_info_pred_proc_info(ModuleInfo, PredId, ProcId,
            _CalleePredInfo, CalleeProcInfo),
        proc_info_get_argmodes(CalleeProcInfo, CalleeArgModes),
        classify_proc_call_args(ModuleInfo, VarTypes, Args, CalleeArgModes,
            _InArgs, OutArgs, UnusedArgs),
        UnusedArgs = [],
        trace [compiletime(flag("lco")), io(!IO)] (
            io.write_string("call output args: ", !IO),
            io.write(OutArgs, !IO),
            io.nl(!IO)
        ),
        list.length(OutArgs, NumOutArgs),
        CurrProcOutArgs = ConstInfo ^ lci_cur_proc_outputs,
        list.length(CurrProcOutArgs, NumCurrProcOutArgs),
        NumOutArgs = NumCurrProcOutArgs,

        assoc_list.from_corresponding_lists(OutArgs, CurrProcOutArgs,
            CallHeadPairs),
        find_args_to_pass_by_addr(ConstInfo, !.UnifyInputVars, CallHeadPairs,
            1, Mismatches, UpdatedCallOutArgs, map.init, Subst, !Info),
        trace [compiletime(flag("lco")), io(!IO)] (
            io.write_string("find_args_to_pass_by_addr:\n", !IO),
            io.write_string("call head pairs: ", !IO),
            io.write(CallHeadPairs, !IO),
            io.nl(!IO),
            io.write_string("mismatches: ", !IO),
            io.write(Mismatches, !IO),
            io.nl(!IO),
            io.write_string("updated call out args: ", !IO),
            io.write(UpdatedCallOutArgs, !IO),
            io.nl(!IO),
            io.write_string("substitution: ", !IO),
            io.write(Subst, !IO),
            io.nl(!IO),
            io.nl(!IO)
        ),
        % If there are no mismatches, we would create an identical "variant".
        % Such cases should be optimized using other means.
        Mismatches = [_ | _],
        assoc_list.values(Mismatches, MismatchedCallArgs),
        % The variants we create return each output in only one place in
        % memory.
        all_true(occurs_once(!.UnifyInputVars), MismatchedCallArgs),

        list.map_foldl2(update_construct(ConstInfo, Subst),
            !.Unifies, UpdatedUnifies, map.init, AddrFieldIds, !Info),
        trace [compiletime(flag("lco")), io(!IO)] (
            VarSet = !.Info ^ lco_var_set,
            io.write_string("original unifies:\n", !IO),
            io.write_list(!.Unifies, "\n",
                dump_goal(ModuleInfo, VarSet), !IO),
            io.nl(!IO),
            io.write_string("updated unifies:\n", !IO),
            io.write_list(UpdatedUnifies, "\n",
                dump_goal(ModuleInfo, VarSet), !IO),
            io.nl(!IO),
            io.write_string("addr field ids:\n", !IO),
            io.write(AddrFieldIds, !IO),
            io.nl(!IO)
        ),
        HighLevelData = ConstInfo ^ lci_highlevel_data,
        make_variant_args(HighLevelData, AddrFieldIds, Mismatches,
            VariantArgs),
        ensure_variant_exists(PredId, ProcId, VariantArgs,
            VariantPredProcId, SymName, VariantSymName, !Info)
    ->
        proc_info_get_argmodes(CalleeProcInfo, CalleeModes),
        update_call_args(ModuleInfo, VarTypes, CalleeModes, Args,
            UpdatedCallOutArgs, UpdatedArgs),
        VariantPredProcId = proc(VariantPredId, VariantProcId),
        UpdatedGoalExpr = plain_call(VariantPredId, VariantProcId, UpdatedArgs,
            Builtin, UnifyContext, VariantSymName),
        UpdatedGoalInfo = RevGoalInfo,
        UpdatedGoal = hlds_goal(UpdatedGoalExpr, UpdatedGoalInfo),
        Goals = list.reverse(RevGoals) ++ UpdatedUnifies ++ [UpdatedGoal],
        MaybeGoals = yes(Goals),
        !Info ^ lco_changed := proc_changed
    ;
        % The reversed conjunction does not follow the pattern we are looking
        % for, so we cannot optimize it.
        MaybeGoals = no
    ).

:- pred update_call_args(module_info::in, vartypes::in, list(mer_mode)::in,
    list(prog_var)::in, list(prog_var)::in, list(prog_var)::out) is det.

update_call_args(_ModuleInfo, _VarTypes, [], [], UpdatedCallOutArgs, []) :-
    expect(unify(UpdatedCallOutArgs, []), $module,
        "update_call_args: updating nonexistent arg").
update_call_args(_ModuleInfo, _VarTypes, [], [_ | _], _, _) :-
    unexpected($module, $pred, "mismatched lists").
update_call_args(_ModuleInfo, _VarTypes, [_ | _], [], _, _) :-
    unexpected($module, $pred, "mismatched lists").
update_call_args(ModuleInfo, VarTypes, [CalleeMode | CalleeModes],
        [Arg | Args], !.UpdatedCallOutArgs, !:UpdatedArgs) :-
    map.lookup(VarTypes, Arg, CalleeType),
    mode_to_arg_mode(ModuleInfo, CalleeMode, CalleeType, ArgMode),
    (
        ArgMode = top_in,
        update_call_args(ModuleInfo, VarTypes, CalleeModes, Args,
            !.UpdatedCallOutArgs, !:UpdatedArgs),
        !:UpdatedArgs = [Arg | !.UpdatedArgs]
    ;
        ArgMode = top_out,
        (
            !.UpdatedCallOutArgs = [UpdatedArg | !:UpdatedCallOutArgs]
        ;
            !.UpdatedCallOutArgs = [],
            unexpected($module, $pred, "no UpdatedCallOutArgs")
        ),
        update_call_args(ModuleInfo, VarTypes, CalleeModes, Args,
            !.UpdatedCallOutArgs, !:UpdatedArgs),
        !:UpdatedArgs = [UpdatedArg | !.UpdatedArgs]
    ;
        ArgMode = top_unused,
        unexpected($module, $pred, "top_unused")
    ).

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

:- pred classify_proc_call_args(module_info::in, vartypes::in,
    list(prog_var)::in, list(mer_mode)::in,
    list(prog_var)::out, list(prog_var)::out, list(prog_var)::out) is det.

classify_proc_call_args(_ModuleInfo, _VarTypes, [], [], [], [], []).
classify_proc_call_args(_ModuleInfo, _VarTypes, [], [_ | _], _, _, _) :-
    unexpected($module, $pred, "mismatched lists").
classify_proc_call_args(_ModuleInfo, _VarTypes, [_ | _], [], _, _, _) :-
    unexpected($module, $pred, "mismatched lists").
classify_proc_call_args(ModuleInfo, VarTypes, [Arg | Args],
        [CalleeMode | CalleeModes], !:InArgs, !:OutArgs, !:UnusedArgs) :-
    classify_proc_call_args(ModuleInfo, VarTypes, Args, CalleeModes,
        !:InArgs, !:OutArgs, !:UnusedArgs),
    map.lookup(VarTypes, Arg, CalleeType),
    mode_to_arg_mode(ModuleInfo, CalleeMode, CalleeType, ArgMode),
    (
        ArgMode = top_in,
        !:InArgs = [Arg | !.InArgs]
    ;
        ArgMode = top_out,
        !:OutArgs = [Arg | !.OutArgs]
    ;
        ArgMode = top_unused,
        !:UnusedArgs = [Arg | !.UnusedArgs]
    ).

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

:- pred find_args_to_pass_by_addr(lco_const_info::in, bag(prog_var)::in,
    assoc_list(prog_var, prog_var)::in, int::in,
    assoc_list(int, prog_var)::out, list(prog_var)::out,
    map(prog_var, prog_var)::in, map(prog_var, prog_var)::out,
    lco_info::in, lco_info::out) is det.

find_args_to_pass_by_addr(_ConstInfo, _, [], _, [], [], !Subst, !Info).
find_args_to_pass_by_addr(ConstInfo, UnifyInputVars,
        [CallArg - HeadArg | CallHeadArgs], ArgNum, Mismatches,
        [UpdatedCallArg | UpdatedCallArgs], !Subst, !Info) :-
    find_args_to_pass_by_addr(ConstInfo, UnifyInputVars, CallHeadArgs,
        ArgNum + 1, MismatchesTail, UpdatedCallArgs, !Subst, !Info),
    (
        !.Info ^ lco_allow_float_addr = do_not_allow_float_addr,
        map.lookup(!.Info ^ lco_var_types, CallArg, CallArgType),
        type_to_ctor(CallArgType, CallArgTypeCtor),
        CallArgTypeCtor = type_ctor(unqualified("float"), 0)
    ->
        !Info ^ lco_permitted := lco_is_not_permitted_on_scc
    ;
        true
    ),
    ( CallArg = HeadArg ->
        UpdatedCallArg = CallArg,
        Mismatches = MismatchesTail,
        ( bag.member(HeadArg, UnifyInputVars) ->
            % This is a fix for Mantis bug 103. If CallArg is both a head
            % variable AND used in a unification that we are trying to move
            % before the recursive call, like this:
            %
            %   rec_call(..., HV2, X),
            %   HV3 = functor(HV2, X)
            %
            % then each call through this recursive call site is next to a
            % unification that creates a cell with a field (in this case
            % the first field) that needs to be set to the value of HV2
            % finally computed by a base case. After the Nth recursive call,
            % there will be N cells. There is no way we can pass N addresses
            % to the base case without making the transformed code pass a
            % LIST of addresses in place of HV2 in the argument list.
            % That would be a different transformation than what lco.m does,
            % and it is far from clear that that transformation would be a
            % good idea, since it doubles the number of loop iterations
            % we would need to execute (N recursive calls, and N iterations
            % of a loop to fill in the fields).
            %
            % Instead, we just disable the application of the lco
            % transformation to this call.

            !Info ^ lco_permitted := lco_is_not_permitted_on_scc
        ;
            true
        )
    ;
        make_address_var(ConstInfo, CallArg, UpdatedCallArg, !Info),
        Mismatches = [ArgNum - CallArg | MismatchesTail],
        map.det_insert(CallArg, UpdatedCallArg, !Subst)
    ).

:- pred make_address_var(lco_const_info::in, prog_var::in, prog_var::out,
    lco_info::in, lco_info::out) is det.

make_address_var(ConstInfo, Var, AddrVar, !Info) :-
    VarSet0 = !.Info ^ lco_var_set,
    VarTypes0 = !.Info ^ lco_var_types,
    varset.lookup_name(VarSet0, Var, "SCCcallarg", Name),
    AddrName = "Addr" ++ Name,
    varset.new_named_var(AddrName, AddrVar, VarSet0, VarSet),
    HighLevelData = ConstInfo ^ lci_highlevel_data,
    (
        HighLevelData = no,
        map.lookup(VarTypes0, Var, FieldType),
        AddrVarType = make_ref_type(FieldType),
        map.det_insert(AddrVar, AddrVarType, VarTypes0, VarTypes)
    ;
        HighLevelData = yes,
        % We set the type later when it is more convenient.
        VarTypes = VarTypes0
    ),
    !Info ^ lco_var_set := VarSet,
    !Info ^ lco_var_types := VarTypes.

:- func make_ref_type(mer_type) = mer_type.

make_ref_type(FieldType) = PtrType :-
    RefTypeName = qualified(mercury_private_builtin_module,
        "store_at_ref_type"),
    PtrType = defined_type(RefTypeName, [FieldType], kind_star).

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

:- pred make_variant_args(bool::in, map(prog_var, field_id)::in,
    assoc_list(int, prog_var)::in, list(variant_arg)::out) is det.

make_variant_args(HighLevelData, AddrVarFieldIds, Mismatches, VariantArgs) :-
    (
        HighLevelData = no,
        MakeArg = (func(Pos - _Var) = variant_arg(Pos, no))
    ;
        HighLevelData = yes,
        MakeArg = (func(Pos - Var) = variant_arg(Pos, yes(FieldId)) :-
            map.lookup(AddrVarFieldIds, Var, FieldId)
        )
    ),
    VariantArgs = list.map(MakeArg, Mismatches).

:- pred ensure_variant_exists(pred_id::in, proc_id::in, list(variant_arg)::in,
    pred_proc_id::out, sym_name::in, sym_name::out,
    lco_info::in, lco_info::out) is semidet.

ensure_variant_exists(PredId, ProcId, AddrArgNums, VariantPredProcId,
        SymName, VariantSymName, !Info) :-
    PredProcId = proc(PredId, ProcId),
    CurSCCVariants0 = !.Info ^ lco_cur_scc_variants,
    (
        multi_map.search(CurSCCVariants0, PredProcId, ExistingVariants),
        match_existing_variant(ExistingVariants, AddrArgNums, ExistingVariant)
    ->
        get_variant_id_and_name(ExistingVariant, SymName, VariantPredProcId,
            VariantSymName)
    ;
        ModuleInfo0 = !.Info ^ lco_module_info,
        clone_pred_proc(PredId, ClonePredId, PredOrFunc,
            ModuleInfo0, ModuleInfo),
        VariantPredProcId = proc(ClonePredId, ProcId),
        !Info ^ lco_module_info := ModuleInfo,
        ( multi_map.search(CurSCCVariants0, PredProcId, ExistingVariants) ->
            VariantNumber = list.length(ExistingVariants) + 1
        ;
            VariantNumber = 1
        ),
        VariantNumber =< max_variants_per_proc,
        (
            SymName = unqualified(Name),
            create_variant_name(PredOrFunc, VariantNumber, Name, VariantName),
            VariantSymName = unqualified(VariantName)
        ;
            SymName = qualified(ModuleName, Name),
            create_variant_name(PredOrFunc, VariantNumber, Name, VariantName),
            VariantSymName = qualified(ModuleName, VariantName)
        ),
        NewVariant = variant_id(AddrArgNums, VariantPredProcId, VariantName),
        multi_map.set(PredProcId, NewVariant, CurSCCVariants0, CurSCCVariants),
        !Info ^ lco_cur_scc_variants := CurSCCVariants
    ).

:- pred match_existing_variant(list(variant_id)::in, list(variant_arg)::in,
    variant_id::out) is semidet.

match_existing_variant([Variant0 | Variants], AddrArgNums, Variant) :-
    ( Variant0 = variant_id(AddrArgNums, _, _) ->
        Variant = Variant0
    ;
        match_existing_variant(Variants, AddrArgNums, Variant)
    ).

:- pred get_variant_id_and_name(variant_id::in, sym_name::in,
    pred_proc_id::out, sym_name::out) is det.

get_variant_id_and_name(VariantId, SymName, PredProcId, VariantSymName) :-
    VariantId = variant_id(_, PredProcId, VariantName),
    (
        SymName = unqualified(_Name),
        VariantSymName = unqualified(VariantName)
    ;
        SymName = qualified(ModuleName, _Name),
        VariantSymName = qualified(ModuleName, VariantName)
    ).

:- func max_variants_per_proc = int.

max_variants_per_proc = 4.

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

clone_pred_proc(PredId, ClonePredId, PredOrFunc, !ModuleInfo) :-
    module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
    PredOrFunc = pred_info_is_pred_or_func(PredInfo),
    module_info_get_predicate_table(!.ModuleInfo, PredTable0),
    predicate_table_insert(PredInfo, ClonePredId, PredTable0, PredTable),
    module_info_set_predicate_table(PredTable, !ModuleInfo).

:- pred create_variant_name(pred_or_func::in, int::in, string::in,
    string::out) is det.

create_variant_name(PredOrFunc, VariantNumber, OrigName, VariantName) :-
    (
        PredOrFunc = pf_function,
        Prefix = "LCMCfn_"
    ;
        PredOrFunc = pf_predicate,
        Prefix = "LCMCpr_"
    ),
    VariantName = Prefix ++ OrigName ++ "_" ++ int_to_string(VariantNumber).

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

:- pred update_construct(lco_const_info::in, map(prog_var, prog_var)::in,
    hlds_goal::in, hlds_goal::out,
    map(prog_var, field_id)::in, map(prog_var, field_id)::out,
    lco_info::in, lco_info::out) is det.

update_construct(ConstInfo, Subst, Goal0, Goal, !AddrVarFieldIds, !Info) :-
    Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
    (
        GoalExpr0 = unify(LHS, RHS0, Mode, Unification0, UnifyContext),
        Unification0 = construct(Var, ConsId, ArgVars, UniModes,
            How, IsUnique, SubInfo0),
        (
            SubInfo0 = no_construct_sub_info,
            TermSizeSlot = no
        ;
            SubInfo0 = construct_sub_info(no, TermSizeSlot)
        )
    ->
        % For high-level data, we should not be using the `take_address_fields'
        % feature in `construct_sub_info', but simply assign the new cell to
        % each of the variables that takes its address. But as support for
        % partial instantiation is incomplete, instmaps for the assignments are
        % likely to be recomputed incorrectly.
        HighLevelData = ConstInfo ^ lci_highlevel_data,
        VarTypes0 = !.Info ^ lco_var_types,
        map.lookup(VarTypes0, Var, VarType),
        InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0),
        update_construct_args(Subst, HighLevelData, VarType, ConsId, 1,
            ArgVars, UpdatedArgVars, AddrFields, InstMapDelta0, InstMapDelta,
            !AddrVarFieldIds, VarTypes0, VarTypes),
        !Info ^ lco_var_types := VarTypes,
        (
            AddrFields = [],
            Goal = Goal0
        ;
            AddrFields = [_ | _],
            SubInfo = construct_sub_info(yes(AddrFields), TermSizeSlot),
            Unification = construct(Var, ConsId, UpdatedArgVars, UniModes,
                How, IsUnique, SubInfo),
            % We must update RHS because quantification gets the set of
            % variables in the unification from there, not from Unification.
            (
                RHS0 = rhs_var(_),
                unexpected($module, $pred, "var RHS")
            ;
                RHS0 = rhs_functor(RHSConsId, IsExistConstr, RHSVars0),
                expect(unify(ConsId, RHSConsId), $module,
                    "update_construct: cons_id mismatch"),
                rename_var_list(need_not_rename, Subst, RHSVars0, RHSVars),
                RHS = rhs_functor(RHSConsId, IsExistConstr, RHSVars)
            ;
                RHS0 = rhs_lambda_goal(_, _, _, _, _, _, _, _, _),
                unexpected($module, $pred, "lambda RHS")
            ),
            GoalExpr = unify(LHS, RHS, Mode, Unification, UnifyContext),

            % For high-level data, there is a lie in this instmap_delta: the
            % new cell is not yet ground, although it will become ground after
            % the call that follows the construction.
            goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo),
            Goal = hlds_goal(GoalExpr, GoalInfo)
        )
    ;
        unexpected($module, $pred, "not construct")
    ).

:- pred update_construct_args(map(prog_var, prog_var)::in, bool::in,
    mer_type::in, cons_id::in, int::in, list(prog_var)::in,
    list(prog_var)::out, list(int)::out, instmap_delta::in, instmap_delta::out,
    map(prog_var, field_id)::in, map(prog_var, field_id)::out,
    vartypes::in, vartypes::out) is det.

update_construct_args(_, _, _, _, _, [], [], [],
        !InstMapDelta, !AddrFieldIds, !VarTypes).
update_construct_args(Subst, HighLevelData, VarType, ConsId, ArgNum,
        [OrigVar | OrigVars], [UpdatedVar | UpdatedVars], AddrArgs,
        !InstMapDelta, !AddrFieldIds, !VarTypes) :-
    update_construct_args(Subst, HighLevelData, VarType, ConsId, ArgNum + 1,
        OrigVars, UpdatedVars, AddrArgsTail, !InstMapDelta, !AddrFieldIds,
        !VarTypes),
    ( map.search(Subst, OrigVar, AddrVar) ->
        UpdatedVar = AddrVar,
        (
            HighLevelData = no,
            FinalInst = ground_inst
        ;
            HighLevelData = yes,
            BoundInst = bound_inst_with_free_arg(ConsId, ArgNum),
            FinalInst = bound(shared, [BoundInst]),
            % We didn't do this when we initially created the variable.
            map.det_insert(AddrVar, VarType, !VarTypes)
        ),
        instmap_delta_set_var(AddrVar, FinalInst, !InstMapDelta),
        map.det_insert(OrigVar, field_id(VarType, ConsId, ArgNum),
            !AddrFieldIds),
        AddrArgs = [ArgNum | AddrArgsTail]
    ;
        UpdatedVar = OrigVar,
        AddrArgs = AddrArgsTail
    ).

:- func bound_inst_with_free_arg(cons_id, int) = bound_inst.

bound_inst_with_free_arg(ConsId, FreeArg) = Inst :-
    Arity = cons_id_arity(ConsId),
    list.duplicate(Arity, ground_inst, ArgInsts0),
    list.det_replace_nth(ArgInsts0, FreeArg, free_inst, ArgInsts),
    Inst = bound_functor(ConsId, ArgInsts).

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

:- pred acceptable_construct_mode(module_info::in, uni_mode::in) is semidet.

acceptable_construct_mode(ModuleInfo, UniMode) :-
    UniMode = ((InitInstX - InitInstY) -> (FinalInstX - FinalInstY)),
    inst_is_free(ModuleInfo, InitInstX),
    inst_is_ground(ModuleInfo, InitInstY),
    inst_is_ground(ModuleInfo, FinalInstX),
    inst_is_ground(ModuleInfo, FinalInstY).

:- pred occurs_once(bag(prog_var)::in, prog_var::in) is semidet.

occurs_once(Bag, Var) :-
    bag.count_value(Bag, Var, 1).

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

:- pred lco_transform_variant_proc(variant_map::in, list(variant_arg)::in,
    proc_info::in, proc_info::out, module_info::in, module_info::out) is det.

lco_transform_variant_proc(VariantMap, AddrOutArgs, ProcInfo,
        !:VariantProcInfo, !ModuleInfo) :-
    !:VariantProcInfo = ProcInfo,
    proc_info_get_varset(ProcInfo, VarSet0),
    proc_info_get_vartypes(ProcInfo, VarTypes0),
    proc_info_get_headvars(ProcInfo, HeadVars0),
    proc_info_get_argmodes(ProcInfo, ArgModes0),
    make_addr_vars(HeadVars0, ArgModes0, HeadVars, ArgModes,
        AddrOutArgs, 1, !.ModuleInfo, VarToAddr,
        VarSet0, VarSet, VarTypes0, VarTypes),
    proc_info_set_headvars(HeadVars, !VariantProcInfo),
    proc_info_set_argmodes(ArgModes, !VariantProcInfo),
    proc_info_set_varset(VarSet, !VariantProcInfo),
    proc_info_set_vartypes(VarTypes, !VariantProcInfo),

    proc_info_get_initial_instmap(ProcInfo, !.ModuleInfo, InstMap0),
    proc_info_get_goal(ProcInfo, Goal0),
    lco_transform_variant_goal(!.ModuleInfo, VariantMap, VarToAddr, InstMap0,
        Goal0, Goal, _Changed, !VariantProcInfo),
    proc_info_set_goal(Goal, !VariantProcInfo),
    % We changed the scopes of the headvars we now return via pointers.
    requantify_proc_general(ordinary_nonlocals_no_lambda, !VariantProcInfo),

    % The high-level data transformation requires instmap deltas to be
    % recomputed.
    module_info_get_globals(!.ModuleInfo, Globals),
    globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
    (
        HighLevelData = yes,
        recompute_instmap_delta_proc(do_not_recompute_atomic_instmap_deltas,
            !VariantProcInfo, !ModuleInfo)
    ;
        HighLevelData = no
    ).

:- pred make_addr_vars(list(prog_var)::in, list(mer_mode)::in,
    list(prog_var)::out, list(mer_mode)::out, list(variant_arg)::in,
    int::in, module_info::in, var_to_target::out,
    prog_varset::in, prog_varset::out, vartypes::in, vartypes::out) is det.

make_addr_vars([], [], [], [], AddrOutArgs, _, _, [],
        !VarSet, !VarTypes) :-
    expect(unify(AddrOutArgs, []), $module,
        "make_addr_vars: AddrOutArgs != []").
make_addr_vars([], [_ | _], _, _, _, _, _, _, !VarSet, !VarTypes) :-
    unexpected($module, $pred, "mismatched lists").
make_addr_vars([_ | _], [], _, _, _, _, _, _, !VarSet, !VarTypes) :-
    unexpected($module, $pred, "mismatched lists").
make_addr_vars([HeadVar0 | HeadVars0], [Mode0 | Modes0],
        [HeadVar | HeadVars], [Mode | Modes], !.AddrOutArgs,
        NextOutArgNum, ModuleInfo, VarToAddr, !VarSet, !VarTypes) :-
    map.lookup(!.VarTypes, HeadVar0, HeadVarType),
    mode_to_arg_mode(ModuleInfo, Mode0, HeadVarType, ArgMode),
    (
        ArgMode = top_in,
        HeadVar = HeadVar0,
        Mode = Mode0,
        make_addr_vars(HeadVars0, Modes0, HeadVars, Modes, !.AddrOutArgs,
            NextOutArgNum, ModuleInfo, VarToAddr, !VarSet, !VarTypes)
    ;
        ArgMode = top_out,
        (
            !.AddrOutArgs = [AddrOutArg | !:AddrOutArgs],
            AddrOutArg = variant_arg(NextOutArgNum, MaybeFieldId)
        ->
            varset.lookup_name(!.VarSet, HeadVar0, Name),
            AddrName = "AddrOf" ++ Name,
            varset.new_named_var(AddrName, AddrVar, !VarSet),
            HeadVar = AddrVar,
            map.lookup(!.VarTypes, HeadVar0, OldType),
            (
                MaybeFieldId = no,
                % For low-level data we replace the output argument with a
                % store_at_ref_type(T) input argument.
                map.det_insert(AddrVar, make_ref_type(OldType), !VarTypes),
                Mode = in_mode
            ;
                MaybeFieldId = yes(field_id(AddrVarType, ConsId, ArgNum)),
                % For high-level data we replace the output argument with a
                % partially instantiated structure. The structure has one
                % argument left unfilled.
                map.det_insert(AddrVar, AddrVarType, !VarTypes),
                BoundInst = bound_inst_with_free_arg(ConsId, ArgNum),
                InitialInst = bound(shared, [BoundInst]),
                Mode = (InitialInst -> ground_inst)
            ),
            make_addr_vars(HeadVars0, Modes0, HeadVars, Modes,
                !.AddrOutArgs, NextOutArgNum + 1, ModuleInfo,
                VarToAddrTail, !VarSet, !VarTypes),
            VarToAddrHead = HeadVar0 - store_target(AddrVar, MaybeFieldId),
            VarToAddr = [VarToAddrHead | VarToAddrTail]
        ;
            HeadVar = HeadVar0,
            Mode = Mode0,
            make_addr_vars(HeadVars0, Modes0, HeadVars, Modes,
                !.AddrOutArgs, NextOutArgNum + 1, ModuleInfo,
                VarToAddr, !VarSet, !VarTypes)
        )
    ;
        ArgMode = top_unused,
        unexpected($module, $pred, "top_unused")
    ).

:- pred lco_transform_variant_goal(module_info::in, variant_map::in,
    var_to_target::in, instmap::in, hlds_goal::in, hlds_goal::out, bool::out,
    proc_info::in, proc_info::out) is det.

lco_transform_variant_goal(ModuleInfo, VariantMap, VarToAddr, InstMap0,
        Goal0, Goal, Changed, !ProcInfo) :-
    Goal0 = hlds_goal(GoalExpr0, GoalInfo0),
    (
        GoalExpr0 = conj(ConjType, Goals0),
        (
            ConjType = plain_conj,
            lco_transform_variant_conj(ModuleInfo, VariantMap, VarToAddr,
                InstMap0, Goals0, Goals, Changed, !ProcInfo),
            GoalExpr = conj(ConjType, Goals),
            GoalInfo = GoalInfo0
        ;
            ConjType = parallel_conj,
            unexpected($module, $pred, "parallel_conj")
        )
    ;
        GoalExpr0 = disj(Goals0),
        list.map2_foldl(
            lco_transform_variant_goal(ModuleInfo, VariantMap, VarToAddr,
                InstMap0),
            Goals0, Goals, DisjsChanged, !ProcInfo),
        Changed = bool.or_list(DisjsChanged),
        GoalExpr = disj(Goals),
        GoalInfo = GoalInfo0
    ;
        GoalExpr0 = switch(Var, CanFail, Cases0),
        list.map2_foldl(
            lco_transform_variant_case(ModuleInfo, VariantMap, VarToAddr,
                InstMap0),
            Cases0, Cases, CasesChanged, !ProcInfo),
        Changed = bool.or_list(CasesChanged),
        GoalExpr = switch(Var, CanFail, Cases),
        GoalInfo = GoalInfo0
    ;
        GoalExpr0 = if_then_else(Vars, Cond, Then0, Else0),
        update_instmap(Cond, InstMap0, InstMap1),
        lco_transform_variant_goal(ModuleInfo, VariantMap, VarToAddr, InstMap1,
            Then0, Then, ThenChanged, !ProcInfo),
        lco_transform_variant_goal(ModuleInfo, VariantMap, VarToAddr, InstMap0,
            Else0, Else, ElseChanged, !ProcInfo),
        Changed = bool.or(ThenChanged, ElseChanged),
        GoalExpr = if_then_else(Vars, Cond, Then, Else),
        GoalInfo = GoalInfo0
    ;
        GoalExpr0 = scope(Reason, SubGoal0),
        ( Reason = from_ground_term(_, from_ground_term_construct) ->
            GoalExpr = GoalExpr0,
            Changed = no
        ;
            lco_transform_variant_goal(ModuleInfo, VariantMap, VarToAddr,
                InstMap0, SubGoal0, SubGoal, Changed, !ProcInfo),
            GoalExpr = scope(Reason, SubGoal)
        ),
        GoalInfo = GoalInfo0
    ;
        GoalExpr0 = negation(_),
        GoalExpr = GoalExpr0,
        GoalInfo = GoalInfo0,
        Changed = no
    ;
        GoalExpr0 = generic_call(_, _, _, _),
        lco_transform_variant_atomic_goal(ModuleInfo, VarToAddr, InstMap0,
            GoalInfo0, GoalExpr0, GoalExpr, Changed, !ProcInfo),
        GoalInfo = GoalInfo0
    ;
        GoalExpr0 = plain_call(_, _, _, _, _, _),
        lco_transform_variant_plain_call(ModuleInfo, VariantMap, VarToAddr,
            InstMap0, GoalExpr0, GoalExpr, GoalInfo0, GoalInfo, Changed,
            !ProcInfo)
    ;
        GoalExpr0 = unify(_, _, _, _, _),
        lco_transform_variant_atomic_goal(ModuleInfo, VarToAddr, InstMap0,
            GoalInfo0, GoalExpr0, GoalExpr, Changed, !ProcInfo),
        GoalInfo = GoalInfo0
    ;
        GoalExpr0 = call_foreign_proc(_, _, _, _,  _, _, _),
        lco_transform_variant_atomic_goal(ModuleInfo, VarToAddr, InstMap0,
            GoalInfo0, GoalExpr0, GoalExpr, Changed, !ProcInfo),
        GoalInfo = GoalInfo0
    ;
        GoalExpr0 = shorthand(_),
        % These should have been expanded out by now.
        unexpected($module, $pred, "shorthand")
    ),
    (
        Changed = yes,
        % This is not actually necessary for the transformation used for
        % high-level data.
        goal_info_set_purity(purity_impure, GoalInfo, GoalInfoImpure),
        Goal = hlds_goal(GoalExpr, GoalInfoImpure)
    ;
        Changed = no,
        Goal = Goal0
    ).

:- pred lco_transform_variant_conj(module_info::in, variant_map::in,
    var_to_target::in, instmap::in, list(hlds_goal)::in, list(hlds_goal)::out,
    bool::out, proc_info::in, proc_info::out) is det.

lco_transform_variant_conj(_, _, _, _, [], [], no, !ProcInfo).
lco_transform_variant_conj(ModuleInfo, VariantMap, VarToAddr, InstMap0,
        [Goal0 | Goals0], Conj, Changed, !ProcInfo) :-
    lco_transform_variant_goal(ModuleInfo, VariantMap, VarToAddr, InstMap0,
        Goal0, Goal, HeadChanged, !ProcInfo),
    update_instmap(Goal0, InstMap0, InstMap1),
    lco_transform_variant_conj(ModuleInfo, VariantMap, VarToAddr, InstMap1,
        Goals0, Goals, TailChanged, !ProcInfo),
    Changed = bool.or(HeadChanged, TailChanged),
    ( Goal = hlds_goal(conj(plain_conj, SubConj), _) ->
        Conj = SubConj ++ Goals
    ;
        Conj = [Goal | Goals]
    ).

:- pred lco_transform_variant_case(module_info::in, variant_map::in,
    var_to_target::in, instmap::in, case::in, case::out, bool::out,
    proc_info::in, proc_info::out) is det.

lco_transform_variant_case(ModuleInfo, VariantMap, VarToAddr, InstMap0,
        Case0, Case, Changed, !ProcInfo) :-
    Case0 = case(MainConsId, OtherConsIds, Goal0),
    lco_transform_variant_goal(ModuleInfo, VariantMap, VarToAddr, InstMap0,
        Goal0, Goal, Changed, !ProcInfo),
    Case = case(MainConsId, OtherConsIds, Goal).

:- pred lco_transform_variant_atomic_goal(module_info::in,
    var_to_target::in, instmap::in, hlds_goal_info::in,
    hlds_goal_expr::in, hlds_goal_expr::out, bool::out,
    proc_info::in, proc_info::out) is det.

lco_transform_variant_atomic_goal(ModuleInfo, VarToAddr, InstMap0,
        GoalInfo, GoalExpr0, GoalExpr, Changed, !ProcInfo) :-
    update_instmap(hlds_goal(GoalExpr0, GoalInfo), InstMap0, InstMap1),
    list.filter(is_grounding(ModuleInfo, InstMap0, InstMap1), VarToAddr,
        GroundingVarToAddr),
    (
        GroundingVarToAddr = [],
        GoalExpr = GoalExpr0,
        Changed = no
    ;
        GroundingVarToAddr = [_ | _],
        list.map_foldl(make_store_goal(ModuleInfo, InstMap1),
            GroundingVarToAddr, StoreGoals, !ProcInfo),
        GoalExpr = conj(plain_conj,
            [hlds_goal(GoalExpr0, GoalInfo) | StoreGoals]),
        Changed = yes
    ).

:- pred lco_transform_variant_plain_call(module_info::in, variant_map::in,
    var_to_target::in, instmap::in,
    hlds_goal_expr::in(plain_call_expr), hlds_goal_expr::out,
    hlds_goal_info::in, hlds_goal_info::out, bool::out,
    proc_info::in, proc_info::out) is det.

lco_transform_variant_plain_call(ModuleInfo, VariantMap, VarToAddr, InstMap0,
        GoalExpr0, GoalExpr, GoalInfo0, GoalInfo, Changed, !ProcInfo) :-
    update_instmap(hlds_goal(GoalExpr0, GoalInfo0), InstMap0, InstMap1),
    list.filter(is_grounding(ModuleInfo, InstMap0, InstMap1), VarToAddr,
        GroundingVarToAddr),
    (
        GroundingVarToAddr = [],
        GoalExpr = GoalExpr0,
        GoalInfo = GoalInfo0,
        Changed = no
    ;
        GroundingVarToAddr = [_ | _],
        % Check if there is a variant of the called procedure where we can pass
        % an address variable in place of each variable that would be ground by
        % the call.
        GoalExpr0 = plain_call(CallPredId, CallProcId, Args, Builtin,
            UnifyContext, SymName),
        CallPredProcId = proc(CallPredId, CallProcId),
        module_info_proc_info(ModuleInfo, CallPredId, CallProcId,
            CalleeProcInfo),
        proc_info_get_vartypes(!.ProcInfo, VarTypes),
        proc_info_get_argmodes(CalleeProcInfo, CalleeArgModes),
        (
            multi_map.search(VariantMap, CallPredProcId, ExistingVariants),
            classify_proc_call_args(ModuleInfo, VarTypes, Args, CalleeArgModes,
                _InArgs, OutArgs, _UnusedArgs),
            grounding_to_variant_args(GroundingVarToAddr, 1, OutArgs, Subst,
                VariantArgs),
            match_existing_variant(ExistingVariants, VariantArgs,
                ExistingVariant)
        ->
            rename_var_list(need_not_rename, Subst, Args, CallArgs),
            get_variant_id_and_name(ExistingVariant, SymName,
                proc(VariantPredId, VariantProcId), VariantSymName),
            GoalExpr = plain_call(VariantPredId, VariantProcId, CallArgs,
                Builtin, UnifyContext, VariantSymName),

            module_info_get_globals(ModuleInfo, Globals),
            globals.lookup_bool_option(Globals, highlevel_data, HighLevelData),
            (
                HighLevelData = no,
                GoalInfo = GoalInfo0
            ;
                HighLevelData = yes,
                % The partially instantiated cells will be ground after the
                % call.
                list.map(pair.fst, GroundingVarToAddr, GroundVars),
                map.apply_to_list(GroundVars, Subst, AddrVars),
                InstMapDelta0 = goal_info_get_instmap_delta(GoalInfo0),
                instmap_delta_set_vars_same(ground_inst, AddrVars,
                    InstMapDelta0, InstMapDelta),
                goal_info_set_instmap_delta(InstMapDelta, GoalInfo0, GoalInfo)
            ),
            Changed = yes
        ;
            lco_transform_variant_atomic_goal(ModuleInfo, VarToAddr, InstMap0,
                GoalInfo0, GoalExpr0, GoalExpr, Changed, !ProcInfo),
            GoalInfo = GoalInfo0
        )
    ).

:- pred is_grounding(module_info::in, instmap::in, instmap::in,
    pair(prog_var, store_target)::in) is semidet.

is_grounding(ModuleInfo, InstMap0, InstMap, Var - _StoreTarget) :-
    instmap_lookup_var(InstMap0, Var, Inst0),
    not inst_is_ground(ModuleInfo, Inst0),
    instmap_is_reachable(InstMap),
    instmap_lookup_var(InstMap, Var, Inst),
    inst_is_ground(ModuleInfo, Inst).

:- pred grounding_to_variant_args(assoc_list(prog_var, store_target)::in,
    int::in, list(prog_var)::in, prog_var_renaming::out,
    list(variant_arg)::out) is det.

grounding_to_variant_args(GroundingVarToAddr, OutArgNum, OutArgs, Subst,
        VariantArgs) :-
    (
        OutArgs = [],
        Subst = map.init,
        VariantArgs = []
    ;
        OutArgs = [OutArg | OutArgsTail],
        grounding_to_variant_args(GroundingVarToAddr, OutArgNum + 1,
            OutArgsTail, Subst0, VariantArgsTail),
        ( assoc_list.search(GroundingVarToAddr, OutArg, StoreTarget) ->
            StoreTarget = store_target(StoreArg, MaybeFieldId),
            map.det_insert(OutArg, StoreArg, Subst0, Subst),
            VariantArg = variant_arg(OutArgNum, MaybeFieldId),
            VariantArgs = [VariantArg | VariantArgsTail]
        ;
            Subst = Subst0,
            VariantArgs = VariantArgsTail
        )
    ).

:- pred make_store_goal(module_info::in, instmap::in,
    pair(prog_var, store_target)::in, hlds_goal::out,
    proc_info::in, proc_info::out) is det.

make_store_goal(ModuleInfo, InstMap, GroundVar - StoreTarget, Goal,
        !ProcInfo) :-
    StoreTarget = store_target(AddrVar, MaybeFieldId),
    (
        % Low-level data.
        MaybeFieldId = no,
        generate_simple_call(mercury_private_builtin_module,
            "store_at_ref_impure",
            pf_predicate, only_mode, detism_det, purity_impure,
            [AddrVar, GroundVar],
            [], instmap_delta_bind_vars([]), ModuleInfo, term.context_init,
            Goal)
    ;
        % High-level data.
        MaybeFieldId = yes(field_id(AddrVarType, ConsId, ArgNum)),
        get_cons_id_arg_types(ModuleInfo, AddrVarType, ConsId, ArgTypes),
        make_unification_args(GroundVar, ArgNum, 1, ArgTypes,
            ArgVars, ArgModes, !ProcInfo),

        IsExistConstr = no,
        RHS = rhs_functor(ConsId, IsExistConstr, ArgVars),

        instmap_lookup_var(InstMap, AddrVar, AddrVarInst0),
        inst_expand(ModuleInfo, AddrVarInst0, AddrVarInst),
        UniMode = (AddrVarInst -> ground_inst) - (ground_inst -> ground_inst),

        Unification = deconstruct(AddrVar, ConsId, ArgVars, ArgModes,
            cannot_fail, cannot_cgc),
        UnifyContext = unify_context(umc_implicit("lcmc"), []),

        GoalExpr = unify(AddrVar, RHS, UniMode, Unification, UnifyContext),

        goal_info_init(GoalInfo0),
        goal_info_set_determinism(detism_det, GoalInfo0, GoalInfo1),
        goal_info_set_instmap_delta(instmap_delta_bind_var(AddrVar),
            GoalInfo1, GoalInfo),

        Goal = hlds_goal(GoalExpr, GoalInfo)
    ).

:- pred make_unification_args(prog_var::in, int::in, int::in,
    list(mer_type)::in, list(prog_var)::out, list(uni_mode)::out,
    proc_info::in, proc_info::out) is det.

make_unification_args(GroundVar, TargetArgNum, CurArgNum, ArgTypes,
        ArgVars, ArgModes, !ProcInfo) :-
    (
        ArgTypes = [],
        ArgVars = [],
        ArgModes = []
    ;
        ArgTypes = [ArgType | ArgTypesTail],
        make_unification_args(GroundVar, TargetArgNum, CurArgNum + 1,
            ArgTypesTail, ArgVarsTail, ArgModesTail, !ProcInfo),
        make_unification_arg(GroundVar, TargetArgNum, CurArgNum,
            ArgType, Var, UniMode, !ProcInfo),
        ArgVars = [Var | ArgVarsTail],
        ArgModes = [UniMode | ArgModesTail]
    ).

:- pred make_unification_arg(prog_var::in, int::in, int::in, mer_type::in,
    prog_var::out, uni_mode::out, proc_info::in, proc_info::out) is det.

make_unification_arg(GroundVar, TargetArgNum, CurArgNum, ArgType,
        Var, UniMode, !ProcInfo) :-
    ( CurArgNum = TargetArgNum ->
        Var = GroundVar,
        UniMode = ((free_inst - ground_inst) -> (ground_inst - ground_inst))
    ;
        % Bind other arguments to fresh variables.
        proc_info_create_var_from_type(ArgType, no, Var, !ProcInfo),
        UniMode = ((ground_inst - free_inst) -> (ground_inst - ground_inst))
    ).

%-----------------------------------------------------------------------------%
:- end_module lco.
%-----------------------------------------------------------------------------%
