mercury/compiler/ssdebug.m

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2007-2012 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.
%-----------------------------------------------------------------------------%
%
% Module: transform_hlds.ssdebug.m.
% Authors: oannet, wangp.
%
% The ssdebug module does a source-to-source tranformation on each procedure
% that allows the procedure to be debugged.
%
% The ssdebug transformation is disabled on standard library predicates,
% because it would introduce cyclic dependencies between ssdb.m and the
% standard library. Disabling the transformation on the standard library is
% also useful for maintaining decent performance.
%
% The transformation is divided into two passes.
%
% The first pass replaces calls to standard library predicates, and closure
% constructions referring to standard library predicates, by calls to and
% closures over proxy predicates. The proxy predicates generate events on
% behalf of the standard library predicates. There will be no events for
% further calls within the standard library, but that is better for
% performance.
%
% The first pass also inserts calls to a context update procedure before every
% procedure call (first or higher order). This will update global variables
% with the location of the next call site, which will be used by the CALL event
% handler. Context update calls are not required within proxy predicates.
%
% The second pass performs the main ssdebug transformation, adding calls to
% procedures to handle debugger events. The transformation depends on the
% determinism of the procedure.
%
% det/cc_multi:
%
%   The promise_equivalent_solutions is required if p is declared cc_nondet
%   but inferred cc_multi.
%
%   p(...) :-
%       promise_<original_purity> (
%           CallVarDescs = [ ... ],
%           Level = ...,
%           impure handle_event_call(ProcId, CallVarDescs, Level),
%           promise_equivalent_solutions [ ... ] (
%               <original body>     % renaming outputs
%           ),
%           ExitVarDescs = [ ... | CallVarDescs ],
%           impure handle_event_exit(ProcId, ExitVarDescs, DoRetry),
%           (
%               DoRetry = do_retry,
%               p(...)
%           ;
%               DoRetry = do_not_retry,
%               % bind outputs
%           )
%       ).
%
% semidet/cc_nondet:
%
%   The promise_equivalent_solutions is required only if p is declared
%   cc_nondet.
%
%   p(...) :-
%       promise_<original_purity> (
%           CallVarDescs = [ ... ],
%           Level = ...,
%           impure handle_event_call(ProcId, CallVarDescs, Level),
%           ( if
%               promise_equivalent_solutions [...] (
%                   <original body>     % renaming outputs
%               )
%           then
%               ExitVarDescs = [ ... | CallVarDescs ],
%               impure handle_event_exit(ProcId, ExitVarDescs, DoRetryA),
%               (
%                   DoRetryA = do_retry,
%                   p(...)
%               ;
%                   DoRetryA = do_not_retry,
%                   % bind outputs
%               )
%           else
%               impure handle_event_fail(ProcId, CallVarDescs, DoRetryB),
%               (
%                   DoRetryB = do_retry,
%                   p(...)
%               ;
%                   DoRetryB = do_not_retry,
%                   fail
%               )
%           )
%       ).
%
% nondet:
%
%   p(...) :-
%       promise_<original_purity> (
%           (
%               CallVarDescs = [ ... ],
%               Level = ...,
%               impure handle_event_call_nondet(ProcId, CallVarDescs, Level),
%               <original body>,
%               ExitVarDescs = [ ... | CallVarDescs ],
%               (
%                   impure handle_event_exit_nondet(ProcId, ExitVarDescs)
%                   % Go to fail port if retry.
%               ;
%                   % preserve_backtrack_into,
%                   impure handle_event_redo_nondet(ProcId, ExitVarDescs),
%                   fail
%               )
%           ;
%               % preserve_backtrack_into
%               FailVarDescs = [ ... ],
%               impure handle_event_fail_nondet(ProcId, FailVarDescs, DoRetry),
%               (
%                   DoRetry = do_retry,
%                   p(...)
%               ;
%                   DoRetry = do_not_retry,
%                   fail
%               )
%           )
%       ).
%
% failure:
%
%   p(...) :-
%       promise_<original_purity> (
%           CallVarDescs = [ ... ],
%           Level = ...,
%           impure handle_event_call(ProcId, CallVarDescs, Level),
%           (
%               <original body>
%           ;
%               % preserve_backtrack_into
%               impure handle_event_fail(ProcId, CallVarDescs, DoRetry),
%               (
%                   DoRetry = do_retry,
%                   p(...)
%               ;
%                   DoRetry = do_not_retry,
%                   fail
%               )
%           )
%       ).
%
% erroneous:
%
%   p(...) :-
%       promise_<original_purity> (
%           CallVarDescs = [ ... ],
%           Level = ...,
%           impure handle_event_call(ProcId, CallVarDescs, Level),
%           <original body>
%       ).
%
% where CallVarDescs, ExitVarDescs are lists of var_value and Level
% is a ssdb.ssdb_tracel_level.
%
%    :- type var_value
%        --->    unbound_head_var(var_name, pos)           :: out      variable
%        ;       some [T] bound_head_var(var_name, pos, T) :: in       variable
%        ;       some [T] bound_other_var(var_name, T).    :: internal variable
%
%    :- type var_name == string.
%
%    :- type pos == int.
%
%    :- type ssdb_tracel_level
%       --->    shallow
%       ;       deep.
%
% Output head variables may appear twice in a variable description list --
% initially unbound, then overridden by a bound_head_var functor. Then the
% ExitVarDescs can add output variable bindings to the CallVarDescs list,
% instead of building new lists. The pos fields give the argument numbers
% of head variables.
%
% The ProcId is of type ssdb.ssdb_proc_id.
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%

:- module transform_hlds.ssdebug.
:- interface.

:- import_module hlds.
:- import_module hlds.hlds_module.
:- import_module libs.
:- import_module libs.globals.

:- inst shallow_or_deep for globals.ssdb_trace_level/0
    --->    ssdb_shallow
    ;       ssdb_deep.

:- pred ssdebug_transform_module(ssdb_trace_level::in(shallow_or_deep),
    module_info::in, module_info::out) is det.

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

:- implementation.

:- import_module check_hlds.
:- import_module check_hlds.polymorphism_type_info.
:- import_module check_hlds.purity.
:- import_module check_hlds.recompute_instmap_deltas.
:- import_module hlds.goal_util.
:- import_module hlds.hlds_goal.
:- import_module hlds.hlds_markers.
:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_proc_util.
:- import_module hlds.instmap.
:- import_module hlds.make_goal.
:- import_module hlds.mode_test.
:- import_module hlds.passes_aux.
:- import_module hlds.pred_name.
:- import_module hlds.pred_table.
:- import_module hlds.quantification.
:- import_module hlds.status.
:- import_module hlds.type_util.
:- import_module mdbcomp.
:- import_module mdbcomp.builtin_modules.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.
:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.file_names.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_detism.
:- import_module parse_tree.prog_rename.
:- import_module parse_tree.prog_type.
:- import_module parse_tree.prog_type_construct.
:- import_module parse_tree.var_table.

:- import_module int.
:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module require.
:- import_module term_context.

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

ssdebug_transform_module(SSTraceLevel, !ModuleInfo) :-
    (
        SSTraceLevel = ssdb_shallow,
        % With the shallow trace level, the parent of a library procedure
        % will also be have trace level shallow, thus we don't need to proxy
        % the library methods.
        process_valid_nonimported_procs(
            update_module(ssdebug_process_proc_if_needed(SSTraceLevel)),
            !ModuleInfo)
    ;
        SSTraceLevel = ssdb_deep,
        ssdebug_first_pass(!ModuleInfo),
        process_valid_nonimported_procs(
            update_module(ssdebug_process_proc_if_needed(SSTraceLevel)),
            !ModuleInfo)
    ).

%-----------------------------------------------------------------------------%
%
% Create proxies for standard library predicates and insert context updates.
%

:- type proxy_map == map(pred_id, maybe(pred_id)).

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

ssdebug_first_pass(!ModuleInfo) :-
    module_info_get_valid_pred_ids(!.ModuleInfo, PredIds),
    list.foldl2(ssdebug_first_pass_in_pred, PredIds,
        map.init, _ProxyMap, !ModuleInfo).

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

