mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-15 01:13:30 +00:00
Code Issues Projects Releases Wiki Activity
Files
master
mercury/deep_profiler/read_profile.m
Zoltan Somogyi 9baadb3d88 Style improvements in browser and deep_profiler. 
deep_profiler/var_use_analysis.m:
    Pass never-varying and slower-varying input arguments first.

    Consistently pass goal lists before the position of the first goal
    in the overall list.

browser/declarative_analyser.m:
browser/declarative_edt.m:
deep_profiler/analysis_utils.m:
deep_profiler/autopar_reports.m:
deep_profiler/autopar_types.m:
deep_profiler/program_representation_utils.m:
deep_profiler/read_profile.m:
deep_profiler/recursion_patterns.m:
deep_profiler/timeout.m:
deep_profiler/top_procs.m:
deep_profiler/util.m:
    Minor improvements in programming style.
2025-11-18 16:11:20 +11:00

1591 lines
58 KiB
Mathematica
Raw Permalink Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2001, 2004-2012 The University of Melbourne.
% Copyright (C) 2013, 2015-2017, 2021-2022, 2024-2025 The Mercury team.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% File: read_profile.m.
% Authors: conway, zs.
%
% This module contains code for reading in a deep profiling data file.
% Such files, named Deep.data, are created by deep profiled executables.
%
%---------------------------------------------------------------------------%
:- module read_profile.
:- interface.
:- import_module profile.
:- import_module io.
:- import_module maybe.
:- pred read_call_graph(string::in, maybe_error(initial_deep)::out,
io::di, io::uo) is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module array_util.
:- import_module io_combinator.
:- import_module mdbcomp.
:- import_module mdbcomp.goal_path.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.program_representation.
:- import_module measurements.
:- import_module array.
:- import_module assoc_list.
:- import_module bool.
:- import_module char.
:- import_module int.
:- import_module list.
:- import_module pair.
:- import_module require.
:- import_module string.
%---------------------------------------------------------------------------%
:- type maybe_error2(T1, T2)
---> ok2(T1, T2)
; error2(string).
:- type ptr_kind
---> ps
; pd
; css
; csd.
read_call_graph(FileName, MaybeInitDeep, !IO) :-
io.open_binary_input(FileName, OpenResult, !IO),
(
OpenResult = ok(FileStream),
read_deep_id_string(FileStream, MaybeAcceptableVersion, !IO),
(
MaybeAcceptableVersion = ok(AcceptableVersion),
% In the future, we could use different code to read in
% profiling data files with different version numbers.
io_combinator.maybe_error_sequence_11(
read_string(FileStream),
read_fixed_size_int(FileStream),
read_fixed_size_int(FileStream),
read_fixed_size_int(FileStream),
read_fixed_size_int(FileStream),
read_fixed_size_int(FileStream),
read_num(FileStream),
read_num(FileStream),
read_num(FileStream),
read_num(FileStream),
read_ptr(FileStream, pd),
maybe_init_deep,
MaybeInitDeepHeader, !IO),
(
MaybeInitDeepHeader = ok(InitDeep),
% When we implement compression of data files, we would
% want to pipe the rest of the input stream through the
% decompression mechanism.
read_nodes_outer_loop(FileStream, AcceptableVersion,
InitDeep, MaybeInitDeep, !IO)
;
MaybeInitDeepHeader = error(Error),
MaybeInitDeep = error(Error)
)
;
MaybeAcceptableVersion = error(Msg),
MaybeInitDeep = error(Msg)
),
io.close_binary_input(FileStream, !IO)
;
OpenResult = error(Error),
io.error_message(Error, Msg),
MaybeInitDeep = error(Msg)
).
:- type acceptable_version
---> av_8
; av_9.
:- pred read_deep_id_string(io.binary_input_stream::in,
maybe_error(acceptable_version)::out, io::di, io::uo) is det.
read_deep_id_string(InputStream, MaybeAcceptableVersion, !IO) :-
% The 10 extra chars should be ample for the version number and newline.
FirstLineLenLimit = string.length(deep_id_prefix) + 10,
read_line(InputStream, FirstLineLenLimit, MaybeLine, !IO),
(
MaybeLine = ok(Line0),
Line = string.chomp(Line0),
( if
string.append(deep_id_prefix, Suffix, Line),
string.to_int(Suffix, VersionNumber)
then
( if acceptable_version(VersionNumber, AcceptableVersion) then
MaybeAcceptableVersion = ok(AcceptableVersion)
else
MaybeAcceptableVersion = error("version number mismatch")
)
else
MaybeAcceptableVersion = error("not a deep profiling data file")
)
;
MaybeLine = error(Error),
MaybeAcceptableVersion = error(Error)
).
% Return the constant prefix of the string identifying a file
% as a deep profiling data file. The first line of a profiling data file
% should contain this prefix and the version number of format used by the
% file.
%
% This string must match the string written by the function
% MR_write_out_deep_id_string in runtime/mercury_deep_profiling.c.
%
:- func deep_id_prefix = string.
deep_id_prefix = "Mercury deep profiler data version ".
:- pred acceptable_version(int::in, acceptable_version::out) is semidet.
acceptable_version(8, av_8).
acceptable_version(9, av_9).
:- pred maybe_init_deep(string::in, int::in, int::in, int::in, int::in,
int::in, int::in, int::in, int::in, int::in, int::in,
maybe_error(initial_deep)::out) is det.
maybe_init_deep(ProgName, FlagsInt, MaxCSD, MaxCSS, MaxPD, MaxPS, TicksPerSec,
InstrumentQuanta, UserQuanta, NumCallSeqs, RootPDI, MaybeInitDeep) :-
maybe_deep_flags(FlagsInt, MaybeFlags),
(
MaybeFlags = ok(Flags),
InitStats = profile_stats(ProgName, MaxCSD, MaxCSS, MaxPD, MaxPS,
TicksPerSec, InstrumentQuanta, UserQuanta, NumCallSeqs, Flags),
InitDeep = initial_deep(
InitStats,
make_pdptr(RootPDI),
array.init(MaxCSD + 1,
call_site_dynamic(
make_dummy_pdptr,
make_dummy_pdptr,
zero_own_prof_info
)),
array.init(MaxPD + 1, proc_dynamic(make_dummy_psptr, array([]),
no)),
array.init(MaxCSS + 1,
call_site_static(
make_dummy_psptr, -1,
normal_call_and_callee(make_dummy_psptr, ""),
"", -1, rgp_nil
)),
array.init(MaxPS + 1,
proc_static(dummy_proc_id, "", "", "", "", "", -1, no,
array([]), array([]), no, not_zeroed))
),
MaybeInitDeep = ok(InitDeep)
;
MaybeFlags = error(Error),
MaybeInitDeep = error(Error)
).
:- pred maybe_deep_flags(int::in, maybe_error(deep_flags)::out) is det.
maybe_deep_flags(FlagsInt, MaybeFlags) :-
BytesPerInt = (FlagsInt /\ deep_flag_bytes_per_int_mask)
>> deep_flag_bytes_per_int_shift,
Canonical = (FlagsInt /\ deep_flag_canonical_mask)
>> deep_flag_canonical_shift,
Compression = (FlagsInt /\ deep_flag_compression_mask)
>> deep_flag_compression_shift,
Coverage = (FlagsInt /\ deep_flag_coverage_mask)
>> deep_flag_coverage_shift,
( if
(
Canonical = 0,
CanonicalFlag = maybe_not_canonical
;
Canonical = 1,
CanonicalFlag = is_canonical
),
(
Compression = 0,
CompressionFlag = no_compression
% There is no compression alternative yet
),
(
Coverage = 0,
CoverageFlag = no_coverage_data
;
Coverage = 1,
CoverageFlag = static_coverage_data
;
Coverage = 2,
CoverageFlag = dynamic_coverage_data
),
0 = ((\ deep_flag_all_fields_mask) /\ FlagsInt)
then
MaybeFlags = ok(deep_flags(BytesPerInt, CanonicalFlag, CompressionFlag,
CoverageFlag))
else
MaybeFlags = error(
string.format("Error parsing flags in file header, flags are 0x%x",
[i(FlagsInt)]))
).
% Flags masks and shifts.
% The following line provides a ruler to line up the hexadecimal values
% with.
%
% 48 32 16 0
%
% Bytes_per_int occupies the bottom 8 bits, bit 0 to 7.
% The canonical flag occupies the next 2 bits, bit 8 to 9.
% The compression flag occupies the next 2 bits, bit 10 to 11.
% The coverage indication occupies the next 2 bits, bit 12 to 13.
%
% Some of these have more bits than they currently need, in order to
% accommodate possible future growth.
:- func deep_flag_bytes_per_int_mask = int.
deep_flag_bytes_per_int_mask = 0x00000000000000FF.
:- func deep_flag_bytes_per_int_shift = int.
deep_flag_bytes_per_int_shift = 0.
:- func deep_flag_canonical_mask = int.
deep_flag_canonical_mask = 0x0000000000000300.
:- func deep_flag_canonical_shift = int.
deep_flag_canonical_shift = 8.
:- func deep_flag_compression_mask = int.
deep_flag_compression_mask = 0x0000000000000C00.
:- func deep_flag_compression_shift = int.
deep_flag_compression_shift = 10.
:- func deep_flag_coverage_mask = int.
deep_flag_coverage_mask = 0x0000000000003000.
:- func deep_flag_coverage_shift = int.
deep_flag_coverage_shift = 12.
:- func deep_flag_all_fields_mask = int.
deep_flag_all_fields_mask =
deep_flag_bytes_per_int_mask \/
deep_flag_canonical_mask \/
deep_flag_compression_mask \/
deep_flag_coverage_mask.
:- pred read_nodes_outer_loop(io.binary_input_stream::in,
acceptable_version::in, initial_deep::in, maybe_error(initial_deep)::out,
io::di, io::uo) is det.
read_nodes_outer_loop(InputStream, Version, InitDeep0, MaybeInitDeep, !IO) :-
% We use two nested loops to ensure that this code works even in grades
% that lack tail recursion, such as debugging grades. read_nodes_inner_loop
% will return after it has processed 50000 nodes, unwinding its stack.
% This outer loop predicate will continue as long as read_nodes_inner_loop
% thinks that more work remains.
%
% The value of 50,000 has been chosen as it is roughly less than half the
% stack depth that causes crashes during debugging.
read_nodes_inner_loop(InputStream, Version, 50000,
InitDeep0, MaybeInitDeep0, !IO),
(
MaybeInitDeep0 = init_deep_complete(InitDeep),
MaybeInitDeep = ok(InitDeep)
;
MaybeInitDeep0 = error(Error),
MaybeInitDeep = error(Error)
;
MaybeInitDeep0 = init_deep_incomplete(InitDeep1),
read_nodes_outer_loop(InputStream, Version,
InitDeep1, MaybeInitDeep, !IO)
).
:- type maybe_init_deep_complete
---> init_deep_complete(initial_deep)
; init_deep_incomplete(initial_deep)
; error(string).
:- pred read_nodes_inner_loop(io.binary_input_stream::in,
acceptable_version::in, int::in,
initial_deep::in, maybe_init_deep_complete::out, io::di, io::uo) is det.
read_nodes_inner_loop(InputStream, Version, !.NumLeft,
!.InitDeep, MaybeInitDeep, !IO) :-
( if !.NumLeft < 1 then
MaybeInitDeep = init_deep_incomplete(!.InitDeep)
else
!:NumLeft = !.NumLeft - 1,
ProfileStats = !.InitDeep ^ init_profile_stats,
read_byte(InputStream, MaybeByte, !IO),
(
MaybeByte = ok(Byte),
( if is_next_item_token(Byte, NextItem) then
(
NextItem = deep_item_call_site_dynamic,
read_call_site_dynamic(InputStream, MaybeCSD, !IO),
(
MaybeCSD = ok2(CallSiteDynamic, CSDI),
CSDs0 = !.InitDeep ^ init_call_site_dynamics,
deep_insert(CSDI, CallSiteDynamic, CSDs0, CSDs),
!InitDeep ^ init_call_site_dynamics := CSDs,
read_nodes_inner_loop(InputStream, Version, !.NumLeft,
!.InitDeep, MaybeInitDeep, !IO)
;
MaybeCSD = error2(Error),
MaybeInitDeep = error(Error)
)
;
NextItem = deep_item_proc_dynamic,
read_proc_dynamic(InputStream, ProfileStats, MaybePD, !IO),
(
MaybePD = ok2(ProcDynamic, PDI),
PDs0 = !.InitDeep ^ init_proc_dynamics,
deep_insert(PDI, ProcDynamic, PDs0, PDs),
!InitDeep ^ init_proc_dynamics := PDs,
read_nodes_inner_loop(InputStream, Version, !.NumLeft,
!.InitDeep, MaybeInitDeep, !IO)
;
MaybePD = error2(Error),
MaybeInitDeep = error(Error)
)
;
NextItem = deep_item_call_site_static,
read_call_site_static(InputStream, Version, MaybeCSS, !IO),
(
MaybeCSS = ok({CallSiteStatic, CSSI}),
CSSs0 = !.InitDeep ^ init_call_site_statics,
deep_insert(CSSI, CallSiteStatic, CSSs0, CSSs),
!InitDeep ^ init_call_site_statics := CSSs,
read_nodes_inner_loop(InputStream, Version, !.NumLeft,
!.InitDeep, MaybeInitDeep, !IO)
;
MaybeCSS = error(Error),
MaybeInitDeep = error(Error)
)
;
NextItem = deep_item_proc_static,
read_proc_static(InputStream, ProfileStats, MaybePS, !IO),
(
MaybePS = ok2(ProcStatic, PSI),
PSs0 = !.InitDeep ^ init_proc_statics,
deep_insert(PSI, ProcStatic, PSs0, PSs),
!InitDeep ^ init_proc_statics := PSs,
read_nodes_inner_loop(InputStream, Version, !.NumLeft,
!.InitDeep, MaybeInitDeep, !IO)
;
MaybePS = error2(Error),
MaybeInitDeep = error(Error)
)
;
NextItem = deep_item_end,
MaybeInitDeep = init_deep_complete(!.InitDeep)
)
else
string.format("unexpected token %d", [i(Byte)], Msg),
MaybeInitDeep = error(Msg)
)
;
MaybeByte = eof,
% XXX: Shouldn't this be an error? Shouldn't we expect
% a deep_item_end token before eof?
MaybeInitDeep = init_deep_complete(!.InitDeep)
;
MaybeByte = error(Error),
io.error_message(Error, Msg),
MaybeInitDeep = error(Msg)
)
).
:- pred read_call_site_static(io.binary_input_stream::in,
acceptable_version::in, maybe_error({call_site_static, int})::out,
io::di, io::uo) is det.
read_call_site_static(InputStream, Version, MaybeCSS, !IO) :-
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream, "reading call_site_static.\n", !TIO)
),
(
Version = av_8,
io_combinator.maybe_error_sequence_4(
read_ptr(InputStream, css),
read_call_site_kind_and_callee(InputStream),
read_num(InputStream),
read_string(InputStream),
( pred(CSSI0::in, Kind::in, LineNumber::in,
GoalPathStr::in, CSS::out) is det :-
DummyPSPtr = make_dummy_psptr,
DummySlotNum = -1,
rev_goal_path_from_string_det(GoalPathStr, RevGoalPath0),
rev_goal_path_remove_type_info(RevGoalPath0, RevGoalPath),
% Setting the FileName slot to "" asks users of this field
% to copy the file name in the call site's proc_static.
CallSiteStatic0 = call_site_static(DummyPSPtr,
DummySlotNum, Kind, "", LineNumber, RevGoalPath),
CSS = ok({CallSiteStatic0, CSSI0})
),
MaybeCSS, !IO)
;
Version = av_9,
io_combinator.maybe_error_sequence_5(
read_ptr(InputStream, css),
read_call_site_kind_and_callee(InputStream),
read_string(InputStream),
read_num(InputStream),
read_string(InputStream),
( pred(CSSI0::in, Kind::in, FileName::in, LineNumber::in,
GoalPathStr::in, CSS::out) is det :-
DummyPSPtr = make_dummy_psptr,
DummySlotNum = -1,
rev_goal_path_from_string_det(GoalPathStr, RevGoalPath0),
rev_goal_path_remove_type_info(RevGoalPath0, RevGoalPath),
CallSiteStatic0 = call_site_static(DummyPSPtr,
DummySlotNum, Kind, FileName, LineNumber, RevGoalPath),
CSS = ok({CallSiteStatic0, CSSI0})
),
MaybeCSS, !IO)
),
(
MaybeCSS = ok({CallSiteStatic, CSSI}),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.format(OutputStream,
"read call_site_static %d:", [i(CSSI)], !TIO),
io.write(OutputStream, CallSiteStatic, !TIO),
io.write_string(OutputStream, "\n", !TIO)
)
;
MaybeCSS = error(_)
).
:- pred read_proc_static(io.binary_input_stream::in, profile_stats::in,
maybe_error2(proc_static, int)::out, io::di, io::uo) is det.
read_proc_static(InputStream, ProfileStats, MaybePS, !IO) :-
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream, "reading proc_static.\n", !TIO)
),
io_combinator.maybe_error_sequence_6(
read_ptr(InputStream, ps),
read_proc_id(InputStream),
read_string(InputStream),
read_num(InputStream),
read_deep_byte(InputStream),
read_num(InputStream),
( pred(PSI0::in, Id0::in, F0::in, L0::in, I0::in,
NCS0::in, ProcId::out) is det :-
ProcId = ok({PSI0, Id0, F0, L0, I0, NCS0})
),
MaybeProcId, !IO),
(
MaybeProcId = ok({PSI, Id, FileName, LineNumber, Interface, NCS}),
read_n_things(NCS, read_ptr(InputStream, css), MaybeCSSIs, !IO),
(
MaybeCSSIs = ok(CSSIs),
maybe_read_ps_coverage_points(InputStream, ProfileStats,
MaybeCoveragePoints, !IO),
(
MaybeCoveragePoints = ok(CPInfos - MaybeCPs),
CSSPtrs = list.map(make_cssptr, CSSIs),
DeclModule = decl_module(Id),
create_refined_proc_ids(Id, UnQualRefinedStr, QualRefinedStr),
RawStr = raw_proc_id_to_string(Id),
( if Interface = 0 then
IsInInterface = no
else
IsInInterface = yes
),
% The `not_zeroed' for whether the procedure's proc_static
% is ever zeroed is the default. The startup phase will set it
% to `zeroed' in the proc_statics which are ever zeroed.
ProcStatic = proc_static(Id, DeclModule,
UnQualRefinedStr, QualRefinedStr, RawStr,
FileName, LineNumber, IsInInterface,
array(CSSPtrs), CPInfos, MaybeCPs, not_zeroed),
MaybePS = ok2(ProcStatic, PSI),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.format(OutputStream,
"read proc_static %d:", [i(PSI)], !TIO),
io.write(OutputStream, ProcStatic, !TIO),
io.write_string(OutputStream, "\n", !TIO)
)
;
MaybeCoveragePoints = error(Error),
MaybePS = error2(Error)
)
;
MaybeCSSIs = error(Error),
MaybePS = error2(Error)
)
;
MaybeProcId = error(Error),
MaybePS = error2(Error)
).
:- pred maybe_read_ps_coverage_points(io.binary_input_stream::in,
profile_stats::in, maybe_error(pair(array(coverage_point_info),
maybe(array(int))))::out, io::di, io::uo) is det.
maybe_read_ps_coverage_points(InputStream, ProfileStats, MaybeCoveragePoints,
!IO) :-
CoverageDataType = ProfileStats ^ prs_deep_flags ^ df_coverage_data_type,
(
CoverageDataType = no_coverage_data,
MaybeCoveragePoints0 = ok([] - no)
;
( CoverageDataType = static_coverage_data
; CoverageDataType = dynamic_coverage_data
),
read_num(InputStream, MaybeNCP, !IO),
(
MaybeNCP = ok(NCP),
(
CoverageDataType = static_coverage_data,
read_n_things(NCP,
read_coverage_point_static_and_num(InputStream),
MaybeCPPairs, !IO),
(
MaybeCPPairs = ok(CPPairs),
keys_and_values(CPPairs, CPInfos, CPs),
MaybeCoveragePoints0 = ok(CPInfos - yes(CPs))
;
MaybeCPPairs = error(Error0),
MaybeCoveragePoints0 = error(Error0)
)
;
CoverageDataType = dynamic_coverage_data,
read_n_things(NCP, read_coverage_point_static(InputStream),
MaybeCPInfos, !IO),
(
MaybeCPInfos = ok(CPInfos),
MaybeCoveragePoints0 = ok(CPInfos - no)
;
MaybeCPInfos = error(Error0),
MaybeCoveragePoints0 = error(Error0)
)
)
;
MaybeNCP = error(Error0),
MaybeCoveragePoints0 = error(Error0)
)
),
(
MaybeCoveragePoints0 = ok(CPInfosList - MaybeCPsList),
CPInfosArray = array(CPInfosList),
MaybeCPsArray = map_maybe(array, MaybeCPsList),
MaybeCoveragePoints = ok(CPInfosArray - MaybeCPsArray)
;
MaybeCoveragePoints0 = error(Error),
MaybeCoveragePoints = error(Error)
).
:- pred maybe_read_pd_coverage_points(io.binary_input_stream::in,
profile_stats::in, maybe_error(maybe(array(int)))::out,
io::di, io::uo) is det.
maybe_read_pd_coverage_points(InputStream, ProfileStats,
MaybeCoveragePoints, !IO) :-
CoverageDataType = ProfileStats ^ prs_deep_flags ^ df_coverage_data_type,
(
( CoverageDataType = no_coverage_data
; CoverageDataType = static_coverage_data
),
MaybeCoveragePoints = ok(no)
;
CoverageDataType = dynamic_coverage_data,
read_num(InputStream, ResN, !IO),
(
ResN = ok(N),
read_n_things(N, read_num(InputStream), MaybeCPs, !IO),
(
MaybeCPs = ok(CPsList),
MaybeCoveragePoints = ok(yes(array(CPsList)))
;
MaybeCPs = error(Error),
MaybeCoveragePoints = error(Error)
)
;
ResN = error(Error),
MaybeCoveragePoints = error(Error)
)
).
:- pred read_proc_id(io.binary_input_stream::in,
maybe_error(string_proc_label)::out, io::di, io::uo) is det.
read_proc_id(InputStream, MaybeProcId, !IO) :-
read_deep_byte(InputStream, MaybeByte, !IO),
(
MaybeByte = ok(Byte),
( if is_proclabel_kind(Byte, ProcLabelKind) then
(
ProcLabelKind = proclabel_special,
read_proc_id_uci_pred(InputStream, MaybeProcId, !IO)
;
ProcLabelKind = proclabel_user_predicate,
read_proc_id_user_defined(InputStream, pf_predicate,
MaybeProcId, !IO)
;
ProcLabelKind = proclabel_user_function,
read_proc_id_user_defined(InputStream, pf_function,
MaybeProcId, !IO)
)
else
string.format("unexpected proclabel_kind %d", [i(Byte)], Msg),
MaybeProcId = error(Msg)
)
;
MaybeByte = error(Error),
MaybeProcId = error(Error)
).
:- pred read_proc_id_uci_pred(io.binary_input_stream::in,
maybe_error(string_proc_label)::out, io::di, io::uo) is det.
read_proc_id_uci_pred(InputStream, MaybeProcLabel, !IO) :-
io_combinator.maybe_error_sequence_6(
read_string(InputStream),
read_string(InputStream),
read_string(InputStream),
read_string(InputStream),
read_num(InputStream),
read_num(InputStream),
( pred(TypeName::in, TypeModule::in, DefModule::in,
PredName::in, Arity::in, Mode::in, ProcId::out) is det :-
ProcId = ok(str_special_proc_label(TypeName, TypeModule,
DefModule, PredName, Arity, Mode))
),
MaybeProcLabel, !IO).
:- pred read_proc_id_user_defined(io.binary_input_stream::in, pred_or_func::in,
maybe_error(string_proc_label)::out, io::di, io::uo) is det.
read_proc_id_user_defined(InputStream, PredOrFunc, MaybeProcLabel, !IO) :-
io_combinator.maybe_error_sequence_5(
read_string(InputStream),
read_string(InputStream),
read_string(InputStream),
read_num(InputStream),
read_num(InputStream),
( pred(DeclModule::in, DefModule::in, Name::in,
Arity::in, Mode::in, ProcId::out) is det :-
ProcId = ok(str_ordinary_proc_label(PredOrFunc, DeclModule,
DefModule, Name, Arity, Mode))
),
MaybeProcLabel, !IO).
% Read the description of a coverage point, and its execution count.
%
% The description of a coverage point is stored in the proc static
% regardless of whether we are using static or dynamic coverage profiling.
% If we are using static coverage profiling, then this description will be
% immediately followed in the profiling data file by the number of times
% that the coverage point was executed.
%
:- pred read_coverage_point_static_and_num(io.binary_input_stream::in,
maybe_error(pair(coverage_point_info, int))::out, io::di, io::uo) is det.
read_coverage_point_static_and_num(InputStream, MaybeCP, !IO) :-
io_combinator.maybe_error_sequence_2(
read_coverage_point_static(InputStream),
read_num(InputStream),
( pred(CPInfo::in, Count::in, ok(CPI)::out) is det :-
CPI = CPInfo - Count
), MaybeCP, !IO).
% Read the description of a coverage point.
%
% The description of a coverage point is stored in the proc static
% regardless of whether we are using static or dynamic coverage profiling.
%
:- pred read_coverage_point_static(io.binary_input_stream::in,
maybe_error(coverage_point_info)::out, io::di, io::uo) is det.
read_coverage_point_static(InputStream, MaybeCP, !IO) :-
io_combinator.maybe_error_sequence_2(
read_string(InputStream),
read_cp_type(InputStream),
( pred(GoalPathString::in, CPType::in, MaybeCPI::out) is det :-
rev_goal_path_from_string_det(GoalPathString, RevGoalPath0),
rev_goal_path_remove_type_info(RevGoalPath0, RevGoalPath),
MaybeCPI = ok(coverage_point_info(RevGoalPath, CPType))
), MaybeCP, !IO).
:- func raw_proc_id_to_string(string_proc_label) = string.
raw_proc_id_to_string(ProcLabel) = Str :-
(
ProcLabel = str_special_proc_label(TypeName, TypeModule, _DefModule,
PredName, Arity, Mode),
string.format("%s for %s.%s/%d mode %d",
[s(PredName), s(TypeModule), s(TypeName), i(Arity), i(Mode)], Str)
;
ProcLabel = str_ordinary_proc_label(PredOrFunc, DeclModule,
_DefModule, Name, Arity, Mode),
string.format("%s.%s/%d%s-%d",
[s(DeclModule), s(Name), i(Arity),
s(plus_one_for_function(PredOrFunc)), i(Mode)], Str)
).
:- pred create_refined_proc_ids(string_proc_label::in,
string::out, string::out) is det.
create_refined_proc_ids(ProcLabel, UnQualName, QualName) :-
(
ProcLabel = str_special_proc_label(TypeName, TypeModule,
_DefModule, RawPredName, Arity, Mode),
( if RawPredName = "__Unify__" then
PredName = "Unify"
else if RawPredName = "__Compare__" then
PredName = "Compare"
else if RawPredName = "__CompareRep__" then
PredName = "CompareRep"
else if RawPredName = "__Index__" then
PredName = "Index"
else
Msg = "unknown special predicate name " ++ RawPredName,
error(Msg)
),
Prefix = PredName ++ " for ",
AritySuffix = "/" ++ string.int_to_string(Arity),
UnQualName0 = Prefix ++ TypeName ++ AritySuffix,
QualName0 = Prefix ++ TypeModule ++ "." ++ TypeName ++ AritySuffix,
( if Mode = 0 then
UnQualName = UnQualName0,
QualName = QualName0
else
ModeSuffix = " mode " ++ int_to_string(Mode),
UnQualName = UnQualName0 ++ ModeSuffix,
QualName = QualName0 ++ ModeSuffix
)
;
ProcLabel = str_ordinary_proc_label(PredOrFunc, DeclModule,
_DefModule, ProcName, Arity, Mode),
PlusOne = plus_one_for_function(PredOrFunc),
( if
string.append("TypeSpecOf__", ProcName1, ProcName),
( if string.append("pred__", ProcName2A, ProcName1) then
ProcName2 = ProcName2A
else if string.append("func__", ProcName2B, ProcName1) then
ProcName2 = ProcName2B
else if string.append("pred_or_func__", ProcName2C, ProcName1) then
ProcName2 = ProcName2C
else
error("typespec: neither pred nor func")
),
string.to_char_list(ProcName2, ProcName2Chars),
fix_type_spec_suffix(ProcName2Chars, ProcNameChars, SpecInfo)
then
RefinedProcName = string.from_char_list(ProcNameChars),
string.format("%s/%d%s-%d [%s]",
[s(RefinedProcName), i(Arity), s(PlusOne), i(Mode),
s(SpecInfo)],
UnQualName)
else if
string.append("IntroducedFrom__", ProcName1, ProcName),
( if string.append("pred__", ProcName2A, ProcName1) then
ProcName2 = ProcName2A
else if string.append("func__", ProcName2B, ProcName1) then
ProcName2 = ProcName2B
else
error("lambda: neither pred nor func")
),
string.to_char_list(ProcName2, ProcName2Chars),
split_lambda_name(ProcName2Chars, Segments),
glue_lambda_name(Segments, ContainingNameChars, LineNumberChars)
then
string.from_char_list(ContainingNameChars, ContainingName),
string.from_char_list(LineNumberChars, LineNumber),
string.format("%s lambda line %s/%d%s",
[s(ContainingName), s(LineNumber), i(Arity), s(PlusOne)],
UnQualName)
else
string.format("%s/%d%s-%d",
[s(ProcName), i(Arity), s(PlusOne), i(Mode)],
UnQualName)
),
QualName = DeclModule ++ "." ++ UnQualName
).
:- func plus_one_for_function(pred_or_func) = string.
plus_one_for_function(pf_function) = "+1".
plus_one_for_function(pf_predicate) = "".
:- pred fix_type_spec_suffix(list(char)::in, list(char)::out, string::out)
is semidet.
fix_type_spec_suffix(Chars0, Chars, SpecInfoStr) :-
( if Chars0 = ['_', '_', '[' | SpecInfo0 ] then
Chars = [],
list.take_while(non_right_bracket, SpecInfo0, SpecInfo),
string.from_char_list(SpecInfo, SpecInfoStr)
else if Chars0 = [Char | TailChars0] then
fix_type_spec_suffix(TailChars0, TailChars, SpecInfoStr),
Chars = [Char | TailChars]
else
fail
).
:- pred non_right_bracket(char::in) is semidet.
non_right_bracket(C) :-
C \= ']'.
:- pred split_lambda_name(list(char)::in, list(list(char))::out) is det.
split_lambda_name([], []).
split_lambda_name([Char0 | Chars0], StringList) :-
( if Chars0 = ['_', '_' | Chars1 ] then
split_lambda_name(Chars1, StringList0),
StringList = [[Char0] | StringList0]
else
split_lambda_name(Chars0, StringList0),
(
StringList0 = [],
StringList = [[Char0]]
;
StringList0 = [String0 | StringList1],
StringList = [[Char0 | String0] | StringList1]
)
).
:- pred glue_lambda_name(list(list(char))::in, list(char)::out,
list(char)::out) is semidet.
glue_lambda_name(Segments, PredName, LineNumber) :-
( if Segments = [LineNumberPrime, _] then
PredName = [],
LineNumber = LineNumberPrime
else if Segments = [Segment | TailSegments] then
glue_lambda_name(TailSegments, PredName1, LineNumber),
(
PredName1 = [],
PredName = Segment
;
PredName1 = [_ | _],
list.append(Segment, ['_', '_' | PredName1], PredName)
)
else
fail
).
:- pred read_proc_dynamic(io.binary_input_stream::in, profile_stats::in,
maybe_error2(proc_dynamic, int)::out, io::di, io::uo) is det.
read_proc_dynamic(InputStream, ProfileStats, MaybePD, !IO) :-
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream, "reading proc_dynamic.\n", !TIO)
),
io_combinator.maybe_error_sequence_3(
read_ptr(InputStream, pd),
read_ptr(InputStream, ps),
read_num(InputStream),
( pred(PDI0::in, PSI0::in, N0::in, Stuff0::out) is det :-
Stuff0 = ok({PDI0, PSI0, N0})
),
MaybePDHeader, !IO),
(
MaybePDHeader = ok({PDI, PSI, N}),
io_combinator.maybe_error_sequence_2(
maybe_read_pd_coverage_points(InputStream, ProfileStats),
read_n_things(N, read_call_site_slot(InputStream)),
( pred(MaybeCPs0::in, Slots0::in, CPsAndSlots0::out) is det :-
CPsAndSlots0 = ok({MaybeCPs0, Slots0})
),
MaybeCPsAndSlots, !IO),
(
MaybeCPsAndSlots = ok({MaybeCPs, Refs}),
PSPtr = make_psptr(PSI),
ProcDynamic = proc_dynamic(PSPtr, array(Refs), MaybeCPs),
MaybePD = ok2(ProcDynamic, PDI),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.format(OutputStream,
"read proc_dynamic %d:", [i(PDI)], !TIO),
io.write(OutputStream, ProcDynamic, !TIO),
io.write_string(OutputStream, "\n", !TIO)
)
;
MaybeCPsAndSlots = error(Error),
MaybePD = error2(Error)
)
;
MaybePDHeader = error(Error),
MaybePD = error2(Error)
).
:- pred read_call_site_dynamic(io.binary_input_stream::in,
maybe_error2(call_site_dynamic, int)::out, io::di, io::uo) is det.
read_call_site_dynamic(InputStream, MaybeCSD, !IO) :-
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream, "reading call_site_dynamic.\n", !TIO)
),
read_ptr(InputStream, csd, MaybeCSDI, !IO),
(
MaybeCSDI = ok(CSDI),
read_ptr(InputStream, pd, MaybePDI, !IO),
(
MaybePDI = ok(PDI),
read_profile(InputStream, MaybeProfile, !IO),
(
MaybeProfile = ok(Profile),
PDPtr = make_pdptr(PDI),
CallerPDPtr = make_dummy_pdptr,
CallSiteDynamic = call_site_dynamic(CallerPDPtr, PDPtr,
Profile),
MaybeCSD = ok2(CallSiteDynamic, CSDI),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.format(OutputStream,
"read call_site_dynamic %d: ", [i(CSDI)], !TIO),
io.write(OutputStream, CallSiteDynamic, !TIO),
io.write_string(OutputStream, "\n", !TIO)
)
;
MaybeProfile = error(Error),
MaybeCSD = error2(Error)
)
;
MaybePDI = error(Error),
MaybeCSD = error2(Error)
)
;
MaybeCSDI = error(Error),
MaybeCSD = error2(Error)
).
:- pred read_profile(io.binary_input_stream::in,
maybe_error(own_prof_info)::out, io::di, io::uo) is det.
read_profile(InputStream, MaybeProfile, !IO) :-
read_num(InputStream, MaybeMask, !IO),
(
MaybeMask = ok(Mask),
% The masks here must correspond exactly with the masks in
% MR_write_out_call_site_dynamic in mercury_deep_profiling.c
% in the runtime.
some [!MaybeError] (
!:MaybeError = no,
% We normally assume that the configuration macro
% MR_DEEP_PROFILING_EXPLICIT_CALL_COUNTS is not
% defined, and thus mercury_deep_profiling.m never
% writes out call counts (instead, call counts are
% computed from other port counts in measurements.m).
% maybe_read_num_handle_error(Mask, 0x0001, Calls,
% !MaybeError, !IO),
maybe_read_num_handle_error(InputStream, Mask, 0x0002, Exits,
!MaybeError, !IO),
maybe_read_num_handle_error(InputStream, Mask, 0x0004, Fails,
!MaybeError, !IO),
maybe_read_num_handle_error(InputStream, Mask, 0x0040, Redos,
!MaybeError, !IO),
maybe_read_num_handle_error(InputStream, Mask, 0x0080, Excps,
!MaybeError, !IO),
maybe_read_num_handle_error(InputStream, Mask, 0x0100, Quanta,
!MaybeError, !IO),
maybe_read_num_handle_error(InputStream, Mask, 0x0008, CallSeqs,
!MaybeError, !IO),
maybe_read_num_handle_error(InputStream, Mask, 0x0010, Allocs,
!MaybeError, !IO),
maybe_read_num_handle_error(InputStream, Mask, 0x0020, Words,
!MaybeError, !IO),
LastMaybeError = !.MaybeError
),
(
LastMaybeError = yes(Error),
MaybeProfile = error(Error)
;
LastMaybeError = no,
MaybeProfile = ok(compress_profile(Exits, Fails, Redos, Excps,
Quanta, CallSeqs, Allocs, Words))
)
;
MaybeMask = error(Error),
MaybeProfile = error(Error)
).
:- pred maybe_read_num_handle_error(io.binary_input_stream::in,
int::in, int::in, int::out, maybe(string)::in, maybe(string)::out,
io::di, io::uo) is det.
maybe_read_num_handle_error(InputStream, MaskWord, MaskValue, Num,
!MaybeError, !IO) :-
( if MaskWord /\ MaskValue \= 0 then
read_num(InputStream, MaybeNum, !IO),
(
MaybeNum = ok(Num)
;
MaybeNum = error(Error),
Num = 0,
!:MaybeError = yes(Error)
)
else
Num = 0
).
:- pred read_call_site_slot(io.binary_input_stream::in,
maybe_error(call_site_array_slot)::out, io::di, io::uo) is det.
read_call_site_slot(InputStream, MaybeSlot, !IO) :-
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream, "reading call_site_slot.\n", !TIO)
),
read_call_site_kind(InputStream, MaybeKind, !IO),
(
MaybeKind = ok(Kind),
(
Kind = normal_call,
read_ptr(InputStream, csd, MaybeCSDI, !IO),
(
MaybeCSDI = ok(CSDI),
CSDPtr = make_csdptr(CSDI),
MaybeSlot = ok(slot_normal(CSDPtr)),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream,
"normal call_site slot ", !TIO),
io.write_int(OutputStream, CSDI, !TIO),
io.write_string(OutputStream, "\n", !TIO)
)
;
MaybeCSDI = error(Error),
MaybeSlot = error(Error)
)
;
(
Kind = higher_order_call,
Zeroed = zeroed
;
Kind = method_call,
Zeroed = zeroed
;
Kind = special_call,
Zeroed = not_zeroed
;
Kind = callback,
Zeroed = not_zeroed
),
read_multi_call_site_csdis(InputStream, MaybeCSDIs, !IO),
(
MaybeCSDIs = ok(CSDIs),
CSDPtrs = list.map(make_csdptr, CSDIs),
MaybeSlot = ok(slot_multi(Zeroed, array(CSDPtrs))),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream,
"multi call_site slots ", !TIO),
io.write(OutputStream, CSDIs, !TIO),
io.write_string(OutputStream, "\n", !TIO)
)
;
MaybeCSDIs = error(Error),
MaybeSlot = error(Error)
)
)
;
MaybeKind = error(Error),
MaybeSlot = error(Error)
).
:- pred read_multi_call_site_csdis(io.binary_input_stream::in,
maybe_error(list(int))::out, io::di, io::uo) is det.
read_multi_call_site_csdis(InputStream, MaybeCSDIs, !IO) :-
read_multi_call_site_csdis_2(InputStream, [], MaybeCSDIs, !IO).
% We keep reading CSD node numbers until we find a zero byte.
% The reason why a zero byte works as a sentinel is that a CSD node
% number in the list of CSD node numbers at a multi call site cannot be
% zero, and our encoding scheme ensures that non-zero node numbers
% cannot start with a zero byte.
%
% We return the list of CSD node numbers in the reversed order, but
% this is OK because our caller does not pay attention to the order
% anyway.
:- pred read_multi_call_site_csdis_2(io.binary_input_stream::in, list(int)::in,
maybe_error(list(int))::out, io::di, io::uo) is det.
read_multi_call_site_csdis_2(InputStream, CSDIs0, MaybeCSDIs, !IO) :-
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.format(OutputStream, "reading multi_call_site_csdi.\n", [], !TIO)
),
read_deep_byte(InputStream, MaybeByte, !IO),
(
MaybeByte = ok(Byte),
( if Byte = 0 then
MaybeCSDIs = ok(CSDIs0)
else
putback_byte(InputStream, Byte, !IO),
read_ptr(InputStream, csd, MaybeCSDI, !IO),
(
MaybeCSDI = ok(CSDI),
read_multi_call_site_csdis_2(InputStream,
[CSDI | CSDIs0], MaybeCSDIs, !IO)
;
MaybeCSDI = error(Error),
MaybeCSDIs = error(Error)
)
)
;
MaybeByte = error(Error),
MaybeCSDIs = error(Error)
).
:- pred read_call_site_kind(io.binary_input_stream::in,
maybe_error(call_site_kind)::out, io::di, io::uo) is det.
read_call_site_kind(InputStream, MaybeKind, !IO) :-
read_deep_byte(InputStream, MaybeByte, !IO),
(
MaybeByte = ok(Byte),
( if is_call_site_kind(Byte, CallSiteKind) then
MaybeKind = ok(CallSiteKind)
else
string.format("unexpected call_site_kind %d", [i(Byte)], Msg),
MaybeKind = error(Msg)
),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream, "call_site_kind ", !TIO),
io.write(OutputStream, MaybeKind, !TIO),
io.write_string(OutputStream, "\n", !TIO)
)
;
MaybeByte = error(Error),
MaybeKind = error(Error)
).
:- pred read_call_site_kind_and_callee(io.binary_input_stream::in,
maybe_error(call_site_kind_and_callee)::out,
io::di, io::uo) is det.
read_call_site_kind_and_callee(InputStream, MaybeKindAndCallee, !IO) :-
read_deep_byte(InputStream, MaybeByte, !IO),
(
MaybeByte = ok(Byte),
( if is_call_site_kind(Byte, CallSiteKind) then
(
CallSiteKind = normal_call,
read_num(InputStream, MaybeCSS, !IO),
(
MaybeCSS = ok(CalleeProcStatic),
read_string(InputStream, MaybeTypeSubst, !IO),
(
MaybeTypeSubst = ok(TypeSubst),
MaybeKindAndCallee = ok(normal_call_and_callee(
proc_static_ptr(CalleeProcStatic), TypeSubst))
;
MaybeTypeSubst = error(Error),
MaybeKindAndCallee = error(Error)
)
;
MaybeCSS = error(Error),
MaybeKindAndCallee = error(Error)
)
;
CallSiteKind = special_call,
MaybeKindAndCallee = ok(special_call_and_no_callee)
;
CallSiteKind = higher_order_call,
MaybeKindAndCallee = ok(higher_order_call_and_no_callee)
;
CallSiteKind = method_call,
MaybeKindAndCallee = ok(method_call_and_no_callee)
;
CallSiteKind = callback,
MaybeKindAndCallee = ok(callback_and_no_callee)
)
else
string.format("unexpected call_site_kind %d", [i(Byte)], Msg),
MaybeKindAndCallee = error(Msg)
),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream, "call_site_kind_and_callee ", !TIO),
io.write(OutputStream, MaybeKindAndCallee, !TIO),
io.write_string(OutputStream, "\n", !TIO)
)
;
MaybeByte = error(Error),
MaybeKindAndCallee = error(Error)
).
%---------------------------------------------------------------------------%
:- pred read_n_things(int::in,
pred(maybe_error(T), io, io)::in(pred(out, di, uo) is det),
maybe_error(list(T))::out, io::di, io::uo) is det.
read_n_things(N, ItemReader, MaybeItems, !IO) :-
read_n_things_loop(N, ItemReader, [], MaybeRevItems, !IO),
(
MaybeRevItems = ok(RevItems),
list.reverse(RevItems, Items),
MaybeItems = ok(Items)
;
MaybeRevItems = error(Error),
MaybeItems = error(Error)
).
:- pred read_n_things_loop(int::in,
pred(maybe_error(T), io, io)::in(pred(out, di, uo) is det),
list(T)::in, maybe_error(list(T))::out, io::di, io::uo) is det.
read_n_things_loop(N, ItemReader, RevItems0, MaybeItems, !IO) :-
( if N =< 0 then
MaybeItems = ok(RevItems0)
else
call(ItemReader, MaybeItem, !IO),
(
MaybeItem = ok(Item),
read_n_things_loop(N - 1, ItemReader,
[Item | RevItems0], MaybeItems, !IO)
;
MaybeItem = error(Error),
MaybeItems = error(Error)
)
).
%---------------------------------------------------------------------------%
:- pred read_line(io.binary_input_stream::in, int::in,
maybe_error(string)::out, io::di, io::uo) is det.
read_line(InputStream, Limit, MaybeLine, !IO) :-
read_line_acc(InputStream, Limit, [], MaybeLine, !IO).
:- pred read_line_acc(io.binary_input_stream::in, int::in, list(char)::in,
maybe_error(string)::out, io::di, io::uo) is det.
read_line_acc(InputStream, Limit, !.RevChars, MaybeLine, !IO) :-
( if Limit > 0 then
read_byte(InputStream, MaybeByte, !IO),
(
MaybeByte = ok(Byte),
( if char.to_int(Char, Byte) then
% Include the newline in the string.
!:RevChars = [Char | !.RevChars],
( if Char = '\n' then
list.reverse(!.RevChars, Chars),
string.from_char_list(Chars, Str),
MaybeLine = ok(Str)
else
read_line_acc(InputStream, Limit - 1, !.RevChars,
MaybeLine, !IO)
)
else
MaybeLine = error("unexpected end of file")
)
;
MaybeByte = eof,
MaybeLine = error("unexpected end of file")
;
MaybeByte = error(Error),
io.error_message(Error, Msg),
MaybeLine = error(Msg)
)
else
list.reverse(!.RevChars, Chars),
string.from_char_list(Chars, Str),
MaybeLine = ok(Str)
).
:- pred read_string(io.binary_input_stream::in, maybe_error(string)::out,
io::di, io::uo) is det.
read_string(InputStream, MaybeStr, !IO) :-
read_num(InputStream, MaybeNum, !IO),
(
MaybeNum = ok(Length),
( if Length = 0 then
MaybeStr = ok("")
else
read_n_byte_string(InputStream, Length, MaybeStr, !IO)
)
;
MaybeNum = error(Error),
MaybeStr = error(Error)
).
:- pred read_n_byte_string(io.binary_input_stream::in, int::in,
maybe_error(string)::out, io::di, io::uo) is det.
read_n_byte_string(InputStream, Length, MaybeStr, !IO) :-
read_n_bytes(InputStream, Length, MaybeNBytes, !IO),
(
MaybeNBytes = ok(Bytes),
( if
list.map((pred(I::in, C::out) is semidet :- char.to_int(C, I)),
Bytes, Chars)
then
string.from_char_list(Chars, Str),
MaybeStr = ok(Str)
else
MaybeStr = error("string contained bad char")
)
;
MaybeNBytes = error(Error),
MaybeStr = error(Error)
),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream, "string ", !TIO),
io.write(OutputStream, MaybeStr, !TIO),
io.write_string(OutputStream, "\n", !TIO)
).
:- pred read_ptr(io.binary_input_stream::in, ptr_kind::in,
maybe_error(int)::out, io::di, io::uo) is det.
read_ptr(InputStream, _Kind, MaybePtr, !IO) :-
read_num(InputStream, MaybePtr, !IO),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream, "ptr ", !TIO),
io.write(OutputStream, MaybePtr, !TIO),
io.write_string(OutputStream, "\n", !TIO)
).
:- pred read_cp_type(io.binary_input_stream::in, maybe_error(cp_type)::out,
io::di, io::uo) is det.
read_cp_type(InputStream, MaybeCPType, !IO) :-
read_num(InputStream, MaybeNum, !IO),
(
MaybeNum = ok(Num),
num_to_cp_type(Num, CPType),
MaybeCPType = ok(CPType)
;
MaybeNum = error(Msg),
MaybeCPType = error(Msg)
).
:- pred num_to_cp_type(int::in, cp_type::out) is det.
:- pragma foreign_proc("C",
num_to_cp_type(Int::in, CPType::out),
[will_not_call_mercury, thread_safe, promise_pure],
"
CPType = Int;
").
:- pred read_num(io.binary_input_stream::in, maybe_error(int)::out,
io::di, io::uo) is det.
read_num(InputStream, MaybeNum, !IO) :-
read_num_acc(InputStream, 0, MaybeNum, !IO),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream, "num ", !TIO),
io.write(OutputStream, MaybeNum, !TIO),
io.write_string(OutputStream, "\n", !TIO)
).
:- pred read_num_acc(io.binary_input_stream::in, int::in,
maybe_error(int)::out, io::di, io::uo) is det.
read_num_acc(InputStream, Num0, MaybeNum, !IO) :-
read_byte(InputStream, MaybeByte, !IO),
(
MaybeByte = ok(Byte),
Num1 = (Num0 << 7) \/ (Byte /\ 0x7F),
( if Byte /\ 0x80 \= 0 then
read_num_acc(InputStream, Num1, MaybeNum, !IO)
else
MaybeNum = ok(Num1)
)
;
MaybeByte = eof,
MaybeNum = error("unexpected end of file")
;
MaybeByte = error(Error),
io.error_message(Error, Msg),
MaybeNum = error(Msg)
).
:- func fixed_size_int_bytes = int.
% Must correspond to MR_FIXED_SIZE_INT_BYTES
% in runtime/mercury_deep_profiling.c.
fixed_size_int_bytes = 8.
:- pred read_fixed_size_int(io.binary_input_stream::in, maybe_error(int)::out,
io::di, io::uo) is det.
read_fixed_size_int(InputStream, MaybeInt, !IO) :-
read_fixed_size_int_acc(InputStream, fixed_size_int_bytes, 0, 0,
MaybeInt, !IO),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.format(OutputStream, "fixed size int %s\n",
[s(string(MaybeInt))], !TIO)
).
:- pred read_fixed_size_int_acc(io.binary_input_stream::in, int::in, int::in,
int::in, maybe_error(int)::out, io::di, io::uo) is det.
read_fixed_size_int_acc(InputStream, BytesLeft, Num0, ShiftBy, MaybeInt,
!IO) :-
( if BytesLeft =< 0 then
MaybeInt = ok(Num0)
else
read_deep_byte(InputStream, MaybeByte, !IO),
(
MaybeByte = ok(Byte),
Num1 = Num0 \/ ( Byte << ShiftBy),
read_fixed_size_int_acc(InputStream, BytesLeft - 1, Num1,
ShiftBy + 8, MaybeInt, !IO)
;
MaybeByte = error(Error),
MaybeInt = error(Error)
)
).
:- pred read_n_bytes(io.binary_input_stream::in, int::in,
maybe_error(list(int))::out, io::di, io::uo) is det.
read_n_bytes(InputStream, N, MaybeNBytes, !IO) :-
read_n_bytes_acc(InputStream, N, [], MaybeRevNBytes, !IO),
(
MaybeRevNBytes = ok(RevBytes),
list.reverse(RevBytes, Bytes),
MaybeNBytes = ok(Bytes)
;
MaybeRevNBytes = error(Error),
MaybeNBytes = error(Error)
).
:- pred read_n_bytes_acc(io.binary_input_stream::in, int::in, list(int)::in,
maybe_error(list(int))::out, io::di, io::uo) is det.
read_n_bytes_acc(InputStream, N, RevBytes0, MaybeNBytes, !IO) :-
( if N =< 0 then
MaybeNBytes = ok(RevBytes0)
else
read_deep_byte(InputStream, MaybeByte, !IO),
(
MaybeByte = ok(Byte),
read_n_bytes_acc(InputStream, N - 1,
[Byte | RevBytes0], MaybeNBytes, !IO)
;
MaybeByte = error(Error),
MaybeNBytes = error(Error)
)
).
:- pred read_deep_byte(io.binary_input_stream::in, maybe_error(int)::out,
io::di, io::uo) is det.
read_deep_byte(InputStream, MaybeByte, !IO) :-
read_byte(InputStream, MaybeRawByte, !IO),
(
MaybeRawByte = ok(Byte),
MaybeByte = ok(Byte)
;
MaybeRawByte = eof,
MaybeByte = error("unexpected end of file")
;
MaybeRawByte = error(Error),
io.error_message(Error, Msg),
MaybeByte = error(Msg)
),
trace [compile_time(flag("debug_read_profdeep")), io(!TIO)] (
io.output_stream(OutputStream, !TIO),
io.write_string(OutputStream, "byte ", !TIO),
io.write(OutputStream, MaybeByte, !TIO),
io.write_string(OutputStream, "\n", !TIO)
).
%---------------------------------------------------------------------------%
:- pred deep_insert(int::in, T::in, array(T)::in, array(T)::out) is det.
deep_insert(Ind, Item, A0, A) :-
array.max(A0, Max),
( if Ind > Max then
error("deep_insert: array bounds violation")
% array.lookup(A0, 0, X),
% array.resize(u(A0), 2 * (Max + 1), X, A1),
% deep_insert(A1, Ind, Item, A)
else
set(Ind, Item, u(A0), A)
).
%---------------------------------------------------------------------------%
:- func make_csdptr(int) = call_site_dynamic_ptr.
:- func make_cssptr(int) = call_site_static_ptr.
:- func make_pdptr(int) = proc_dynamic_ptr.
:- func make_psptr(int) = proc_static_ptr.
make_csdptr(CSDI) = call_site_dynamic_ptr(CSDI).
make_cssptr(CSSI) = call_site_static_ptr(CSSI).
make_pdptr(PDI) = proc_dynamic_ptr(PDI).
make_psptr(PSI) = proc_static_ptr(PSI).
:- func make_dummy_pdptr = proc_dynamic_ptr.
:- func make_dummy_psptr = proc_static_ptr.
make_dummy_pdptr = proc_dynamic_ptr(-1).
make_dummy_psptr = proc_static_ptr(-1).
%---------------------------------------------------------------------------%
:- pragma foreign_decl("C", "#include ""mercury_deep_profiling.h""").
:- type next_deep_item
---> deep_item_end
; deep_item_call_site_static
; deep_item_call_site_dynamic
; deep_item_proc_static
; deep_item_proc_dynamic.
:- pragma foreign_enum("C", next_deep_item/0, [
deep_item_end - "MR_deep_item_end",
deep_item_call_site_static - "MR_deep_item_call_site_static",
deep_item_call_site_dynamic - "MR_deep_item_call_site_dynamic",
deep_item_proc_static - "MR_deep_item_proc_static",
deep_item_proc_dynamic - "MR_deep_item_proc_dynamic"
]).
:- pred is_next_item_token(int::in, next_deep_item::out) is semidet.
:- pragma foreign_proc("C",
is_next_item_token(Int::in, NextItem::out),
[promise_pure, will_not_call_mercury, thread_safe],
"
NextItem = (MR_DeepProfNextItem) Int;
switch (NextItem) {
case MR_deep_item_end:
case MR_deep_item_call_site_static:
case MR_deep_item_call_site_dynamic:
case MR_deep_item_proc_static:
case MR_deep_item_proc_dynamic:
SUCCESS_INDICATOR = MR_TRUE;
break;
default:
SUCCESS_INDICATOR = MR_FALSE;
break;
}
").
%---------------------------------------------------------------------------%
:- end_module read_profile.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink