mercury/mdbcomp/rtti_access.m

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2005-2007, 2009-2011 The University of Melbourne.
% Copyright (C) 2014-2015, 2017-2018 The Mercury team.
% This file is distributed under the terms specified in COPYING.LIB.
%---------------------------------------------------------------------------%
%
% File: rtti_access.m.
% Main authors: zs, maclarty
%
% This module contains an interface to the label_layout and proc_layout
% types which are used in the C backend of the debugger.
%
%---------------------------------------------------------------------------%

:- module mdbcomp.rtti_access.
:- interface.

:- import_module mdbcomp.goal_path.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.trace_counts.

:- import_module list.
:- import_module maybe.

:- type label_layout.

:- func get_proc_layout_from_label_layout(label_layout) = proc_layout.

:- func get_goal_path_from_label_layout(label_layout) = goal_path_string.

:- func get_goal_path_from_maybe_label(maybe(label_layout)) = goal_path_string.

:- func get_port_from_label_layout(label_layout) = trace_port.

:- func get_path_port_from_label_layout(label_layout) = path_port.

:- pred get_context_from_label_layout(label_layout::in, string::out, int::out)
    is semidet.

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

:- type proc_layout.

:- func get_proc_label_from_layout(proc_layout) = proc_label.

:- func get_proc_name(proc_label) = string.

    % find_initial_version_arg_num(Proc, OutputArgNum, InputArgNum):
    %
    % Given a procedure and an output argument number of that procedure,
    % find an input argument which has the same name as the output argument,
    % expect for a numerical suffix and possibly an underscore. The output
    % argument name needn't have a numerical suffix, but if it does, then the
    % input argument's numerical suffix should be less that the numerical
    % suffix of the output argument. This procedure is used as a heuristic to
    % determine when it is worth checking if a subterm appearing in the output
    % argument also appears in the same position in the input argument.
    % The heuristic is used by the subterm dependency tracking algorithm
    % to help speed up the search.
    % Argument numbers start at one.
    % This procedure is implemented in C to avoid having to allocate memory
    % to import non-word-aligned strings into Mercury code.
    %
:- pred find_initial_version_arg_num(proc_layout::in, int::in, int::out)
    is semidet.

:- func get_all_modes_for_layout(proc_layout) = list(proc_layout).

:- func containing_proc_layout(label_layout) = proc_layout.

:- func proc_bytecode_bytes(proc_layout) = bytecode_bytes.

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

:- type string_table
    --->    string_table(
                string_table_chars,
                % The characters of the string table, which may include
                % null characters.

                int
                % The number of characters in the string table.
            ).

:- type module_layout.
:- type string_table_chars.

:- pred containing_module_layout(proc_layout::in, module_layout::out)
    is semidet.

:- func module_string_table(module_layout) = string_table.

:- func lookup_string_table(string_table, int) = string.

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

:- type bytecode
    --->    bytecode(
                bytecode_bytes,     % The bytes of the bytecode.
                int                 % The number of bytes in the bytecode.
            ).

:- type bytecode_bytes
    --->    dummy_bytecode_bytes.

:- pragma foreign_type("C", bytecode_bytes, "const MR_uint_least8_t *",
    [can_pass_as_mercury_type, stable]).
    % The following definitions are only stubs.
:- pragma foreign_type("C#", bytecode_bytes, "object", []).
:- pragma foreign_type("Java", bytecode_bytes, "java.lang.Object", []).

    % read_byte(ByteCode, Byte, !Pos):
    %
    % Read a single byte.
    %
:- pred read_byte(bytecode::in, int::out, int::in, int::out) is semidet.

    % read_short(ByteCode, Short, !Pos):
    %
    % Read a short that is represented by two bytes.
    %
:- pred read_short(bytecode::in, int::out, int::in, int::out) is semidet.

    % read_int32(ByteCode, Int, !Pos):
    %
    % Read four byte integer.
    %
:- pred read_int32(bytecode::in, int::out, int::in, int::out) is semidet.

    % read_num(ByteCode, Num, !Pos):
    %
    % Read an integer encoded using the deep profiler's variable length
    % encoding scheme.
    %
:- pred read_num(bytecode::in, int::out, int::in, int::out) is semidet.

    % read_string_via_offset(ByteCode, StringTable, String, !Pos):
    %
    % Read a string represented as a four-byte integer giving an offset
    % in the string table.
    %