ssdebug_first_pass_in_pred(PredId, !ProxyMap, !ModuleInfo) :-
    module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
    ProcIds = pred_info_all_non_imported_procids(PredInfo),
    list.foldl2(ssdebug_first_pass_in_proc(PredId), ProcIds,
        !ProxyMap, !ModuleInfo).

:- pred ssdebug_first_pass_in_proc(pred_id::in, proc_id::in,
    proxy_map::in, proxy_map::out, module_info::in, module_info::out) is det.

ssdebug_first_pass_in_proc(PredId, ProcId, !ProxyMap, !ModuleInfo) :-
    some [!ProcInfo] (
        module_info_pred_proc_info(!.ModuleInfo, PredId, ProcId, PredInfo,
            !:ProcInfo),
        proc_info_get_var_table(!.ProcInfo, VarTable0),
        proc_info_get_goal(!.ProcInfo, Goal0),
        ssdebug_first_pass_in_goal(Goal0, Goal, VarTable0, VarTable,
            !ProxyMap, !ModuleInfo),
        proc_info_set_var_table(VarTable, !ProcInfo),
        proc_info_set_goal(Goal, !ProcInfo),
        module_info_set_pred_proc_info(PredId, ProcId, PredInfo, !.ProcInfo,
            !ModuleInfo)
    ).

:- pred ssdebug_first_pass_in_goal(hlds_goal::in, hlds_goal::out,
    var_table::in, var_table::out, proxy_map::in, proxy_map::out,
    module_info::in, module_info::out) is det.

ssdebug_first_pass_in_goal(!Goal, !VarTable, !ProxyMap, !ModuleInfo) :-
    !.Goal = hlds_goal(GoalExpr0, GoalInfo0),
    (
        GoalExpr0 = unify(_, _, _, Unification0, _),
        ( if
            Unification0 = construct(_, ConsId0, _, _, _, _, _),
            ConsId0 = closure_cons(ShroudedPredProcId)
        then
            PredProcId = unshroud_pred_proc_id(ShroudedPredProcId),
            PredProcId = proc(PredId, ProcId),
            lookup_proxy_pred(PredId, MaybeNewPredId, !ProxyMap, !ModuleInfo),
            (
                MaybeNewPredId = yes(NewPredId),
                NewPredProcId = proc(NewPredId, ProcId),
                NewShroundPredProcId = shroud_pred_proc_id(NewPredProcId),
                ConsId = closure_cons(NewShroundPredProcId),
                Unification = Unification0 ^ construct_cons_id := ConsId,
                GoalExpr = GoalExpr0 ^ unify_kind := Unification,
                !:Goal = hlds_goal(GoalExpr, GoalInfo0)
            ;
                MaybeNewPredId = no
            )
        else
            true
        )
    ;
        GoalExpr0 = plain_call(PredId, ProcId, Args, Builtin, Context,
            _SymName),
        (
            Builtin = not_builtin,
            lookup_proxy_pred(PredId, MaybeNewPredId, !ProxyMap, !ModuleInfo),
            (
                MaybeNewPredId = yes(NewPredId),
                module_info_pred_info(!.ModuleInfo, NewPredId, NewPredInfo),
                NewModuleName = pred_info_module(NewPredInfo),
                NewPredName = pred_info_name(NewPredInfo),
                NewSymName = qualified(NewModuleName, NewPredName),
                GoalExpr = plain_call(NewPredId, ProcId, Args, Builtin,
                    Context, NewSymName),
                !:Goal = hlds_goal(GoalExpr, GoalInfo0)
            ;
                MaybeNewPredId = no
            ),
            insert_context_update_call(!.ModuleInfo, !Goal, !VarTable)
        ;
            Builtin = inline_builtin
        )
    ;
        GoalExpr0 = generic_call(_, _, _, _, _),
        insert_context_update_call(!.ModuleInfo, !Goal, !VarTable)
    ;
        GoalExpr0 = call_foreign_proc(_, _, _, _, _, _, _)
    ;
        GoalExpr0 = conj(ConjType, Goals0),
        list.map_foldl3(ssdebug_first_pass_in_goal, Goals0, Goals,
            !VarTable, !ProxyMap, !ModuleInfo),
        GoalExpr = conj(ConjType, Goals),
        !:Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = disj(Goals0),
        list.map_foldl3(ssdebug_first_pass_in_goal, Goals0, Goals,
            !VarTable, !ProxyMap, !ModuleInfo),
        GoalExpr = disj(Goals),
        !:Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = switch(Var, CanFail, Cases0),
        list.map_foldl3(ssdebug_first_pass_in_case, Cases0, Cases,
            !VarTable, !ProxyMap, !ModuleInfo),
        GoalExpr = switch(Var, CanFail, Cases),
        !:Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = negation(SubGoal0),
        ssdebug_first_pass_in_goal(SubGoal0, SubGoal,
            !VarTable, !ProxyMap, !ModuleInfo),
        GoalExpr = negation(SubGoal),
        !:Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = scope(Reason, SubGoal0),
        ssdebug_first_pass_in_goal(SubGoal0, SubGoal,
            !VarTable, !ProxyMap, !ModuleInfo),
        GoalExpr = scope(Reason, SubGoal),
        !:Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = if_then_else(Vars, Cond0, Then0, Else0),
        ssdebug_first_pass_in_goal(Cond0, Cond,
            !VarTable, !ProxyMap, !ModuleInfo),
        ssdebug_first_pass_in_goal(Then0, Then,
            !VarTable, !ProxyMap, !ModuleInfo),
        ssdebug_first_pass_in_goal(Else0, Else,
            !VarTable, !ProxyMap, !ModuleInfo),
        GoalExpr = if_then_else(Vars, Cond, Then, Else),
        !:Goal = hlds_goal(GoalExpr, GoalInfo0)
    ;
        GoalExpr0 = shorthand(_),
        % These should have been expanded out by now.
        unexpected($pred, "unexpected shorthand")
    ).

:- pred ssdebug_first_pass_in_case(case::in, case::out,
    var_table::in, var_table::out, proxy_map::in, proxy_map::out,
    module_info::in, module_info::out) is det.

ssdebug_first_pass_in_case(Case0, Case, !VarTable, !ProxyMap, !ModuleInfo) :-
    Case0 = case(MainConsId, OtherConsIds, Goal0),
    ssdebug_first_pass_in_goal(Goal0, Goal, !VarTable, !ProxyMap, !ModuleInfo),
    Case = case(MainConsId, OtherConsIds, Goal).

    % Look up the proxy for a predicate, creating one if appropriate.
    %
:- pred lookup_proxy_pred(pred_id::in, maybe(pred_id)::out,
    proxy_map::in, proxy_map::out, module_info::in, module_info::out) is det.

lookup_proxy_pred(PredId, MaybeNewPredId, !ProxyMap, !ModuleInfo) :-
    ( if map.search(!.ProxyMap, PredId, MaybeNewPredId0) then
        MaybeNewPredId = MaybeNewPredId0
    else
        module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
        PredModule = pred_info_module(PredInfo),
        ( if mercury_std_library_module_name(PredModule) then
            create_proxy_pred(PredId, PredInfo, NewPredId, !ModuleInfo),
            MaybeNewPredId = yes(NewPredId)
        else
            MaybeNewPredId = no
        ),
        map.det_insert(PredId, MaybeNewPredId, !ProxyMap)
    ).

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

create_proxy_pred(PredId, !.PredInfo, NewPredId, !ModuleInfo) :-
    pred_info_set_status(pred_status(status_local), !PredInfo),

    ProcIds = pred_info_all_procids(!.PredInfo),
    list.foldl2(create_proxy_proc(PredId), ProcIds, !PredInfo,
        !ModuleInfo),

    % The proxy is defined in this module, even if the original is not.
    module_info_get_name(!.ModuleInfo, ModuleName),
    pred_info_set_module_name(ModuleName, !PredInfo),
    % Change the name, so that the proxy is not confused with the original.
    Name = pred_info_name(!.PredInfo),
    PredOrFunc = pred_info_is_pred_or_func(!.PredInfo),
    Transform = tn_ssdb_stdlib_proxy(PredOrFunc),
    make_transformed_pred_name(Name, Transform, ProxyName),
    pred_info_set_name(ProxyName, !PredInfo),

    % Set the predicate origin so that the later pass can find the name of
    % the original predicate.
    pred_info_get_origin(!.PredInfo, Origin),
    NewOrigin = origin_pred_transform(pred_transform_ssdebug(PredOrFunc),
        Origin, PredId),
    pred_info_set_origin(NewOrigin, !PredInfo),

    module_info_get_predicate_table(!.ModuleInfo, PredTable0),
    predicate_table_insert(!.PredInfo, NewPredId, PredTable0, PredTable),
    module_info_set_predicate_table(PredTable, !ModuleInfo).

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