:- pred read_string_via_offset(bytecode::in, string_table::in, string::out,
    int::in, int::out) is semidet.

    % read_line(ByteCode, Line, !Pos):
    %
    % Read a sequence of characters ending in a newline.
    %
:- pred read_line(bytecode::in, string::out, int::in, int::out) is semidet.

    % read_len_string(ByteCode, String, !Pos):
    %
    % Read a string represented as a <length, characters> sequence, in which
    % the length is encoded using the deep profiler's variable length
    % encoding scheme.
    %
:- pred read_len_string(bytecode::in, string::out, int::in, int::out)
    is semidet.

    % read_string_table(ByteCode, StringTable, !Pos):
    %
    % Given that ByteCode contains a string table starting at the position
    % given by !.Pos, return that string table and set !:Pos to point to
    % the first byte after it.
    %
:- pred read_string_table(bytecode::in, string_table::out,
    int::in, int::out) is semidet.

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

:- pred encode_byte(int::in, list(int)::out) is semidet.
:- pred encode_byte_det(int::in, list(int)::out) is det.
:- func encode_byte_func(int) = list(int).

:- pred encode_short(int::in, list(int)::out) is semidet.
:- pred encode_short_det(int::in, list(int)::out) is det.
:- func encode_short_func(int) = list(int).

:- pred encode_int32(int::in, list(int)::out) is semidet.
:- pred encode_int32_det(int::in, list(int)::out) is det.
:- func encode_int32_func(int) = list(int).

:- pred encode_num(int::in, list(int)::out) is semidet.
:- pred encode_num_det(int::in, list(int)::out) is det.
:- func encode_num_func(int) = list(int).

:- pred encode_len_string(string::in, list(int)::out) is det.
:- func encode_len_string_func(string) = list(int).

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

:- implementation.

:- import_module mdbcomp.sym_name.

:- import_module char.
:- import_module int.
:- import_module require.
:- import_module string.

:- pragma foreign_type("C", label_layout, "const MR_LabelLayout *",
    [can_pass_as_mercury_type, stable]).
    % The following definitions are only stubs.
:- pragma foreign_type("C#", label_layout, "object", []).
:- pragma foreign_type("Java", label_layout, "java.lang.Object", []).