create_proxy_proc(PredId, ProcId, !PredInfo, !ModuleInfo) :-
    some [!ProcInfo] (
        % The proxy just has to call the original procedure.
        pred_info_proc_info(!.PredInfo, ProcId, !:ProcInfo),
        proc_info_get_headvars(!.ProcInfo, Args),
        pred_info_get_sym_name(!.PredInfo, SymName),
        CallExpr = plain_call(PredId, ProcId, Args, not_builtin, no, SymName),
        proc_info_get_goal(!.ProcInfo, hlds_goal(_, GoalInfo0)),
        proc_info_interface_determinism(!.ProcInfo, Detism),
        goal_info_set_determinism(Detism, GoalInfo0, GoalInfo),
        Goal = hlds_goal(CallExpr, GoalInfo),
        proc_info_set_goal(Goal, !ProcInfo),
        requantify_proc_general(ord_nl_no_lambda, !ProcInfo),
        recompute_instmap_delta_proc(recomp_atomics, !ProcInfo, !ModuleInfo),
        pred_info_set_proc_info(ProcId, !.ProcInfo, !PredInfo)
    ).

:- pred insert_context_update_call(module_info::in,
    hlds_goal::in, hlds_goal::out, var_table::in, var_table::out) is det.

insert_context_update_call(ModuleInfo, Goal0, Goal, !VarTable) :-
    Goal0 = hlds_goal(_, GoalInfo),
    Context = goal_info_get_context(GoalInfo),
    Context = context(FileName, LineNumber),

    make_string_const_construction_alloc(FileName, "FileName",
        MakeFileName, FileNameVar, !VarTable),
    make_int_const_construction_alloc(LineNumber, "LineNumber",
        MakeLineNumber, LineNumberVar, !VarTable),

    ArgVars = [FileNameVar, LineNumberVar],
    Features = [],
    instmap_delta_init_reachable(InstMapDelta),
    generate_plain_call(ModuleInfo, pf_predicate,
        mercury_ssdb_builtin_module, "set_context",
        [], ArgVars, InstMapDelta, only_mode,
        detism_det, purity_impure, Features, Context, SetContextGoal),

    conj_list_to_goal([MakeFileName, MakeLineNumber, SetContextGoal, Goal0],
        GoalInfo, Goal).

%-----------------------------------------------------------------------------%
%
% The main transformation.
%

:- pred ssdebug_process_proc_if_needed(ssdb_trace_level::in,
    pred_proc_id::in, proc_info::in, proc_info::out,
    module_info::in, module_info::out) is det.

ssdebug_process_proc_if_needed(SSTraceLevel, PredProcId,
        !ProcInfo, !ModuleInfo) :-
    (
        SSTraceLevel = ssdb_none
    ;
        SSTraceLevel = ssdb_shallow,
        % Only transform the procedures in the interface.
        % XXX We still need to fix the ssdb so that events generated
        % below the shallow call event aren't seen.
        PredProcId = proc(PredId, _ProcId),
        module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
        ( if pred_info_is_exported(PredInfo) then
            ssdebug_process_proc(SSTraceLevel, PredProcId, PredInfo,
                !ProcInfo, !ModuleInfo)
        else
            true
        )
    ;
        SSTraceLevel = ssdb_deep,
        % Transfrom all procedures.
        PredProcId = proc(PredId, _ProcId),
        module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
        ssdebug_process_proc(SSTraceLevel, PredProcId, PredInfo,
            !ProcInfo, !ModuleInfo)
    ).

:- pred ssdebug_process_proc(ssdb_trace_level::in(shallow_or_deep),
    pred_proc_id::in, pred_info::in, proc_info::in, proc_info::out,
    module_info::in, module_info::out) is det.

ssdebug_process_proc(SSTraceLevel, PredProcId, PredInfo,
        !ProcInfo, !ModuleInfo) :-
    pred_info_get_arg_types(PredInfo, ArgTypes),
    proc_info_get_argmodes(!.ProcInfo, ArgModes),
    ( if all_args_fully_input_or_output(!.ModuleInfo, ArgTypes, ArgModes) then
        % We have different transformations for procedures of different
        % determinisms.

        % XXX It might be possible to factor out the common code in the four
        % ssdebug_process_proc_* predicates.

        proc_info_get_inferred_determinism(!.ProcInfo, Determinism),
        PredProcId = proc(PredId, ProcId),
        (
            ( Determinism = detism_det
            ; Determinism = detism_cc_multi
            ),
            ssdebug_process_proc_det(SSTraceLevel, PredId, ProcId,
                !ProcInfo, !ModuleInfo)
        ;
            ( Determinism = detism_semi
            ; Determinism = detism_cc_non
            ),
            ssdebug_process_proc_semi(SSTraceLevel, PredId, ProcId,
                !ProcInfo, !ModuleInfo)
        ;
            ( Determinism = detism_multi
            ; Determinism = detism_non
            ),
            ssdebug_process_proc_nondet(SSTraceLevel, PredId, ProcId,
                !ProcInfo, !ModuleInfo)
        ;
            Determinism = detism_erroneous,
            ssdebug_process_proc_erroneous(SSTraceLevel, PredId, ProcId,
                !ProcInfo, !ModuleInfo)
        ;
            Determinism = detism_failure,
            ssdebug_process_proc_failure(SSTraceLevel, PredId, ProcId,
                !ProcInfo, !ModuleInfo)
        )
    else
        % In the case of a mode which is not fully input or output,
        % we don't transform the procedure, since we don't know how.
        true
    ).

    % Source-to-source transformation for a deterministic goal.
    %
:- pred ssdebug_process_proc_det(ssdb_trace_level::in(shallow_or_deep),
    pred_id::in, proc_id::in, proc_info::in, proc_info::out,
    module_info::in, module_info::out) is det.

ssdebug_process_proc_det(SSTraceLevel, PredId, ProcId,
        !ProcInfo, !ModuleInfo) :-
    some [!PredInfo, !VarTable] (
        module_info_pred_info(!.ModuleInfo, PredId, !:PredInfo),
        proc_info_get_goal(!.ProcInfo, OrigBodyGoal),
        proc_info_get_var_table(!.ProcInfo, !:VarTable),
        get_stripped_headvars(!.PredInfo, !.ProcInfo, FullHeadVars, HeadVars,
            ArgModes),

        % Make the ssdb_proc_id.
        make_proc_id_construction(!.ModuleInfo, !.PredInfo, ProcIdGoals,
            ProcIdVar, !VarTable),

        % Make a list which records the value for each of the head
        % variables at the call port.
        proc_info_get_initial_instmap(!.ModuleInfo, !.ProcInfo, InitInstMap),
        make_arg_list(0, InitInstMap, HeadVars, map.init, CallArgListVar,
            CallArgListGoals, !ModuleInfo, !ProcInfo, !PredInfo, !VarTable,
            map.init, BoundVarDescsAtCall),

        % Set the ssdb_tracing_level.
        make_level_construction(SSTraceLevel, ConstructLevelGoal, LevelVar,
            !VarTable),

        % Generate the call to handle_event_call(ProcId, VarList).
        make_handle_event(!.ModuleInfo, "handle_event_call",
            [ProcIdVar, CallArgListVar, LevelVar], HandleEventCallGoal),

        % In the case of a retry, the output variables will be bound by the
        % retried call.
        get_output_args(!.ModuleInfo, HeadVars, ArgModes, OutputVars),
        rename_outputs(OutputVars, OrigBodyGoal, RenamedBodyGoal,
            AssignOutputsGoal, Renaming, !VarTable),

        % If the procedure (which we call recursively on retry) is declared
        % cc_nondet but inferred cc_multi, then we must put the original body
        % in a single solution context.
        proc_info_interface_determinism(!.ProcInfo, ProcDetism),
        determinism_components(ProcDetism, CanFail, _Solns),
        (
            CanFail = can_fail,
            map.apply_to_list(OutputVars, Renaming, RenamedOutputVars),
            add_promise_equivalent_solutions(RenamedOutputVars,
                RenamedBodyGoal, ScopedRenamedBodyGoal)
        ;
            CanFail = cannot_fail,
            ScopedRenamedBodyGoal = RenamedBodyGoal
        ),

        % Make the variable list at the exit port. It's currently a
        % completely new list instead of adding on to the list generated
        % for the call port.
        apply_goal_instmap_delta(OrigBodyGoal, InitInstMap, FinalInstMap),
        make_arg_list(0, FinalInstMap, HeadVars, Renaming, ExitArgListVar,
            ExitArgListGoals, !ModuleInfo, !ProcInfo, !PredInfo, !VarTable,
            BoundVarDescsAtCall, _BoundVarDescsAtExit),

        % Generate the call to handle_event_exit.
        make_retry_var("DoRetry", RetryVar, !VarTable),
        make_handle_event(!.ModuleInfo, "handle_event_exit",
            [ProcIdVar, ExitArgListVar, RetryVar], HandleEventExitGoal),

        % Generate the recursive call in the case of a retry.
        make_recursive_call(!.PredInfo, !.ModuleInfo, PredId, ProcId,
            FullHeadVars, RecursiveGoal),

        % Create the switch on Retry at exit port.
        make_switch_goal(RetryVar, RecursiveGoal, AssignOutputsGoal,
            SwitchGoal),

        % Put it all together.
        BodyGoals = list.condense([
            ProcIdGoals,
            CallArgListGoals,
            [ConstructLevelGoal],
            [HandleEventCallGoal],
            [ScopedRenamedBodyGoal],
            ExitArgListGoals,
            [HandleEventExitGoal],
            [SwitchGoal]
        ]),
        commit_goal_changes(BodyGoals, PredId, ProcId, !.PredInfo, !.VarTable,
            !ProcInfo, !ModuleInfo)
    ).

    % Source-to-source transformation for a semidet goal.
    %
:- pred ssdebug_process_proc_semi(ssdb_trace_level::in(shallow_or_deep),
    pred_id::in, proc_id::in, proc_info::in, proc_info::out,
    module_info::in, module_info::out) is det.

ssdebug_process_proc_semi(SSTraceLevel, PredId, ProcId,
        !ProcInfo, !ModuleInfo) :-
    some [!PredInfo, !VarTable] (
        module_info_pred_info(!.ModuleInfo, PredId, !:PredInfo),
        proc_info_get_goal(!.ProcInfo, OrigBodyGoal),
        proc_info_get_var_table(!.ProcInfo, !:VarTable),
        get_stripped_headvars(!.PredInfo, !.ProcInfo, FullHeadVars, HeadVars,
            ArgModes),

        % Make the ssdb_proc_id.
        make_proc_id_construction(!.ModuleInfo, !.PredInfo, ProcIdGoals,
            ProcIdVar, !VarTable),

        % Make a list which records the value for each of the head
        % variables at the call port.
        proc_info_get_initial_instmap(!.ModuleInfo, !.ProcInfo, InitInstMap),
        make_arg_list(0, InitInstMap, HeadVars, map.init, CallArgListVar,
            CallArgListGoals, !ModuleInfo, !ProcInfo, !PredInfo, !VarTable,
            map.init, BoundVarDescsAtCall),

        % Set the ssdb_tracing_level.
        make_level_construction(SSTraceLevel, ConstructLevelGoal, LevelVar,
            !VarTable),

        % Generate the call to handle_event_call.
        make_handle_event(!.ModuleInfo, "handle_event_call",
            [ProcIdVar, CallArgListVar, LevelVar], HandleEventCallGoal),

        % In the case of a retry, the output variables will be bound by the
        % retried call.
        get_output_args(!.ModuleInfo, HeadVars, ArgModes, OutputVars),
        rename_outputs(OutputVars, OrigBodyGoal, RenamedBodyGoal,
            AssignOutputsGoal, Renaming, !VarTable),

        % Make the variable list at the exit port. It's currently a
        % completely new list instead of adding on to the list generated
        % for the call port.
        apply_goal_instmap_delta(OrigBodyGoal, InitInstMap, FinalInstMap),
        make_arg_list(0, FinalInstMap, HeadVars, Renaming, ExitArgListVar,
            ExitArgListGoals, !ModuleInfo, !ProcInfo, !PredInfo, !VarTable,
            BoundVarDescsAtCall, _BoundVarDescsAtExit),

        % Generate the call to handle_event_exit.
        make_retry_var("DoRetryA", RetryAVar, !VarTable),
        make_handle_event(!.ModuleInfo, "handle_event_exit",
            [ProcIdVar, ExitArgListVar, RetryAVar], HandleEventExitGoal),

        % Generate the recursive call in the case of a retry.
        make_recursive_call(!.PredInfo, !.ModuleInfo, PredId, ProcId,
            FullHeadVars, RecursiveGoal),

        % Generate the list of arguments at the fail port.
        make_arg_list(0, InitInstMap, [], Renaming, FailArgListVar,
            FailArgListGoals, !ModuleInfo, !ProcInfo, !PredInfo, !VarTable,
            BoundVarDescsAtCall, _BoundVarDescsAtFail),

        % Generate the call to handle_event_fail.
        make_retry_var("DoRetryB", RetryBVar, !VarTable),
        make_handle_event(!.ModuleInfo, "handle_event_fail",
            [ProcIdVar, FailArgListVar, RetryBVar], HandleEventFailGoal),

        proc_info_interface_determinism(!.ProcInfo, ProcDetism),
        ImpureGoalInfo = impure_goal_info(ProcDetism),

        % The condition of the if-then-else is the original body with renamed
        % output variables. Introduce a promise_equivalent_solutions scope to
        % put it into a single solution context if the procedure (which we call
        % recursively later) was _declared_ to have more solutions.
        determinism_components(ProcDetism, _CanFail, Solns),
        (
            Solns = at_most_one,
            CondGoal = RenamedBodyGoal
        ;
            ( Solns = at_most_many_cc
            ; Solns = at_most_many
            ),
            map.apply_to_list(OutputVars, Renaming, RenamedOutputVars),
            add_promise_equivalent_solutions(RenamedOutputVars,
                RenamedBodyGoal, CondGoal)
        ;
            Solns = at_most_zero,
            unexpected($pred, "zero solutions")
        ),

        % Create the `then' branch.
        make_switch_goal(RetryAVar, RecursiveGoal, AssignOutputsGoal,
            SwitchExitPortGoal),
        GoalsThen = list.condense([
            ExitArgListGoals,
            [HandleEventExitGoal],
            [SwitchExitPortGoal]
        ]),
        ThenGoal = hlds_goal(conj(plain_conj, GoalsThen), ImpureGoalInfo),

        % Create the `else' branch.
        make_switch_goal(RetryBVar, RecursiveGoal, fail_goal,
            SwitchFailPortGoal),
        GoalsElse = list.condense([
            FailArgListGoals,
            [HandleEventFailGoal],
            [SwitchFailPortGoal]
        ]),
        ElseGoal = hlds_goal(conj(plain_conj, GoalsElse), ImpureGoalInfo),

        % Put it all together.
        OrigBodyGoal = hlds_goal(_, OrigGoalInfo),
        goal_info_set_determinism(ProcDetism, OrigGoalInfo, IteGoalInfo),
        IteGoal = hlds_goal(if_then_else([], CondGoal, ThenGoal, ElseGoal),
            IteGoalInfo),
        BodyGoals = list.condense([
            ProcIdGoals,
            CallArgListGoals,
            [ConstructLevelGoal],
            [HandleEventCallGoal],
            [IteGoal]
        ]),
        commit_goal_changes(BodyGoals, PredId, ProcId, !.PredInfo, !.VarTable,
            !ProcInfo, !ModuleInfo)
    ).

    % Source-to-source transformation for a nondeterministic procedure.
    %
:- pred ssdebug_process_proc_nondet(ssdb_trace_level::in(shallow_or_deep),
    pred_id::in, proc_id::in, proc_info::in, proc_info::out,
    module_info::in, module_info::out) is det.