:- pragma foreign_proc("C",
    get_proc_layout_from_label_layout(Label::in) = (ProcLayout::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    ProcLayout = Label->MR_sll_entry;
").

:- pragma foreign_proc("C",
    get_goal_path_from_label_layout(Label::in) = (GoalPath::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    GoalPath = (MR_String) MR_label_goal_path(Label);
").

get_goal_path_from_maybe_label(yes(Label))
    = get_goal_path_from_label_layout(Label).
get_goal_path_from_maybe_label(no) = "".

:- pragma foreign_proc("C",
    get_context_from_label_layout(Label::in, FileName::out, LineNo::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    const char  *filename;
    int         line_no;

    SUCCESS_INDICATOR = MR_find_context(Label, &filename, &line_no);
    LineNo = (MR_Integer) line_no;
    MR_TRACE_USE_HP(
        MR_make_aligned_string(FileName, (MR_String) filename);
    );
").

:- pragma foreign_proc("C",
    get_port_from_label_layout(Label::in) = (Port::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    Port = Label->MR_sll_port;
").

get_path_port_from_label_layout(Label) = PathPort :-
    Port = get_port_from_label_layout(Label),
    GoalPathStr = get_goal_path_from_label_layout(Label),
    rev_goal_path_from_string_det(GoalPathStr, GoalPath),
    PathPort = make_path_port(GoalPath, Port).

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

:- pragma foreign_type("C", proc_layout, "const MR_ProcLayout *",
    [can_pass_as_mercury_type, stable]).
    % The following definitions are only stubs.
:- pragma foreign_type("C#", proc_layout, "object", []).
:- pragma foreign_type("Java", proc_layout, "java.lang.Object", []).

get_proc_label_from_layout(Layout) = ProcLabel :-
    ( if proc_layout_is_uci(Layout) then
        proc_layout_get_uci_fields(Layout, TypeName, TypeModule,
            DefModule, PredName, TypeArity, ModeNum),
        ( special_pred_name_arity(SpecialIdPrime, _, PredName, _) ->
            SpecialId = SpecialIdPrime
        ;
            unexpected($pred, "bad special_pred_id")
        ),
        SymDefModule = string_to_sym_name(DefModule),
        SymTypeModule = string_to_sym_name(TypeModule),
        ProcLabel = special_proc_label(SymDefModule, SpecialId,
            SymTypeModule, TypeName, TypeArity, ModeNum)
    else
        proc_layout_get_non_uci_fields(Layout, PredOrFunc,
            DeclModule, DefModule, PredName, Arity, ModeNum),
        SymDefModule = string_to_sym_name(DefModule),
        SymDeclModule = string_to_sym_name(DeclModule),
        ProcLabel = ordinary_proc_label(SymDefModule, PredOrFunc,
            SymDeclModule, PredName, Arity, ModeNum)
    ).

get_proc_name(ordinary_proc_label(_, _, _, ProcName, _, _)) = ProcName.
get_proc_name(special_proc_label(_, _, _, ProcName , _, _)) = ProcName.

:- pred proc_layout_is_uci(proc_layout::in) is semidet.

:- pragma foreign_proc("C",
    proc_layout_is_uci(Layout::in),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    if (MR_PROC_ID_IS_UCI(Layout->MR_sle_proc_id)) {
        SUCCESS_INDICATOR = MR_TRUE;
    } else {
        SUCCESS_INDICATOR = MR_FALSE;
    }
").

:- pred proc_layout_get_uci_fields(proc_layout::in, string::out,
    string::out, string::out, string::out, int::out, int::out) is det.

:- pragma foreign_proc("C",
    proc_layout_get_uci_fields(Layout::in, TypeName::out, TypeModule::out,
        DefModule::out, PredName::out, TypeArity::out, ModeNum::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    const MR_UCIProcId  *proc_id;

    proc_id = &Layout->MR_sle_uci;

    /* The casts are there to cast away const without warnings */
    TypeName   = (MR_String) (MR_Integer) proc_id->MR_uci_type_name;
    TypeModule = (MR_String) (MR_Integer) proc_id->MR_uci_type_module;
    DefModule  = (MR_String) (MR_Integer) proc_id->MR_uci_def_module;
    PredName   = (MR_String) (MR_Integer) proc_id->MR_uci_pred_name;
    TypeArity  = proc_id->MR_uci_type_arity;
    ModeNum    = proc_id->MR_uci_mode;
").

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

:- pragma foreign_proc("C",
    proc_layout_get_non_uci_fields(Layout::in, PredOrFunc::out,
        DeclModule::out, DefModule::out, PredName::out,
        Arity::out, ModeNum::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    const MR_UserProcId *proc_id;

    proc_id = &Layout->MR_sle_user;

    /* The casts are there to cast away const without warnings */
    PredOrFunc = proc_id->MR_user_pred_or_func;
    DeclModule = (MR_String) (MR_Integer) proc_id->MR_user_decl_module;
    DefModule  = (MR_String) (MR_Integer) proc_id->MR_user_def_module;
    PredName   = (MR_String) (MR_Integer) proc_id->MR_user_name;
    Arity      = proc_id->MR_user_pred_form_arity;
    ModeNum    = proc_id->MR_user_mode;
").

:- pragma foreign_proc("C",
    find_initial_version_arg_num(Layout::in, OutArgNum::in, InArgNum::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    const MR_ProcLayout     *proc;
    int                     out_hlds_num;
    const char              *out_name;
    int                     should_copy_out;

    proc = Layout;

    if (! MR_PROC_LAYOUT_HAS_EXEC_TRACE(proc)) {
        MR_fatal_error(""find_initial_version_arg_num: proc"");
    }

    out_hlds_num = proc->MR_sle_head_var_nums[OutArgNum - 1];
    out_name = MR_hlds_var_name(proc, out_hlds_num, &should_copy_out);
    if (out_name == NULL || MR_streq(out_name, """")) {
        /* out_hlds_num was not named by the user */
        SUCCESS_INDICATOR = MR_FALSE;
    } else {
        char                    out_name_buf[MR_MAX_VARNAME_SIZE];
        int                     out_base_name_len;
        int                     out_numerical_suffix;
        int                     num_matches;
        int                     in_hlds_num;
        int                     in_arg_num;
        const char              *in_name;
        int                     start_of_num;
        int                     in_numerical_suffix;
        int                     head_var_num;
        int                     call_var_num;
        int                     call_num_vars;
        const MR_LabelLayout    *call_label;
        MR_bool                 found;

        if (should_copy_out) {
            strncpy(out_name_buf, out_name, sizeof(out_name_buf) - 1);
            out_name_buf[sizeof(out_name_buf) - 1] = '\\0';
            out_name = (const char *) out_name_buf;
        }

        start_of_num = MR_find_start_of_num_suffix(out_name);
        if (start_of_num < 0) {
            out_base_name_len = strlen(out_name);
            out_numerical_suffix = -1;
        } else {
            out_base_name_len = start_of_num;
            out_numerical_suffix = atoi(out_name + start_of_num);
        }

        num_matches = 0;
        in_arg_num = -1;

        for (head_var_num = 0; head_var_num < proc->MR_sle_num_head_vars;
            head_var_num++)
        {
            in_hlds_num = proc->MR_sle_head_var_nums[head_var_num];
            in_name = MR_hlds_var_name(proc, in_hlds_num, NULL);
            if (in_name == NULL || MR_streq(in_name, """")) {
                continue;
            }

            start_of_num = MR_find_start_of_num_suffix(in_name);
            if (start_of_num < 0) {
                continue;
            }

            if (! (
                    (
                        /*
                        ** The names are exactly the same except
                        ** for the numerical suffix.
                        */
                        start_of_num == out_base_name_len &&
                        MR_strneq(out_name, in_name, start_of_num)
                    )
                ||
                    (
                        /*
                        ** The names are exactly the same except
                        ** for an underscore and the numerical suffix
                        ** (as is the case with state variable notation).
                        */
                        start_of_num == out_base_name_len + 1 &&
                        start_of_num > 0 &&
                        in_name[start_of_num - 1] == '_' &&
                        MR_strneq(out_name, in_name, start_of_num - 1)
                    )
                ))
            {
                continue;
            }

            in_numerical_suffix = atoi(in_name + start_of_num);
            if (! ((in_numerical_suffix >= out_numerical_suffix)
                || (out_numerical_suffix < 0)))
            {
                continue;
            }

            call_label = proc->MR_sle_call_label;
            if (! MR_has_valid_var_count(call_label)) {
                    continue;
            }

            if (! MR_has_valid_var_info(call_label)) {
                continue;
            }

            /*
            ** The in_hlds_num has the same prefix as the output variable.
            ** Check if in_hlds_num is an input argument.
            */
            call_num_vars = MR_all_desc_var_count(call_label);
            found = MR_FALSE;
            for (call_var_num = 0 ; call_var_num < call_num_vars;
                    call_var_num++)
            {
                if (call_label->MR_sll_var_nums[call_var_num] == in_hlds_num) {
                    found = MR_TRUE;
                    break;
                }
            }

            if (! found) {
                continue;
            }

            num_matches++;
            in_arg_num = head_var_num;
        }

        if (num_matches == 1) {
            InArgNum = in_arg_num + 1;
            SUCCESS_INDICATOR = MR_TRUE;
        } else {
            SUCCESS_INDICATOR = MR_FALSE;
        }
    }
").

:- pragma foreign_proc("C",
    get_all_modes_for_layout(Layout::in) = (Layouts::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    const MR_ModuleLayout   *module;
    const MR_ProcLayout     *proc;
    int                     i;
    MR_Word                 list;
    MR_bool                 match;
    const MR_ProcLayout     *selected_proc;

    selected_proc = Layout;

    if (! MR_PROC_LAYOUT_HAS_EXEC_TRACE(selected_proc)) {
        MR_fatal_error(""get_all_modes_for_layout: selected_proc"");
    }

    module = selected_proc->MR_sle_module_layout;
    list = MR_list_empty();
    for (i = 0; i < module->MR_ml_proc_count; i++) {
        proc = module->MR_ml_procs[i];
        if (! MR_PROC_LAYOUT_HAS_EXEC_TRACE(selected_proc)) {
            MR_fatal_error(""get_all_modes_for_layout: proc"");
        }

        if (MR_PROC_LAYOUT_IS_UCI(selected_proc)
            && MR_PROC_LAYOUT_IS_UCI(proc))
        {
            const MR_UCIProcId  *proc_id;
            const MR_UCIProcId  *selected_proc_id;

            proc_id = &proc->MR_sle_uci;
            selected_proc_id = &selected_proc->MR_sle_uci;

            if (MR_streq(proc_id->MR_uci_type_name,
                selected_proc_id->MR_uci_type_name)
            && MR_streq(proc_id->MR_uci_type_module,
                selected_proc_id->MR_uci_type_module)
            && MR_streq(proc_id->MR_uci_pred_name,
                selected_proc_id->MR_uci_pred_name)
            && (proc_id->MR_uci_type_arity ==
                selected_proc_id->MR_uci_type_arity))
            {
                match = MR_TRUE;
            } else {
                match = MR_FALSE;
            }
        } else if (!MR_PROC_LAYOUT_IS_UCI(selected_proc)
            && !MR_PROC_LAYOUT_IS_UCI(proc))
        {
            const MR_UserProcId *proc_id;
            const MR_UserProcId *selected_proc_id;

            proc_id = &proc->MR_sle_user;
            selected_proc_id = &selected_proc->MR_sle_user;

            if ((proc_id->MR_user_pred_or_func ==
                selected_proc_id->MR_user_pred_or_func)
            && MR_streq(proc_id->MR_user_decl_module,
                selected_proc_id->MR_user_decl_module)
            && MR_streq(proc_id->MR_user_name,
                selected_proc_id->MR_user_name)
            && (proc_id->MR_user_pred_form_arity ==
                selected_proc_id->MR_user_pred_form_arity))
            {
                match = MR_TRUE;
            } else {
                match = MR_FALSE;
            }
        } else {
            match = MR_FALSE;
        }

        if (match) {
            list = MR_int_list_cons((MR_Integer) proc, list);
        }
    }

    Layouts = list;
").

:- pragma foreign_proc("C",
    containing_proc_layout(LabelLayout::in) = (ProcLayout::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    ProcLayout = LabelLayout->MR_sll_entry;
").

:- pragma foreign_proc("C",
    proc_bytecode_bytes(ProcLayout::in) = (ByteCodeBytes::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    ByteCodeBytes = ProcLayout->MR_sle_body_bytes;
#ifdef MR_DEBUG_PROC_REP
    printf(""lookup_proc_bytecode: %p %p\\n"", ProcLayout, ByteCodeBytes);
#endif
").

:- pragma foreign_proc("C#",
    proc_bytecode_bytes(_ProcLayout::in) = (_ByteCodeBytes::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    throw new System.Exception(\"not supported in C# grade\");
").

:- pragma foreign_proc("Java",
    proc_bytecode_bytes(_ProcLayout::in) = (_ByteCodeBytes::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    if (1 == 1) throw new Error(\"not supported in java grade\");
").

    % Default version for non-C backends.
proc_bytecode_bytes(_) = dummy_bytecode_bytes.

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

:- pragma foreign_type("C", module_layout, "const MR_ModuleLayout *",
    [can_pass_as_mercury_type, stable]).
    % The following definitions are only stubs.
:- pragma foreign_type("C#", module_layout, "object", []).
:- pragma foreign_type("Java", module_layout, "java.lang.Object", []).

:- pragma foreign_type("C", string_table_chars, "MR_ConstString",
    [can_pass_as_mercury_type, stable]).
    % The following definitions are only stubs.
:- pragma foreign_type("C#", string_table_chars, "object", []).
:- pragma foreign_type("Java", string_table_chars, "java.lang.Object", []).

:- pragma foreign_proc("C",
    containing_module_layout(ProcLayout::in, ModuleLayout::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    if (MR_PROC_LAYOUT_HAS_THIRD_GROUP(ProcLayout)) {
        ModuleLayout = ProcLayout->MR_sle_module_layout;
        SUCCESS_INDICATOR = MR_TRUE;
    } else {
        SUCCESS_INDICATOR = MR_FALSE;
    }
").

module_string_table(ModuleLayout) = StringTable :-
    module_string_table_components(ModuleLayout, StringTableChars, Size),
    StringTable = string_table(StringTableChars, Size).

:- pred module_string_table_components(module_layout::in,
    string_table_chars::out, int::out) is det.

:- pragma foreign_proc("C",
    module_string_table_components(ModuleLayout::in,
        StringTableChars::out, Size::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    StringTableChars = ModuleLayout->MR_ml_string_table;
    Size = ModuleLayout->MR_ml_string_table_size;
").

lookup_string_table(StringTable, NameCode) = Str :-
    StringTable = string_table(StringTableChars, Size),
    Str = lookup_string_table_2(StringTableChars, Size, NameCode).

:- func lookup_string_table_2(string_table_chars, int, int) = string.

:- pragma foreign_proc("C",
    lookup_string_table_2(StringTableChars::in, StringTableSize::in,
        NameCode::in) = (Str::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    MR_ConstString  str0;
    int             should_copy;

    str0 = MR_name_in_string_table(StringTableChars, StringTableSize,
        (MR_uint_least32_t)NameCode, &should_copy);
    if (should_copy) {
        MR_make_aligned_string(Str, str0);
    } else {
        MR_make_aligned_string_copy(Str, str0);
    }
").

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

read_byte(ByteCode, Value, !Pos) :-
    ByteCode = bytecode(Bytes, Size),
    !.Pos + 1 =< Size,
    read_byte_2(Bytes, Value, !Pos).

:- pred read_byte_2(bytecode_bytes::in, int::out, int::in, int::out) is det.

:- pragma foreign_proc("C",
    read_byte_2(ByteCode::in, Value::out, Pos0::in, Pos::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    Value = ByteCode[Pos0];
    Pos = Pos0 + 1;
").

read_short(ByteCode, Value, !Pos) :-
    ByteCode = bytecode(Bytes, Size),
    !.Pos + 2 =< Size,
    read_short_2(Bytes, Value, !Pos).

:- pred read_short_2(bytecode_bytes::in, int::out, int::in, int::out) is det.

:- pragma foreign_proc("C",
    read_short_2(ByteCode::in, Value::out, Pos0::in, Pos::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    Value = (ByteCode[Pos0] << 8) + ByteCode[Pos0+1];
    Pos = Pos0 + 2;
").

read_int32(ByteCode, Value, !Pos) :-
    ByteCode = bytecode(Bytes, Size),
    !.Pos + 4 =< Size,
    read_int32_2(Bytes, Value, !Pos).

:- pred read_int32_2(bytecode_bytes::in, int::out, int::in, int::out) is det.

:- pragma foreign_proc("C",
    read_int32_2(ByteCode::in, Value::out, Pos0::in, Pos::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    Value = (ByteCode[Pos0] << 24) + (ByteCode[Pos0+1] << 16) +
        (ByteCode[Pos0+2] << 8) + ByteCode[Pos0+3];
    Pos = Pos0 + 4;
").

read_num(ByteCode, Num, !Pos) :-
    read_num_2(ByteCode, 0, Num, !Pos).

:- pred read_num_2(bytecode::in, int::in, int::out, int::in, int::out)
    is semidet.

read_num_2(ByteCode, Num0, Num, !Pos) :-
    read_byte(ByteCode, Byte, !Pos),
    Num1 = (Num0 << 7) \/ (Byte /\ 0x7F),
    ( if Byte /\ 0x80 = 0 then
        Num = Num1
    else
        read_num_2(ByteCode, Num1, Num, !Pos)
    ).

read_string_via_offset(ByteCode, StringTable, String, !Pos) :-
    read_int32(ByteCode, Offset, !Pos),
    String = lookup_string_table(StringTable, Offset).

read_line(ByteCode, Line, !Pos) :-
    read_line_2(ByteCode, [], RevChars, !Pos),
    string.from_rev_char_list(RevChars, Line).

:- pred read_line_2(bytecode::in, list(char)::in, list(char)::out,
    int::in, int::out) is semidet.

read_line_2(ByteCode, !RevChars, !Pos) :-
    read_byte(ByteCode, Byte, !Pos),
    char.from_int(Byte, Char),
    ( if Char = '\n' then
        !:RevChars = [Char | !.RevChars]
    else
        !:RevChars = [Char | !.RevChars],
        disable_warning [suspicious_recursion] (
            read_line_2(ByteCode, !RevChars, !Pos)
        )
    ).

read_len_string(ByteCode, String, !Pos) :-
    read_num(ByteCode, Length, !Pos),
    read_len_string_2(ByteCode, Length, [], RevChars, !Pos),
    string.from_rev_char_list(RevChars, String).

:- pred read_len_string_2(bytecode::in, int::in,
    list(char)::in, list(char)::out, int::in, int::out) is semidet.

read_len_string_2(ByteCode, N, !RevChars, !Pos) :-
    ( if N =< 0 then
        true
    else
        read_byte(ByteCode, Byte, !Pos),
        char.from_int(Byte, Char),
        !:RevChars = [Char | !.RevChars],
        read_len_string_2(ByteCode, N - 1, !RevChars, !Pos)
    ).

read_string_table(ByteCode, StringTable, !Pos) :-
    read_num(ByteCode, Size, !Pos),
    ByteCode = bytecode(Bytes, NumBytes),
    !.Pos + Size =< NumBytes,
    bytecode_string_table_2(Bytes, !.Pos, Size, StringTableChars),
    !:Pos = !.Pos + Size,
    StringTable = string_table(StringTableChars, Size).

:- pred bytecode_string_table_2(bytecode_bytes::in, Offset::in, Size::in,
    string_table_chars::out) is det.

:- pragma foreign_proc("C",
    bytecode_string_table_2(Bytes::in, Offset::in, Size::in,
        StringTableChars::out),
    [will_not_call_mercury, thread_safe, promise_pure],
"
    char        *buf;
    char        *table;
    MR_Unsigned i;

    MR_allocate_aligned_string_msg(buf, Size, MR_ALLOC_ID);
    table = ((char *) Bytes) + Offset;
    for (i = 0; i < Size; i++) {
        buf[i] = table[i];
    }

    StringTableChars = (MR_ConstString) buf;
").

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

encode_byte(Byte, [Byte]) :-
    Byte >= 0,
    Byte < 128.

encode_byte_det(Byte, Bytes) :-
    ( if encode_byte(Byte, BytesPrime) then
        Bytes = BytesPrime
    else
        unexpected($pred, "encode_byte failed")
    ).

encode_byte_func(Byte) = Bytes :-
    encode_byte_det(Byte, Bytes).

encode_short(Short, [Byte1, Byte2]) :-
    Short >= 0,
    Byte2 = Short /\ 255,
    Byte1 = Short / 256,
    Byte1 < 128.

encode_short_det(Short, Bytes) :-
    ( if encode_short(Short, BytesPrime) then
        Bytes = BytesPrime
    else
        unexpected($pred, "encode_short failed")
    ).

encode_short_func(Short) = Bytes :-
    encode_short_det(Short, Bytes).

encode_int32(Int32, [Byte1, Byte2, Byte3, Byte4]) :-
    Int32 >= 0,
    Byte4 = Int32 /\ 255,
    Bytes123 = Int32 / 256,
    Byte3 = Bytes123 /\ 255,
    Bytes12 = Bytes123 / 256,
    Byte2 = Bytes12 /\ 255,
    Byte1 = Bytes12 / 256,
    Byte1 < 128.

encode_int32_det(Int32, Bytes) :-
    ( if encode_int32(Int32, BytesPrime) then
        Bytes = BytesPrime
    else
        unexpected($pred, "encode_int32 failed")
    ).

encode_int32_func(Int32) = Bytes :-
    encode_int32_det(Int32, Bytes).

encode_num(Num, Bytes) :-
    Num >= 0,
    LastByte = Num /\ 127,
    NextNum = Num / 128,
    encode_num_2(NextNum, [LastByte], Bytes).

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

encode_num_2(Num, RestBytes, Bytes) :-
    ( if Num = 0 then
        Bytes = RestBytes
    else
        CurByte = (Num /\ 127) \/ 128,
        NextNum = Num / 128,
        encode_num_2(NextNum, [CurByte | RestBytes], Bytes)
    ).

encode_num_det(Num, Bytes) :-
    ( if encode_num(Num, BytesPrime) then
        Bytes = BytesPrime
    else
        unexpected($pred, "encode_num failed")
    ).

encode_num_func(Num) = Bytes :-
    encode_num_det(Num, Bytes).

encode_len_string(String, Bytes) :-
    string.length(String, Length),
    encode_num_det(Length, LengthBytes),
    string.to_char_list(String, Chars),
    CharBytes = list.map(char.to_int, Chars),
    Bytes = LengthBytes ++ CharBytes.

encode_len_string_func(String) = Bytes :-
    encode_len_string(String, Bytes).

%---------------------------------------------------------------------------%
:- end_module mdbcomp.rtti_access.
%---------------------------------------------------------------------------%