ssdebug_process_proc_nondet(SSTraceLevel, PredId, ProcId,
        !ProcInfo, !ModuleInfo) :-
    some [!PredInfo, !VarTable] (
        module_info_pred_info(!.ModuleInfo, PredId, !:PredInfo),
        proc_info_get_goal(!.ProcInfo, OrigBodyGoal),
        proc_info_get_var_table(!.ProcInfo, !:VarTable),
        get_stripped_headvars(!.PredInfo, !.ProcInfo, FullHeadVars, HeadVars,
            _ArgModes),

        % Make the ssdb_proc_id.
        make_proc_id_construction(!.ModuleInfo, !.PredInfo, ProcIdGoals,
            ProcIdVar, !VarTable),

        % Make a list which records the value for each of the head
        % variables at the call port.
        proc_info_get_initial_instmap(!.ModuleInfo, !.ProcInfo, InitInstMap),
        make_arg_list(0, InitInstMap, HeadVars, map.init, CallArgListVar,
            CallArgListGoals, !ModuleInfo, !ProcInfo, !PredInfo, !VarTable,
            map.init, BoundVarDescsAtCall),

        % Set the ssdb_tracing_level.
        make_level_construction(SSTraceLevel, ConstructLevelGoal, LevelVar,
            !VarTable),

        % Generate the call to handle_event_call.
        make_handle_event(!.ModuleInfo, "handle_event_call_nondet",
            [ProcIdVar, CallArgListVar, LevelVar], HandleEventCallGoal),

        % Make the variable list at the exit port. It's currently a
        % completely new list instead of adding on to the list generated
        % for the call port.
        apply_goal_instmap_delta(OrigBodyGoal, InitInstMap, FinalInstMap),
        make_arg_list(0, FinalInstMap, HeadVars, map.init, ExitArgListVar,
            ExitArgListGoals, !ModuleInfo, !ProcInfo, !PredInfo, !VarTable,
            BoundVarDescsAtCall, _BoundVarDescsAtExit),

        proc_info_interface_determinism(!.ProcInfo, ProcDetism),

        % Create the disjunct that handles call, exit and redo ports.
        make_handle_event(!.ModuleInfo, "handle_event_exit_nondet",
            [ProcIdVar, ExitArgListVar], HandleEventExitGoal),
        ExitDisjunct = HandleEventExitGoal,

        make_handle_event(!.ModuleInfo, "handle_event_redo_nondet",
            [ProcIdVar, ExitArgListVar], HandleEventRedoGoal),
        RedoDisjunct = hlds_goal(conj(plain_conj,
            [HandleEventRedoGoal, fail_goal]),
            impure_backtrack_goal_info(detism_failure)),

        ExitOrRedoGoal = hlds_goal(disj([ExitDisjunct, RedoDisjunct]),
            impure_goal_info(detism_non)),
        CallExitRedoDisjunctGoals = list.condense([
            CallArgListGoals,
            [ConstructLevelGoal],
            [HandleEventCallGoal],
            [OrigBodyGoal],
            ExitArgListGoals,
            [ExitOrRedoGoal]
        ]),
        CallExitRedoDisjunct = hlds_goal(
            conj(plain_conj, CallExitRedoDisjunctGoals),
            impure_goal_info(ProcDetism)),

        % Create the disjunct that handles the fail port.
        FailArgListVar = CallArgListVar,
        FailArgListGoals = CallArgListGoals,
        make_retry_var("DoRetry", RetryVar, !VarTable),
        make_handle_event(!.ModuleInfo, "handle_event_fail_nondet",
            [ProcIdVar, FailArgListVar, RetryVar], HandleEventFailGoal),
        make_recursive_call(!.PredInfo, !.ModuleInfo, PredId, ProcId,
            FullHeadVars, RecursiveGoal),
        make_switch_goal(RetryVar, RecursiveGoal, fail_goal,
            SwitchFailPortGoal),
        FailDisjunctGoals = list.condense([
            FailArgListGoals,
            [HandleEventFailGoal],
            [SwitchFailPortGoal]
        ]),
        FailDisjunct = hlds_goal(conj(plain_conj, FailDisjunctGoals),
            impure_backtrack_goal_info(ProcDetism)),

        % Put it together.
        BodyDisj = hlds_goal(disj([CallExitRedoDisjunct, FailDisjunct]),
            impure_goal_info(ProcDetism)),
        BodyGoals = ProcIdGoals ++ [BodyDisj],
        commit_goal_changes(BodyGoals, PredId, ProcId, !.PredInfo, !.VarTable,
            !ProcInfo, !ModuleInfo)
    ).

    % Source-to-source transformation for a failure procedure.
    %
:- pred ssdebug_process_proc_failure(ssdb_trace_level::in(shallow_or_deep),
    pred_id::in, proc_id::in, proc_info::in, proc_info::out,
    module_info::in, module_info::out) is det.

ssdebug_process_proc_failure(SSTraceLevel, PredId, ProcId,
        !ProcInfo, !ModuleInfo) :-
    some [!PredInfo, !VarTable] (
        module_info_pred_info(!.ModuleInfo, PredId, !:PredInfo),
        proc_info_get_goal(!.ProcInfo, OrigBodyGoal),
        proc_info_get_var_table(!.ProcInfo, !:VarTable),
        get_stripped_headvars(!.PredInfo, !.ProcInfo, FullHeadVars, HeadVars,
            _ArgModes),

        % Make the ssdb_proc_id.
        make_proc_id_construction(!.ModuleInfo, !.PredInfo, ProcIdGoals,
            ProcIdVar, !VarTable),

        % Make a list which records the value for each of the head
        % variables at the call port.
        proc_info_get_initial_instmap(!.ModuleInfo, !.ProcInfo, InitInstMap),
        make_arg_list(0, InitInstMap, HeadVars, map.init, CallArgListVar,
            CallArgListGoals, !ModuleInfo, !ProcInfo, !PredInfo, !VarTable,
            map.init, _BoundVarDescsAtCall),

        % Set the ssdb_tracing_level.
        make_level_construction(SSTraceLevel, ConstructLevelGoal, LevelVar,
            !VarTable),

        % Generate the call to handle_event_call.
        make_handle_event(!.ModuleInfo, "handle_event_call",
            [ProcIdVar, CallArgListVar, LevelVar], HandleEventCallGoal),

        % Generate the call to handle_event_fail.
        FailArgListVar = CallArgListVar,
        make_retry_var("DoRetry", RetryVar, !VarTable),
        make_handle_event(!.ModuleInfo, "handle_event_fail",
            [ProcIdVar, FailArgListVar, RetryVar], HandleEventFailGoal),

        % Generate the recursive call in the case of a retry.
        make_recursive_call(!.PredInfo, !.ModuleInfo, PredId, ProcId,
            FullHeadVars, RecursiveGoal),

        % Create the switch on Retry at fail port.
        make_switch_goal(RetryVar, RecursiveGoal, fail_goal, SwitchGoal),

        % Put it all together.
        proc_info_interface_determinism(!.ProcInfo, ProcDetism),
        FailDisjunct = hlds_goal(
            conj(plain_conj, [HandleEventFailGoal, SwitchGoal]),
            impure_backtrack_goal_info(ProcDetism)),
        DisjGoal = hlds_goal(disj([OrigBodyGoal, FailDisjunct]),
            impure_goal_info(ProcDetism)),
        BodyGoals = list.condense([
            ProcIdGoals,
            CallArgListGoals,
            [ConstructLevelGoal],
            [HandleEventCallGoal],
            [DisjGoal]
        ]),
        commit_goal_changes(BodyGoals, PredId, ProcId, !.PredInfo, !.VarTable,
            !ProcInfo, !ModuleInfo)
    ).

    % Source-to-source transformation for an erroneous procedure.
    %
:- pred ssdebug_process_proc_erroneous(ssdb_trace_level::in(shallow_or_deep),
    pred_id::in, proc_id::in, proc_info::in, proc_info::out,
    module_info::in, module_info::out) is det.

ssdebug_process_proc_erroneous(SSTraceLevel, PredId, ProcId,
        !ProcInfo, !ModuleInfo) :-
    some [!PredInfo, !VarTable] (
        module_info_pred_info(!.ModuleInfo, PredId, !:PredInfo),
        proc_info_get_goal(!.ProcInfo, OrigBodyGoal),
        proc_info_get_var_table(!.ProcInfo, !:VarTable),
        get_stripped_headvars(!.PredInfo, !.ProcInfo, _FullHeadVars, HeadVars,
            _ArgModes),

        % Make the ssdb_proc_id.
        make_proc_id_construction(!.ModuleInfo, !.PredInfo, ProcIdGoals,
            ProcIdVar, !VarTable),

        % Make a list which records the value for each of the head
        % variables at the call port.
        proc_info_get_initial_instmap(!.ModuleInfo, !.ProcInfo, InitInstMap),
        make_arg_list(0, InitInstMap, HeadVars, map.init, CallArgListVar,
            CallArgListGoals, !ModuleInfo, !ProcInfo, !PredInfo, !VarTable,
            map.init, _BoundVarDescsAtCall),

        % Set the ssdb_tracing_level.
        make_level_construction(SSTraceLevel, ConstructLevelGoal, LevelVar,
            !VarTable),

        % Generate the call to handle_event_call(ProcId, VarList).
        make_handle_event(!.ModuleInfo, "handle_event_call",
            [ProcIdVar, CallArgListVar, LevelVar], HandleEventCallGoal),

        % Put it all together.
        BodyGoals = list.condense([
            ProcIdGoals,
            CallArgListGoals,
            [ConstructLevelGoal],
            [HandleEventCallGoal],
            [OrigBodyGoal]
        ]),
        commit_goal_changes(BodyGoals, PredId, ProcId, !.PredInfo, !.VarTable,
            !ProcInfo, !ModuleInfo)
    ).

:- pred get_stripped_headvars(pred_info::in, proc_info::in,
    list(prog_var)::out, list(prog_var)::out, list(mer_mode)::out) is det.

get_stripped_headvars(PredInfo, ProcInfo, FullHeadVars, HeadVars, ArgModes) :-
    % XXX using orig_arity here does not work when the predicate is one
    % produced by higher-order specialization. See tests/valid/gh89.m.
    pred_info_get_orig_arity(PredInfo, PredFormArity),
    proc_info_get_headvars(ProcInfo, FullHeadVars),
    proc_info_get_argmodes(ProcInfo, FullArgModes),
    NumExtraArgs = num_extra_args(PredFormArity, FullHeadVars),
    % Strip off the extra type_info arguments inserted at the front by
    % polymorphism.m.
    list.det_drop(NumExtraArgs, FullHeadVars, HeadVars),
    list.det_drop(NumExtraArgs, FullArgModes, ArgModes).

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

get_output_args(ModuleInfo, HeadVars, ArgModes, OutputVars) :-
    F = (func(Var, Mode) = Var is semidet :-
        mode_is_output(ModuleInfo, Mode)
    ),
    OutputVars = list.filter_map_corresponding(F, HeadVars, ArgModes).

:- pred rename_outputs(list(prog_var)::in, hlds_goal::in, hlds_goal::out,
    hlds_goal::out, prog_var_renaming::out,
    var_table::in, var_table::out) is det.

rename_outputs(OutputVars, !Goal, UnifyGoal, Renaming, !VarTable) :-
    GoalInfo0 = get_hlds_goal_info(!.Goal),
    InstMapDelta = goal_info_get_instmap_delta(GoalInfo0),
    create_renaming(OutputVars, InstMapDelta, !VarTable,
        UnifyGoals, _NewVars, Renaming),
    goal_info_init(UnifyGoalInfo0),
    goal_info_set_determinism(detism_det, UnifyGoalInfo0, UnifyGoalInfo),
    conj_list_to_goal(UnifyGoals, UnifyGoalInfo, UnifyGoal),
    rename_some_vars_in_goal(Renaming, !Goal).

:- pred add_promise_equivalent_solutions(list(prog_var)::in,
    hlds_goal::in, hlds_goal::out) is det.

add_promise_equivalent_solutions(OutputVars, Goal0, Goal) :-
    Goal0 = hlds_goal(_, GoalInfo),
    Reason = promise_solutions(OutputVars, equivalent_solutions),
    Goal = hlds_goal(scope(Reason, Goal0), GoalInfo).

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

    % Create the output variable DoRetry.
    %
:- pred make_retry_var(string::in, prog_var::out,
    var_table::in, var_table::out) is det.

make_retry_var(VarName, RetryVar, !VarTable) :-
    SSDBModule = mercury_ssdb_builtin_module,
    TypeCtor = type_ctor(qualified(SSDBModule, "ssdb_retry"), 0),
    construct_type(TypeCtor, [], RetryType),
    RetryVarEntry = vte(VarName, RetryType, is_not_dummy_type),
    add_var_entry(RetryVarEntry, RetryVar, !VarTable).

    % Create the goal for recursive call in the case of a retry.
    %
:- pred make_recursive_call(pred_info::in, module_info::in, pred_id::in,
    proc_id::in, list(prog_var)::in, hlds_goal::out) is det.

make_recursive_call(PredInfo, ModuleInfo, PredId, ProcId, HeadVars, Goal) :-
    PredName = pred_info_name(PredInfo),
    ModuleName = pred_info_module(PredInfo),
    SymName = qualified(ModuleName, PredName),
    BuiltIn = builtin_state(ModuleInfo, PredId, PredId, ProcId),
    GoalExpr = plain_call(PredId, ProcId, HeadVars, BuiltIn, no, SymName),

    % We use the goal info of the top level goal in the proc info
    % as this goal is the equivalent of what the recursive call
    % is doing, ie binding the head vars.
    pred_info_proc_info(PredInfo, ProcId, ProcInfo),
    proc_info_get_goal(ProcInfo, BodyGoal0),
    GoalInfoHG0 = get_hlds_goal_info(BodyGoal0),

    proc_info_interface_determinism(ProcInfo, Determinism),
    goal_info_set_determinism(Determinism, GoalInfoHG0, GoalInfoHG),

    Goal = hlds_goal(GoalExpr, GoalInfoHG).

    % make_switch_goal(SwitchVar, RecursiveGoal, FailGoal, Goal).
    %
    % Create an output Goal, which is a switch with following pattern :
    %   (
    %       SwitchVar = do_retry,
    %       SwitchCase1
    %   ;
    %       SwitchVar = do_not_retry,
    %       SwitchCase2
    %   )
    %
:- pred make_switch_goal(prog_var::in, hlds_goal::in, hlds_goal::in,
    hlds_goal::out) is det.

make_switch_goal(SwitchVar, DoRetryGoal, DoNotRetryGoal, SwitchGoal) :-
    SSDBModule = mercury_ssdb_builtin_module,
    RetryTypeSymName = qualified(SSDBModule, "ssdb_retry"),
    RetryTypeCtor = type_ctor(RetryTypeSymName, 0),
    ConsIdDoRetry =
        du_data_ctor(du_ctor(qualified(SSDBModule, "do_retry"),
            0, RetryTypeCtor)),
    ConsIdDoNotRetry =
        du_data_ctor(du_ctor(qualified(SSDBModule, "do_not_retry"),
            0, RetryTypeCtor)),
    CaseDoRetry = case(ConsIdDoRetry, [], DoRetryGoal),
    CaseDoNotRetry = case(ConsIdDoNotRetry, [], DoNotRetryGoal),
    SwitchGoalExpr = switch(SwitchVar, cannot_fail,
        [CaseDoRetry, CaseDoNotRetry]),

    RetryGoalInfo = get_hlds_goal_info(DoRetryGoal),
    NoRetryGoalInfo = get_hlds_goal_info(DoNotRetryGoal),
    RetryDetism = goal_info_get_determinism(RetryGoalInfo),
    NoRetryDetism = goal_info_get_determinism(NoRetryGoalInfo),

    det_switch_detism(RetryDetism, NoRetryDetism, SwitchDetism),

    goal_info_init(GoalInfo0),
    goal_info_set_determinism(SwitchDetism, GoalInfo0, GoalInfo1),
    goal_info_set_purity(purity_impure, GoalInfo1, GoalInfo),

    SwitchGoal = hlds_goal(SwitchGoalExpr, GoalInfo).

    % Update the proc_info and pred_info with the result of the
    % source-to-source transformation.
    %
:- pred commit_goal_changes(list(hlds_goal)::in, pred_id::in, proc_id::in,
    pred_info::in, var_table::in, proc_info::in, proc_info::out,
    module_info::in, module_info::out) is det.

commit_goal_changes(ConjGoals, PredId, ProcId, !.PredInfo, VarTable,
        !ProcInfo, !ModuleInfo) :-
    goal_list_determinism(ConjGoals, ConjDetism),
    ConjGoalInfo = impure_goal_info(ConjDetism),
    Conj = hlds_goal(conj(plain_conj, ConjGoals), ConjGoalInfo),

    proc_info_get_goal(!.ProcInfo, hlds_goal(_, OrigGoalInfo)),
    proc_info_interface_determinism(!.ProcInfo, ProcDetism),
    % This is needed due to the determinism of the recursive call.
    goal_info_set_determinism(ProcDetism, OrigGoalInfo, ScopeGoalInfo),
    Purity = goal_info_get_purity(OrigGoalInfo),
    Goal = hlds_goal(scope(promise_purity(Purity), Conj), ScopeGoalInfo),

    proc_info_set_var_table(VarTable, !ProcInfo),
    proc_info_set_goal(Goal, !ProcInfo),
    requantify_proc_general(ord_nl_no_lambda, !ProcInfo),
    recompute_instmap_delta_proc(recomp_atomics,
        !ProcInfo, !ModuleInfo),
    pred_info_set_proc_info(ProcId, !.ProcInfo, !PredInfo),
    repuritycheck_proc(!.ModuleInfo, proc(PredId, ProcId), !PredInfo),
    module_info_set_pred_info(PredId, !.PredInfo, !ModuleInfo).

:- func impure_goal_info(determinism) = hlds_goal_info.

impure_goal_info(Detism) = GoalInfo :-
    goal_info_init(GoalInfo0),
    goal_info_set_purity(purity_impure, GoalInfo0, GoalInfo1),
    goal_info_set_determinism(Detism, GoalInfo1, GoalInfo).

:- func impure_backtrack_goal_info(determinism) = hlds_goal_info.

impure_backtrack_goal_info(Detism) = GoalInfo :-
    GoalInfo0 = impure_goal_info(Detism),
    goal_info_add_feature(feature_preserve_backtrack_into,
        GoalInfo0, GoalInfo).

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

    % Build the following goal : handle_event_EVENT(ProcId, Arguments).
    % EVENT = call,exit,fail or redo
    % Argument = ProcId, ListHeadVars and eventually Retry
    %
:- pred make_handle_event(module_info::in, string::in, list(prog_var)::in,
    hlds_goal::out) is det.

make_handle_event(ModuleInfo, ProcName, ArgVars, HandleEventGoal) :-
    SSDBModule = mercury_ssdb_builtin_module,
    Features = [],
    Context = dummy_context,
    generate_plain_call(ModuleInfo, pf_predicate, SSDBModule, ProcName,
        [], ArgVars, instmap_delta_bind_no_var, only_mode, detism_det,
        purity_impure, Features, Context, HandleEventGoal).

    % make_proc_id_construction(ModuleInfo, PredInfo, Goals, Var, !VarTable)
    %
    % Returns a set of goals, Goals, which build the ssdb_proc_id structure
    % for the given pred and proc infos. The Var returned holds the
    % ssdb_proc_id.
    %
:- pred make_proc_id_construction(module_info::in, pred_info::in,
    list(hlds_goal)::out, prog_var::out, var_table::in, var_table::out) is det.

make_proc_id_construction(ModuleInfo, PredInfo, Goals, ProcIdVar, !VarTable) :-
    pred_info_get_origin(PredInfo, Origin),
    ( if
        Origin = origin_pred_transform(pred_transform_ssdebug(_),
            _, OrigPredId)
    then
        % This predicate is a proxy for a standard library predicate.
        module_info_pred_info(ModuleInfo, OrigPredId, OrigPredInfo)
    else
        OrigPredInfo = PredInfo
    ),
    SymModuleName = pred_info_module(OrigPredInfo),
    ModuleName = sym_name_to_string(SymModuleName),
    PredName = pred_info_name(OrigPredInfo),

    make_string_const_construction_alloc(ModuleName, "ModuleName",
        ConstructModuleName, ModuleNameVar, !VarTable),

    make_string_const_construction_alloc(PredName, "PredName",
        ConstructPredName, PredNameVar, !VarTable),

    SSDBModule = mercury_ssdb_builtin_module,
    TypeCtor = type_ctor(qualified(SSDBModule, "ssdb_proc_id"), 0),

    ConsId = du_data_ctor(du_ctor(qualified(SSDBModule, "ssdb_proc_id"),
        2, TypeCtor)),
    construct_type(TypeCtor, [], ProcIdType),
    ProcIdVarEntry = vte("ProcId", ProcIdType, is_not_dummy_type),
    add_var_entry(ProcIdVarEntry, ProcIdVar, !VarTable),
    construct_functor(ProcIdVar, ConsId, [ModuleNameVar, PredNameVar],
        ConstructProcIdGoal),

    Goals = [ConstructModuleName, ConstructPredName, ConstructProcIdGoal].

    % Construct the goal which sets the ssdb_tracing_level for
    % the current goal. ie Level = shallow
    %
:- pred make_level_construction(ssdb_trace_level::in(shallow_or_deep),
    hlds_goal::out, prog_var::out, var_table::in, var_table::out) is det.

make_level_construction(SSTraceLevel, Goal, LevelVar, !VarTable) :-
    (
        SSTraceLevel = ssdb_shallow,
        ConsId = shallow_cons_id
    ;
        SSTraceLevel = ssdb_deep,
        ConsId = deep_cons_id
    ),
    make_const_construction_alloc(ConsId, ssdb_tracing_level_type,
        is_not_dummy_type,"Level", Goal, LevelVar, !VarTable).

    % Succeed if all the given argument modes are fully input or fully output.
    % XXX At the moment, we don't handle arguments modes other than
    % fully input or fully output, so if a procedure has such modes,
    % we won't generate code for it.
    %
:- pred all_args_fully_input_or_output(module_info::in,
    list(mer_type)::in, list(mer_mode)::in) is semidet.

all_args_fully_input_or_output(_, [], []).
all_args_fully_input_or_output(_, [], [_ | _]) :-
    unexpected($pred, "list length mismatch").
all_args_fully_input_or_output(_, [_ | _], []) :-
    unexpected($pred, "list length mismatch").
all_args_fully_input_or_output(ModuleInfo, [Type | Types], [Mode | Modes]) :-
    ( mode_is_fully_input(ModuleInfo, Type, Mode)
    ; mode_is_fully_output(ModuleInfo, Type, Mode)
    ),
    all_args_fully_input_or_output(ModuleInfo, Types, Modes).

%-----------------------------------------------------------------------------%
%
% The following code concern predicates which create the list argument at
% event point.
%

    % make_arg_list(Pos, InstMap, Vars, RenamedVar, FullListVar, Goals,
    %   !ModuleInfo, !ProcInfo, !PredInfo, !VarTable, !BoundedVarDesc)
    %
    % Processes each variable in Vars creating a list(var_value) named
    % FullListVar which records the value of each of the variables. Vars points
    % to the start of the list and Goals is the list of goals to construct the
    % list. Pos indicates which argument position the first variable in Vars
    % is.
    % InstMap is used to work out if the variable is instantiated enough yet
    % to display.
    % RenamedVar is a map(X, Y) where Y is the X renamed Var, it is use to
    % replace the output variable at the call of the predicate.
    % BoundedVarDes is a map(X, Y) where Y is the VarDesc of X, it is
    % use while generation to recover the description of already bounded
    % variables.
    %
:- pred make_arg_list(int::in, instmap::in, list(prog_var)::in,
    map(prog_var, prog_var)::in, prog_var::out, list(hlds_goal)::out,
    module_info::in, module_info::out, proc_info::in, proc_info::out,
    pred_info::in, pred_info::out, var_table::in, var_table::out,
    map(prog_var, prog_var)::in, map(prog_var, prog_var)::out) is det.

make_arg_list(_Pos, _InstMap, [], _Renaming, OutVar, [Goal], !ModuleInfo,
        !ProcInfo, !PredInfo, !VarTable, !BoundVarDescs) :-
    OutVarEntry = vte("EmptyVarList", list_var_value_type, is_not_dummy_type),
    add_var_entry(OutVarEntry, OutVar, !VarTable),
    ListTypeSymName = qualified(mercury_list_module, "list"),
    ListTypeCtor = type_ctor(ListTypeSymName, 1),
    ConsId = du_data_ctor(du_ctor(qualified(mercury_list_module, "[]" ),
        0, ListTypeCtor)),
    construct_functor(OutVar, ConsId, [], Goal).
make_arg_list(Pos0, InstMap, [ProgVar | ProgVars], Renaming, OutVar, Goals,
        !ModuleInfo, !ProcInfo, !PredInfo, !VarTable, !BoundVarDescs) :-
    Pos = Pos0 + 1,
    make_arg_list(Pos, InstMap, ProgVars, Renaming, OutVar0, Goals0,
        !ModuleInfo, !ProcInfo, !PredInfo, !VarTable, !BoundVarDescs),

    lookup_var_type(!.VarTable, ProgVar, ProgVarType),
    ( if
        ( ProgVarType = io_state_type
        ; ProgVarType = io_io_type
        )
    then
        OutVar = OutVar0,
        Goals = Goals0
    else
        % BoundVarDescs is filled with the description of the input variable
        % during the first call to make_arg_list predicate.
        % At the second call, we search if the current ProgVar already exist
        % in the map and if yes, copy his recorded description.

        ( if map.search(!.BoundVarDescs, ProgVar, ExistingVarDesc) then
            ValueGoals = [],
            VarDesc = ExistingVarDesc
        else
            make_var_value(InstMap, ProgVar, Renaming, VarDesc, Pos0,
                ValueGoals, !ModuleInfo, !ProcInfo, !PredInfo,
                !VarTable, !BoundVarDescs)
        ),

        OutVarEntry =
            vte("FullListVar", list_var_value_type, is_not_dummy_type),
        add_var_entry(OutVarEntry, OutVar, !VarTable),
        ListTypeSymName = qualified(mercury_list_module, "list"),
        ListTypeCtor = type_ctor(ListTypeSymName, 1),
        ConsId = du_data_ctor(du_ctor(qualified(unqualified("list"), "[|]" ),
            2, ListTypeCtor)),
        construct_functor(OutVar, ConsId, [VarDesc, OutVar0], Goal),

        %XXX Optimize me: repeated appends are slow.
        Goals = Goals0 ++ ValueGoals ++ [Goal]
    ).

    % Return the type list(var_value).
    %
:- func list_var_value_type = mer_type.

list_var_value_type = ListVarValueType :-
    SSDBModule = mercury_ssdb_builtin_module,
    VarValueTypeCtor = type_ctor(qualified(SSDBModule, "var_value"), 0),
    construct_type(VarValueTypeCtor, [], VarValueType),
    ListTypeCtor = type_ctor(qualified(mercury_list_module, "list"), 1),
    construct_type(ListTypeCtor, [VarValueType], ListVarValueType).

    % Create the goal's argument description:
    % -> unbound_head_var(Name, Pos) if it is an unbound argument
    % -> bound_head_var(type_of_T, Name, Position, T) if it is a bound argument
    %
:- pred make_var_value(instmap::in, prog_var::in, map(prog_var, prog_var)::in,
    prog_var::out, int::in, list(hlds_goal)::out,
    module_info::in, module_info::out, proc_info::in, proc_info::out,
    pred_info::in, pred_info::out, var_table::in, var_table::out,
    map(prog_var, prog_var)::in, map(prog_var, prog_var)::out) is det.

make_var_value(InstMap, VarToInspect, Renaming, VarDesc, VarPos, Goals,
        !ModuleInfo, !ProcInfo, !PredInfo, !VarTable, !BoundVarDescs) :-
    SSDBModule = mercury_ssdb_builtin_module,
    VarValueTypeCtor = type_ctor(qualified(SSDBModule, "var_value"), 0),
    construct_type(VarValueTypeCtor, [], VarValueType),
    VarName = var_table_entry_name(!.VarTable, VarToInspect),
    make_string_const_construction_alloc(VarName, "VarName",
        ConstructVarName, VarNameVar, !VarTable),
    make_int_const_construction_alloc(VarPos, "VarPos",
        ConstructVarPos, VarPosVar, !VarTable),

    VarValueTypeIsDummy = is_type_a_dummy(!.ModuleInfo, VarValueType),
    VarDescEntry = vte("VarDesc", VarValueType, VarValueTypeIsDummy),
    add_var_entry(VarDescEntry, VarDesc, !VarTable),
    ( if
        var_is_ground_in_instmap(!.ModuleInfo, !.VarTable, InstMap,
            VarToInspect)
    then
        % Update proc_varset and proc_vartypes; without this,
        % polymorphism_make_type_info_var uses a prog_var which is
        % already bound.

        proc_info_set_var_table(!.VarTable, !ProcInfo),

        % Create dynamic constructor for the value of the argument.
        %
        % Call polymorphism.m to create the type_infos, add an hidden field
        % which is the polymorphic type of the value.
        %
        % some[T] bound_head_var(string, int, T) ---->
        %   some[T] bound_head_var(type_of_T, string, int, T)

        Context = dummy_context,
        lookup_var_type(!.VarTable, VarToInspect, MerType),
        polymorphism_make_type_info_var_mi(MerType, Context,
            TypeInfoVar, TypeInfoGoals0, !ModuleInfo, !PredInfo, !ProcInfo),

        proc_info_get_var_table(!.ProcInfo, !:VarTable),
        % Constructor of the variable's description.
        ConsId = du_data_ctor(du_ctor(
            qualified(SSDBModule, "bound_head_var"), 3,
            VarValueTypeCtor)),

        % Renaming contains the names of all instantiated arguments
        % during the execution of the procedure's body.
        ( if map.is_empty(Renaming) then
            construct_functor(VarDesc, ConsId,
                [TypeInfoVar, VarNameVar, VarPosVar, VarToInspect],
                ConstructVarGoal)
        else
            map.lookup(Renaming, VarToInspect, RenamedVar),
            construct_functor(VarDesc, ConsId,
                [TypeInfoVar, VarNameVar, VarPosVar, RenamedVar],
                ConstructVarGoal)
        ),

        % The type_info of an existentally typed variable is an output, so
        % could be renamed away. The exit port handler is called before the
        % assignment of the original type_info variable, so we need to use the
        % renamed variable here.
        rename_vars_in_goals(need_not_rename, Renaming, TypeInfoGoals0,
            TypeInfoGoals),

        Goals = [ConstructVarName, ConstructVarPos | TypeInfoGoals] ++
            [ConstructVarGoal],
        map.det_insert(VarToInspect, VarDesc, !BoundVarDescs)
    else
        ConsId = du_data_ctor(du_ctor(
            qualified(SSDBModule, "unbound_head_var"), 2,
            VarValueTypeCtor)),
        construct_functor(VarDesc, ConsId, [VarNameVar, VarPosVar],
            ConstructVarGoal),

        Goals = [ConstructVarName, ConstructVarPos, ConstructVarGoal]
    ).

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

:- func shallow_cons_id = cons_id.

shallow_cons_id = ssdb_tracing_level_cons_id("shallow").

:- func deep_cons_id = cons_id.

deep_cons_id = ssdb_tracing_level_cons_id("deep").

:- func ssdb_tracing_level_cons_id(string) = cons_id.

ssdb_tracing_level_cons_id(Level) = Cons :-
    DataCtor = qualified(mercury_ssdb_builtin_module, Level),
    Cons = du_data_ctor(du_ctor(DataCtor, 0, ssdb_tracing_level_type_ctor)).

:- func ssdb_tracing_level_type_ctor = type_ctor.

ssdb_tracing_level_type_ctor = type_ctor(ssdb_tracing_level_name, 0).

:- func ssdb_tracing_level_type = mer_type.

ssdb_tracing_level_type = defined_type(ssdb_tracing_level_name, [], kind_star).

:- func ssdb_tracing_level_name = sym_name.

ssdb_tracing_level_name =
    qualified(mercury_ssdb_builtin_module, "ssdb_tracing_level").

%-----------------------------------------------------------------------------%
:- end_module transform_hlds.ssdebug.
%-----------------------------------------------------------------------------%